diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile deleted file mode 100644 index 2098c57..0000000 --- a/.devcontainer/Dockerfile +++ /dev/null @@ -1,30 +0,0 @@ -ARG UBUNTU_TAG=20.04 -FROM ubuntu:"$UBUNTU_TAG" - -ENV LANG=C.UTF-8 -RUN \ - apt-get update && \ - apt-get install --assume-yes curl gcc git libgmp-dev libtinfo-dev make sudo - -ARG GHCUP_VERSION=0.1.17.4 -RUN \ - curl --output /usr/local/bin/ghcup "https://downloads.haskell.org/~ghcup/$GHCUP_VERSION/x86_64-linux-ghcup-$GHCUP_VERSION" && \ - chmod +x /usr/local/bin/ghcup && \ - ghcup --version - -ARG USER_NAME=haskell -RUN \ - useradd --create-home --shell "$( which bash )" "$USER_NAME" && \ - echo "$USER_NAME ALL=(ALL) NOPASSWD: ALL" | tee "/etc/sudoers.d/$USER_NAME" -USER "$USER_NAME" -ENV PATH="/home/$USER_NAME/.cabal/bin:/home/$USER_NAME/.ghcup/bin:$PATH" - -ARG GHC_VERSION=9.0.1 -RUN \ - ghcup install ghc "$GHC_VERSION" --set && \ - ghc --version - -ARG CABAL_VERSION=3.6.2.0 -RUN \ - ghcup install cabal "$CABAL_VERSION" --set && \ - cabal --version diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json deleted file mode 100644 index 582acff..0000000 --- a/.devcontainer/devcontainer.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "build": { - "dockerfile": "Dockerfile" - }, - "postCreateCommand": "cabal update" -} diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml deleted file mode 100644 index 0e0f3d7..0000000 --- a/.github/workflows/ci.yaml +++ /dev/null @@ -1,105 +0,0 @@ -name: CI -on: - pull_request: - branches: - - main - - master - push: - branches: - - main - - master - release: - types: - - created -jobs: - build: - strategy: - fail-fast: false - matrix: - include: - - { os: macos-11, ghc: 9.0.1, cabal: 3.6.2.0 } - - { os: ubuntu-20.04, ghc: 9.0.1, cabal: 3.6.2.0 } - - { os: windows-2019, ghc: 9.0.1, cabal: 3.6.2.0, ext: .exe } - runs-on: ${{ matrix.os }} - steps: - - uses: actions/checkout@v2 - - run: mkdir artifact - - run: mkdir artifact/${{ matrix.os }} - - id: setup-haskell - uses: haskell/actions/setup@v1 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} - - run: cabal configure --enable-tests --flags pedantic --jobs - - run: cabal freeze - - run: cat cabal.project.freeze - - uses: actions/cache@v2 - with: - path: ${{ steps.setup-haskell.outputs.cabal-store }} - key: ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-${{ hashFiles('cabal.project.freeze') }} - restore-keys: | - ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}- - ${{ matrix.os }}-${{ matrix.ghc }}- - - run: cabal build - - run: cabal install --installdir artifact/${{ matrix.os }} --install-method copy - - run: cabal test --test-show-details direct - - run: cabal check - - run: cabal sdist --output-dir artifact/${{ matrix.os }} - - uses: svenstaro/upx-action@v2 - with: - file: artifact/${{ matrix.os }}/brittany${{ matrix.ext }} - - uses: actions/upload-artifact@v2 - with: - path: artifact - name: brittany-${{ github.sha }} - - release: - needs: build - if: github.event_name == 'release' - runs-on: ubuntu-20.04 - steps: - - - uses: actions/checkout@v2 - - - uses: actions/download-artifact@v2 - with: - name: brittany-${{ github.sha }} - path: artifact - - - uses: actions/upload-release-asset@v1 - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - with: - asset_content_type: application/octet-stream - asset_name: brittany-${{ github.event.release.tag_name }}-ubuntu - asset_path: artifact/ubuntu-20.04/brittany - upload_url: ${{ github.event.release.upload_url }} - - - uses: actions/upload-release-asset@v1 - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - with: - asset_content_type: application/octet-stream - asset_name: brittany-${{ github.event.release.tag_name }}-macos - asset_path: artifact/macos-11/brittany - upload_url: ${{ github.event.release.upload_url }} - - - uses: actions/upload-release-asset@v1 - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - with: - asset_content_type: application/octet-stream - asset_name: brittany-${{ github.event.release.tag_name }}-windows.exe - asset_path: artifact/windows-2019/brittany.exe - upload_url: ${{ github.event.release.upload_url }} - - - uses: actions/upload-release-asset@v1 - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - with: - asset_content_type: application/gzip - asset_name: brittany-${{ github.event.release.tag_name }}.tar.gz - asset_path: artifact/ubuntu-20.04/brittany-${{ github.event.release.tag_name }}.tar.gz - upload_url: ${{ github.event.release.upload_url }} - - - run: cabal upload --publish --username '${{ secrets.HACKAGE_USERNAME }}' --password '${{ secrets.HACKAGE_PASSWORD }}' artifact/ubuntu-20.04/brittany-${{ github.event.release.tag_name }}.tar.gz diff --git a/.gitignore b/.gitignore index cdc020e..758506f 100644 --- a/.gitignore +++ b/.gitignore @@ -8,8 +8,5 @@ dist/ dist-newstyle/ local/ .cabal-sandbox/ +.stack-work/ cabal.sandbox.config -cabal.project.local* -cabal.project.freeze -.ghc.environment.* -result diff --git a/.hlint.yaml b/.hlint.yaml deleted file mode 100644 index 191512f..0000000 --- a/.hlint.yaml +++ /dev/null @@ -1,16 +0,0 @@ -# HLint configuration file -# https://github.com/ndmitchell/hlint -########################## - -# This file contains a template configuration file, which is typically -# placed as .hlint.yaml in the root of your project - -- ignore: { name: 'Use :' } -- ignore: { name: Eta reduce } -- ignore: { name: Move brackets to avoid $ } -- ignore: { name: Redundant $ } -- ignore: { name: Redundant bracket } -- ignore: { name: Use newtype instead of data } -- ignore: {name: "Redundant do"} -- ignore: {name: "Redundant return"} -- ignore: {name: "Use camelCase"} diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..8b62149 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,286 @@ +# Use new container infrastructure to enable caching +sudo: false + +# Do not choose a language; we provide our own build tools. +language: generic + +# Caching so the next build will be fast too. +cache: + directories: + - $HOME/.cabsnap + - $HOME/.cabal/packages + - $HOME/.stack + - $HOME/.cabal/store + # alternatively: + #- $HOME/.stack/bin + #- $HOME/.stack/precompiled + #- $HOME/.stack/programs + #- $HOME/.stack/setup-exe-cache + #- $HOME/.stack/snapshots + +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + # remove files that are regenerated by 'cabal update' + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + +# The different configurations we want to test. We have +# - BUILD=cabal which uses cabal-install(<2.0) +# - BUILD=canew which uses cabal-install 2.0 "new-build" +# - BUILD=stack which uses Stack. +# +# We set the compiler values here to tell Travis to use a different +# cache file per set of arguments. +# +# If you need to have different apt packages for each combination in the +# matrix, you can use a line such as: +# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} +matrix: + include: + # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: + # https://github.com/hvr/multi-ghc-travis + #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 + # compiler: ": #GHC 7.0.4" + # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 + # compiler: ": #GHC 7.2.2" + # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 + # compiler: ": #GHC 7.4.2" + # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 + # compiler: ": #GHC 7.6.3" + # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + #- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 + # compiler: ": #GHC 7.8.4" + # addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + #- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 + # compiler: ": #GHC 7.10.3" + # addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + + ##### CABAL ##### + + - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.0.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.2.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.2.1" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + + # Build with the newest GHC and cabal-install. This is an accepted failure, + # see below. + #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 + # compiler: ": #GHC HEAD" + # addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + + ##### CABAL DIST CHECK + + - env: BUILD=cabaldist GHCVER=8.2.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal 8.2.1 dist" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + + ##### CANEW ##### + + - env: BUILD=canew GHCVER=8.2.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #cabal new 8.2.1" + addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + + ##### STACK ##### + + # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS + # variable, such as using --stack-yaml to point to a different file. + - env: BUILD=stack ARGS="" + compiler: ": #stack default" + addons: {apt: {packages: [libgmp-dev]}} + + #- env: BUILD=stack ARGS="--resolver lts-2" + # compiler: ": #stack 7.8.4" + # addons: {apt: {packages: [libgmp-dev]}} + #- env: BUILD=stack ARGS="--resolver lts-3" + # compiler: ": #stack 7.10.2" + # addons: {apt: {packages: [libgmp-dev]}} + #- env: BUILD=stack ARGS="--resolver lts-6" + # compiler: ": #stack 7.10.3" + # addons: {apt: {packages: [libgmp-dev]}} + #- env: BUILD=stack ARGS="--resolver lts-7" + # compiler: ": #stack 8.0.1" + # addons: {apt: {packages: [libgmp-dev]}} + - env: BUILD=stack ARGS="--resolver lts-8" + compiler: ": #stack 8.0.2" + addons: {apt: {packages: [libgmp-dev]}} + + # Nightly builds are allowed to fail + - env: BUILD=stack ARGS="--resolver nightly" + compiler: ": #stack nightly" + addons: {apt: {packages: [libgmp-dev]}} + + # Build on macOS in addition to Linux + - env: BUILD=stack ARGS="" + compiler: ": #stack default osx" + os: osx + + # Travis includes an macOS which is incompatible with GHC 7.8.4 + #- env: BUILD=stack ARGS="--resolver lts-2" + # compiler: ": #stack 7.8.4 osx" + # os: osx + + #- env: BUILD=stack ARGS="--resolver lts-3" + # compiler: ": #stack 7.10.2 osx" + # os: osx + #- env: BUILD=stack ARGS="--resolver lts-6" + # compiler: ": #stack 7.10.3 osx" + # os: osx + #- env: BUILD=stack ARGS="--resolver lts-7" + # compiler: ": #stack 8.0.1 osx" + # os: osx + #- env: BUILD=stack ARGS="--resolver lts-8" + # compiler: ": #stack 8.0.2 osx" + # os: osx + #- env: BUILD=stack ARGS="--resolver nightly" + # compiler: ": #stack nightly osx" + # os: osx + + allow_failures: + #- env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 + - env: BUILD=stack ARGS="--resolver nightly" + +before_install: +# Using compiler above sets CC to an invalid value, so unset it +- unset CC + +# We want to always allow newer versions of packages when building on GHC HEAD +- CABALARGS="" +- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi + +# Download and unpack the stack executable +- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH +- mkdir -p ~/.local/bin +- | + if [ `uname` = "Darwin" ] + then + travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin + else + travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + fi + + # Use the more reliable S3 mirror of Hackage + #mkdir -p $HOME/.cabal + #echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config + #echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config + + #if [ "$CABALVER" != "1.16" ] + #then + # echo 'jobs: $ncpus' >> $HOME/.cabal/config + #fi +- PKGNAME='brittany' +- JOBS='2' +- | + function better_wait() { + date + time "$*" & # send the long living command to background! + + set +x + MINUTES=0 + LIMIT=30 + while kill -0 $! >/dev/null 2>&1; do + echo -n -e " \b" # never leave evidences! + + if [ $MINUTES == $LIMIT ]; then + break; + fi + + MINUTES=$((MINUTES+1)) + + sleep 60 + done + set -x + } + +install: +- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" +- if [ -f configure.ac ]; then autoreconf -i; fi +- | + set -ex + case "$BUILD" in + stack) + stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies + ;; + cabal*) + cabal --version + echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; + then + zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >$HOME/.cabal/packages/hackage.haskell.org/00-index.tar; + fi + travis_retry cabal update -v + sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt + sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt + + # check whether current requested install-plan matches cached package-db snapshot + if diff -u $HOME/.cabsnap/installplan.txt installplan.txt; + then + echo "cabal build-cache HIT"; + rm -rfv .ghc; + cp -a $HOME/.cabsnap/ghc $HOME/.ghc; + cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; + else + echo "cabal build-cache MISS"; + rm -rf $HOME/.cabsnap; + mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; + cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M500M"; + fi + + # snapshot package-db on cache miss + if [ ! -d $HOME/.cabsnap ]; + then + echo "snapshotting package-db to build-cache"; + mkdir $HOME/.cabsnap; + cp -a $HOME/.ghc $HOME/.cabsnap/ghc; + cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; + fi + ;; + canew) + cabal --version + travis_retry cabal update -v + echo 'packages: .' > cabal.project + rm -f cabal.project.freeze + cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep + cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep + ;; + esac + set +ex + +script: +- | + set -ex + case "$BUILD" in + stack) + better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M" + ;; + cabal) + if [ -f configure.ac ]; then autoreconf -i; fi + cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging + better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M" # this builds all libraries and executables (including tests/benchmarks) + cabal test + ;; + cabaldist) + # cabal check + cabal sdist # tests that a source-distribution can be generated + + # Check that the resulting source distribution can be built & installed. + # If there are no other `.tar.gz` files in `dist`, this can be even simpler: + # `cabal install --force-reinstalls dist/*-*.tar.gz` + SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && + (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M") + ;; + canew) + better_wait cabal new-build -j$JOBS --disable-tests --disable-benchmarks + better_wait cabal new-build -j$JOBS --enable-tests --enable-benchmarks + cabal new-test --ghc-options="-j1 +RTS -M500M" + ;; + esac + set +ex diff --git a/.vscode/extensions.json b/.vscode/extensions.json deleted file mode 100644 index c51a4b2..0000000 --- a/.vscode/extensions.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "recommendations": [ - "taylorfausak.purple-yolk" - ] -} diff --git a/.vscode/settings.json b/.vscode/settings.json deleted file mode 100644 index 8b52b40..0000000 --- a/.vscode/settings.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "purple-yolk.brittany.command": "cabal exec -- brittany --write-mode inplace", - "purple-yolk.ghci.command": "cabal repl --repl-options -ddump-json", - "purple-yolk.hlint.command": "false", - "purple-yolk.hlint.onSave": false -} diff --git a/ChangeLog.md b/ChangeLog.md index baf8314..236a7ad 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,231 +1,5 @@ # Revision history for brittany -## 0.14.0.0 -- November 2021 - -* #357: Added support for GHC 9.0. Dropped support for all other versions of GHC. - * ab59e9acc3069551ac4132321b285d000f5f5691: Removed runtime dependency on `ghc-paths`. - * fa8365a7fa9372043d5a1018f2f7669ce3853edd: Started providing pre-built binaries for Linux, MacOS, and Windows. - * Many other changes to Brittany's internals and exposed Haskell interface, but (hopefully) no changes to its command-line interface. - -## 0.13.1.2 -- May 2021 - -* #347: Allowed hspec 2.8. Thanks @felixonmars! - -## 0.13.1.1 -- February 2021 - -* #333: Allowed random 1.2. Thanks @felixonmars! -* #334: Updated Arch install instructions. Thanks @ahstro! -* #343: Allowed ghc-exactprint 0.6.4. Thanks @maralorn! - -## 0.13.1.0 -- December 2020 - -* #330: Started sorting imports. Thanks @expipiplus1! - -## 0.13.0.0 -- December 2020 - -* #324: Added support for GHC 8.10. - * Dropped support for GHC 8.4, 8.2, and 8.0. - * Thanks @jneira, @bubba, @infinity0, and @expipiplus1! - -## 0.12.2.0 -- November 2020 - -* #207: Fix newtype indent in associated type family. -* #231: Improve comments-affecting-layout behaviour for tuples. -* #259: Data declaration for newtype and records. Thanks @eborden! -* #263: Fix non-idempotent newlines with comment + where. -* #273: Error handling. -* #281: Fix moving comment in export list (haddock header). -* #286: Fix comments in instance/type instances. -* #287: Add support for pattern synonyms. Thanks @RaoulHC! -* #293: Expose main function as a module. Thanks @soareschen! -* #303: Readme: Supports 8.8. Thanks @andys8! -* #311: Allows aeson-1.5.*. Thanks @jkachmar! -* #313: Nondecreasing export list formatting. Thanks @expipiplus1! - -## 0.12.1.1 -- December 2019 - -* Bugfixes: - - Fix layouting regression of record update for many/large fields - - Fix whitespace regression on ExplicitForall notation - (`foo :: forall a . Show a => a -> a`, note the double space) - introduced in 0.12. (#264) - - Fix roundtripping of type equality constraint - `f :: ((~) a b) => a -> b` (#267) -* One experimental feature addition: Turning brace notation semicolons into - newlines when formatting (see #270) - -## 0.12.1.0 -- September 2019 - -* Support ghc-8.8 -* Support for OverloadedLabels extension - (thanks to Evan Rutledge Borden @eborden) -* Support for Implicit Params extension (thanks to pepe iborra @pepeiborra) -* Add flag `--no-user-config` to enable only using manually passed config -* Disable the performance test suite by default to prevent spurious failures - on certain CI setups. The github/travis brittany CI still has all tests - enabled. See the `brittany-test-perf` flag in the cabal file. -* Bugfixes: - - Fix one wandering-comment bug for let-in expressions - - Fix invalid result for prefix operator pattern matches - - Fix lambda expression with laziness/strictness annotation - - Fix parenthesis handling for infix pattern matches with 3+ arguments -* Changes to layouting behaviour: - - For pattern matching and data/instance definitions, the usage of - parenthesis is now "normalized", i.e. superfluous parens are removed by - brittany. - -## 0.12.0.0 -- June 2019 - -* Support for ghc-8.6 (basic support, not necessarily all new syntactic - extensions) -* Support -XExplicitNamespaces and -XPatternSynonyms -* Allow a --dry-run sort of operation via flag "-c/--check-mode" - (thanks to Doug Beardsley @mightybyte) -* Include file name in errors about unsupported syntax nodes (thanks to @5outh) -* Partially implement layouting class instances: Layouts children, but - falls back on ghc-exactprint for the instance head - (thanks to Rupert Horlick @ruhatch) -* Implement layouting for type synonyms (thanks to Rupert Horlick @ruhatch) -* Support -XMagicHash, -XUnboxedTuples (thanks to Sergey Vinokurov @sergv) -* Support -XQuasiQuotes (no formatting applied to the splices; they are simply - retained without causing the dreaded "Unknown construct: HsSpliceE{}") - - `lconfig_allowHangingQuasiQuotes` controls whether multi-line - QuasiQuotes are allowed to start at the end of the current line, or - whether they are always placed in new lines. -* Bugfixes: - - Fix rare-case alignment bug with IndentPolicyMultiple (#144) - - Make inline layout config apply to module header (#151) - - Fix unaligned import-hiding layout (#150) - - Fix idempotence violation for comments around if-then-else (#167) - - Fix comments having an effect on far-away parent node's layout (#159) - - Fix imports of type operators ("symbolic data types") - (thanks to Phil Hazelden @ChickenProp) - - Work around GHC and cabal-install misfeature ".ghc.environment files" - that could break brittany in unexpected and hard-to-understand ways - - Stop removing empty lines before `where` keyword in a couple of cases - - Fix functions with mixing prefix/infix style causing error (#234) -* Changes to layout: - - Align usage of spaces for record update vs record construction (#126) - - More indentation to import-hiding-paragraph (follow-up to #150 fix) - - Record construction and update now are layouted in the same way - (thanks to Evan Rutledge Borden @eborden) - - Stop allowing single-line layout when there are comments between - arguments (#214) (thanks to @matt-noonan) -* Various build-instructions and editor integrations - -## 0.11.0.0 -- May 2018 - -* Support for ghc-8.4 -* Implement inline-config - e.g. "-- brittany --indent=4" - - respects the following comment forms as input: - - ~~~~ - source comment affected target - ====================================================== - "-- brittany CONFIG" whole module - "-- brittany-next-binding CONFIG" next binding - "-- brittany-disable-next-binding" next binding - "-- brittany @ myExampleFunc CONFIG" `myExampleFunc` - ~~~~ - - multiline-comments are supported too, although - the specification must still be a single line. E.g. - - > "{- brittany --columns 50 -}" - - CONFIG is either: - - 1) one or more flags in the form of what brittany accepts - on the commandline, e.g. "--columns 50", or - 2) one or more specifications in the form of what brittany - accepts in its config files for the layouting config - (a one-line yaml document), e.g. "{ lconfig_cols: 50 }" -* Implement `IndentPolicyMultiple` (thanks to Bryan Richter @chreekat) - Restrict indentation amounts to `n * indentAmount` -* Implement `--obfuscate` that replaces non-keyword identifiers with random - names -* Do not write files unless there are changes (don't update modtime) - (`--write-mode=inplace`) (#93) -* Bugfixes: - - Fix empty function constraints (`() => IO ()`) (#133) - - Fix overflowing columns caused by aligning with surrounding lines - for certain complex cases - - Implement hacky workaround for `type instance`s (`-XTypeFamilies`) (#89) -* Layouting changes: - - On default settings, allow single-line module header - `module MyModule where` when no exports - - Fix one case of non-optimal layouting for if-then-else - - Allow same-line let binding inside do-notation with - `IndentPolicyLeft/Multiple` and `indentAmount>=4` - -## 0.10.0.0 -- March 2018 - -* Implement module/exports/imports layouting (thanks to sniperrifle2004) -* Expose config paths/parsing functions (thanks to Alexey Raga) -* Bugfixes: - - Fix layouting of `NOINLINE` pragma - - Fix ticked type operator (e.g. `':-`) losing tick (#125) - - Fix alignment issue with cases involving operators (#65) - - Fix comments in tuples being dropped (#37) - - Fix comment placements with let-in (#110) -* Layouting changes: - - Align arguments only if it is the same function being called (#128) - - Do not use single-line layout when infix operator expression contains - comments (#111) -* New layouting config items: - - `lconfig_importColumn`/`--import-col`: column for import items - - `lconfig_importAsColumn`/`--import-as-col`: column for the "as" name of - a module - - `lconfig_reformatModulePreamble`: controls module/export/import layouting - (default True) - - `lconfig_allowSingleLineExportList`: permit one-line module header, e.g. - `module Main (main)` (default False) - -## 0.9.0.1 -- February 2018 - -* Support `TupleSections` (thanks to Matthew Piziak) -* Bugfixes: - - Fix Shebang handling with stdin input (#92) - - Fix bug that effectively deleted strict/lazy matches (BangPatterns) (#116) - - Fix infix operator whitespace bug (#101, #114) - - Fix help command output and its layouting (#103) - - Fix crash when config dir does not exist yet (#115) -* Layouting changes: - - no space after opening non-tuple parenthesis even for multi-line case - - use spaces around infix operators (applies to sections and in pattern - matches) - - Let-in is layouted more flexibly in fewer lines, if possible - (thanks to Evan Borden) - -## 0.9.0.0 -- December 2017 - -* Change default global config path (use XDG spec) - Existing config should still be respected, so this should not break - compatibility -* Support per-project config -* ! Slight rework of the commandline interface: - - Support multiple inputs and outputs - - Support inplace-transformation for multiple files via - `--write-mode=inplace` -* Implement `IndentPolicyLeft` - the indentation mode that never adds more - than the base indentation for nested parts (no hanging indentation) - - (thanks to Evan Borden) -* Fix bug that manifested in bad output for (top-level) template haskell splices -* Extension support: - - RecordWildCards - - RecursiveDo (was only partially supported previously) -* Layouting Bugfixes: - - Properly reproduce parentheses around kind signatures - - Fix issue around promoted lists - (example good: `'[ 'True]` bad: `'['True]`) - - Trim text from exactprint used as workaround for unknown nodes - (unsupported extension workaround) -* Layouting changes - - Insert spaces around operator in sections - ## 0.8.0.3 -- September 2017 * Support for ghc-8.2.1 diff --git a/README.md b/README.md index d03fb97..d32a189 100644 --- a/README.md +++ b/README.md @@ -1,11 +1,4 @@ -# brittany [](https://hackage.haskell.org/package/brittany) [](https://www.stackage.org/package/brittany) [](http://travis-ci.org/lspitzner/brittany) - -:warning: -This project is effectively unmaintained! -I ([@tfausak](https://github.com/tfausak)) would recommend switching to another formatter. -At time of writing (2022-11-11), I would suggest [Ormolu](https://github.com/tweag/ormolu). -Or if you prefer some configuration, I would suggest [Fourmolu](https://github.com/fourmolu/fourmolu). - +# brittany [](https://hackage.haskell.org/package/brittany) [](https://www.stackage.org/package/brittany) [](http://travis-ci.org/lspitzner/brittany) haskell source code formatter  @@ -15,12 +8,13 @@ haskell source code formatter This project's goals roughly are to: - Always retain the semantics of the source being transformed; -- Be idempotent; +- Be idempotent (this also directly ensures that only valid haskell is + produced); - Support the full GHC-haskell syntax including syntactic extensions (but excluding `-XCPP` which is too hard); - Retain newlines and comments unmodified; - Be clever about using the available horizontal space while not overflowing - the column maximum unless it cannot be avoided; + it if it cannot be avoided; - Be clever about aligning things horizontally (this can be turned off completely however); - Have linear complexity in the size of the input. @@ -33,12 +27,11 @@ size of the input (although the constant factor is not small). See But brittany is not finished yet, and there are some open issues that yet require fixing: -- **only the module header (imports/exports), type-signatures and - function/value bindings** are processed; - other module elements (data-decls, classes, instances, etc.) +- **only type-signatures and function/value bindings** are processed; + other module elements (data-decls, classes, instances, imports/exports etc.) are not transformed in any way; this extends to e.g. **bindings inside class instance definitions** - they **won't be touched** (yet). -- By using `ghc-exactprint` as the parser, brittany supports full GHC +- By using `ghc-exactprint` as the parser, brittany supports full GHC including extensions, but **some of the less common syntactic elements (even of 2010 haskell) are not handled**. - **There are some known issues regarding handling of in-source comments.** @@ -46,98 +39,58 @@ require fixing: be detected and the user will get an error); there are other cases where comments are moved slightly; there are also cases where comments result in wonky newline insertion (although this should be a purely aesthetic issue.) - -## Try without Installing - -You can [paste haskell code over here](https://hexagoxel.de/brittany/) -to test how it gets formatted by brittany. (Rg. privacy: the server does -log the size of the input, but _not_ the full input/output of requests.) +- ~~There is an **open performance issue on large inputs** (due to an + accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.~~ + (fixed in `0.8.0.3`) # Other usage notes -- Supports GHC version `9.0.x`. -- included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) +- Supports GHC versions `8.0.*` and `8.2.*`. - config (file) documentation is lacking. - some config values can not be configured via commandline yet. -- uses/creates user config file in `~/.config/brittany/config.yaml`; - also reads (the first) `brittany.yaml` found in current or parent - directories. +- uses/creates user config file in `~/.brittany/config.yaml`; + also reads `brittany.yaml` in current dir if present. # Installation +- via `cabal` "old-build" + + ~~~~.sh + # optionally: + # mkdir brittany + # cd brittany + # cabal sandbox init + cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_0 + ~~~~ + +- via `cabal new-build` + + ~~~~.sh + cabal unpack brittany + cd brittany-0.8.0.2 + # cabal new-configure -w $PATH_TO_GHC_8_0 + cabal new-build exe:brittany + # and it should be safe to just copy the executable, e.g. + cp `./find dist-newstyle/build/ -type f -name brittany` $HOME/.cabal/bin/ + ~~~~ + - via `stack` ~~~~.sh - stack install brittany # --resolver lts-16.31 + git clone https://github.com/lspitzner/brittany.git + cd brittany + stack install ~~~~ - If you use an lts that includes brittany this should just work; otherwise - you may want to clone the repo and try again. - -- via `cabal` - - Due to constant changes to the cabal UI, I have given up on making sure - these instructions work before releases. Please do not expect these - instructions to be up-to-date; they may produce incomprehensible error - messages, they may be broken otherwise, they may work now but break with - the next cabal release. Thanks for your understanding, and feel free to - open issues for any problems you encounter. -- lennart - - If you are using cabal-3.0, using - `cabal install brittany --installdir=$HOME/.cabal/bin` - might work. Keep in mind that cabal merely puts a symlink to the "store" - into the installdir, so you have to re-install if you ever clean your - store. On cabal-2.4, try `cabal v2-install brittany`. On cabal-2.2 or - earlier you might be succesful using - ```cabal new-build exe:brittany; cp `find dist-newstyle/ -name brittany -type f | xargs -x ls -t | head -n1` $HOME/.cabal/bin/```. - Alternatively, you can also use the v1-approach with sandboxes as - `cabal v1-sandbox init; cabal v1-install brittany --bindir=$HOME/.cabal/bin`. - - (TODO: These instructions are more confusing than helpful. I am inclined - to just remove them.) - -- on ArchLinux: - ~~~~.sh - pacman -S haskell-brittany - ~~~~ - -# Development tips - -# Editor Integration - -#### Sublime text - [In this gist](https://gist.github.com/lspitzner/097c33177248a65e7657f0c6d0d12075) - I have described a haskell setup that includes a shortcut to run brittany formatting. -#### VSCode - [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) - connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGabriel. -#### Via HLS - [haskell-language-server](https://github.com/haskell/haskell-language-server) - includes a `brittany` plugin that directly uses the brittany library. - Relevant for any editors that properly support the language-server-protocol. -#### Neovim / Vim 8 - The [Neoformat](https://github.com/sbdchd/neoformat) plugin comes with support for - brittany built in. -#### Atom - [Atom Beautify](https://atom.io/packages/atom-beautify) supports brittany as a formatter for Haskell. Since the default formatter is set to hindent, you will need to change this setting to brittany, after installing the extension. -#### Emacs - [format-all](https://github.com/lassik/emacs-format-all-the-code) support brittany as the default formatter for Haskell. # Usage -- Default mode of operation: Transform a single module, from `stdin` to `stdout`. - Can pass one or multiple files as input, and there is a flag to override them - in place instead of using `stdout` (since 0.9.0.0). So: - - ~~~~ .sh - brittany # stdin -> stdout - brittany mysource.hs # ./mysource.hs -> stdout - brittany --write-mode=inplace *.hs # apply formatting to all ./*.hs inplace - ~~~~ - +- Currently one mode of operation: Transform a single module. By default read + from `stdin` and written to `stdout`, but commandline arguments allow to + read/write from/to files. - For stdin/stdout usage it makes sense to enable certain syntactic extensions by default, i.e. to add something like this to your - `~/.config/brittany/config.yaml` (execute `brittany` once to create default): + `~/.brittany/config.yaml` (execute `brittany` once to create default): ~~~~ conf_forward: @@ -156,32 +109,13 @@ log the size of the input, but _not_ the full input/output of requests.) - -XBangPatterns ~~~~ -# Feature Requests, Contribution, Documentation +# Implementation/High-level Documentation -For a long time this project has had a single maintainer, and as a consequence -there have been some mildly large delays for reacting to feature requests -and even PRs. - -Sorry about that. - -The good news is that this project is getting sponsored by PRODA LTD, and two -previous contributors, Evan Borden and Taylor Fausak, have agreed on helping -with organisational aspects. Thanks! - -Still, this project has a long queue of very sensible feature requests, so it -may take some time until new ones get our attention. But with the help of -the co-maintainers, at least the reaction-times on PRs and the frequency -of releases should improve significantly. - -If you are interested in making your own contributions, there is -a good amount of high-level documentation at - -[the documentation index](doc/implementation/index.md) +[See the documentation index](doc/implementation/index.md) # License -Copyright (C) 2016-2019 Lennart Spitzner\ -Copyright (C) 2019 PRODA LTD +Copyright (C) 2016-2017 Lennart Spitzner This program is free software: you can redistribute it and/or modify it under the terms of the diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/brittany.cabal b/brittany.cabal index ad87944..957fb06 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,149 +1,397 @@ -cabal-version: 2.2 - name: brittany -version: 0.14.0.2 +version: 0.8.0.3 synopsis: Haskell source code formatter -description: +description: { See <https://github.com/lspitzner/brittany/blob/master/README.md the README>. . If you are interested in the implementation, have a look at <https://github.com/lspitzner/brittany/blob/master/doc/implementation/theory.md this document>; . The implementation is documented in more detail <https://github.com/lspitzner/brittany/blob/master/doc/implementation/index.md here>. -license: AGPL-3.0-only +} +license: AGPL-3 license-file: LICENSE author: Lennart Spitzner maintainer: Lennart Spitzner <hexagoxel@hexagoxel.de> -copyright: Copyright (C) 2016-2019 Lennart Spitzner - Copyright (C) 2019 PRODA LTD +copyright: Copyright (C) 2016-2017 Lennart Spitzner category: Language build-type: Simple +cabal-version: >=1.18 homepage: https://github.com/lspitzner/brittany/ bug-reports: https://github.com/lspitzner/brittany/issues -extra-doc-files: +extra-doc-files: { ChangeLog.md README.md doc/implementation/*.md -extra-source-files: - data/brittany.yaml - data/*.hs +} +extra-source-files: { + src-literatetests/tests.blt +} -source-repository head +source-repository head { type: git location: https://github.com/lspitzner/brittany.git +} -flag pedantic +flag brittany-dev + description: dev options default: False - description: Enables @-Werror@, which turns warnings into errors. manual: True -common library - build-depends: - , aeson ^>= 2.0.1 - , base ^>= 4.15.0 - , butcher ^>= 1.3.3 - , bytestring ^>= 0.10.12 - , cmdargs ^>= 0.10.21 - , containers ^>= 0.6.4 - , czipwith ^>= 1.0.1 - , data-tree-print ^>= 0.1.0 - , deepseq ^>= 1.4.5 - , directory ^>= 1.3.6 - , extra ^>= 1.7.10 - , filepath ^>= 1.4.2 - , ghc ^>= 9.0.1 - , ghc-boot ^>= 9.0.1 - , ghc-boot-th ^>= 9.0.1 - , ghc-exactprint ^>= 0.6.4 - , monad-memo ^>= 0.5.3 - , mtl ^>= 2.2.2 - , multistate ^>= 0.8.0 - , pretty ^>= 1.1.3 - , random ^>= 1.2.1 - , safe ^>= 0.3.19 - , semigroups ^>= 0.19.2 - , strict ^>= 0.4.0 - , syb ^>= 0.7.2 - , text ^>= 1.2.5 - , transformers ^>= 0.5.6 - , uniplate ^>= 1.6.13 - , yaml ^>= 0.11.7 - default-language: Haskell2010 - ghc-options: - -Weverything - -Wno-all-missed-specialisations - -Wno-incomplete-uni-patterns - -Wno-missing-deriving-strategies - -Wno-missing-export-lists - -Wno-missing-import-lists - -Wno-missing-local-signatures - -Wno-missing-safe-haskell-mode - -Wno-monomorphism-restriction - -Wno-prepositive-qualified-module - -Wno-safe - -Wno-unsafe +flag brittany-dev-lib + description: set buildable false for anything but lib + default: False + manual: True - if flag(pedantic) - ghc-options: -Werror - -common executable - import: library - - build-depends: brittany - ghc-options: - -rtsopts - -threaded - -Wno-implicit-prelude - -Wno-unused-packages - -library - import: library - - autogen-modules: Paths_brittany - hs-source-dirs: source/library - exposed-modules: +library { + default-language: + Haskell2010 + hs-source-dirs: + src + install-includes: { + srcinc/prelude.inc + } + exposed-modules: { Language.Haskell.Brittany Language.Haskell.Brittany.Internal - Language.Haskell.Brittany.Internal.Backend - Language.Haskell.Brittany.Internal.BackendUtils + Language.Haskell.Brittany.Internal.Prelude + Language.Haskell.Brittany.Internal.PreludeUtils + Language.Haskell.Brittany.Internal.Types + Language.Haskell.Brittany.Internal.Utils Language.Haskell.Brittany.Internal.Config Language.Haskell.Brittany.Internal.Config.Types Language.Haskell.Brittany.Internal.Config.Types.Instances - Language.Haskell.Brittany.Internal.ExactPrintUtils + Paths_brittany + } + other-modules: { Language.Haskell.Brittany.Internal.LayouterBasics - Language.Haskell.Brittany.Internal.Layouters.DataDecl + Language.Haskell.Brittany.Internal.Backend + Language.Haskell.Brittany.Internal.BackendUtils + Language.Haskell.Brittany.Internal.ExactPrintUtils + Language.Haskell.Brittany.Internal.Layouters.Type Language.Haskell.Brittany.Internal.Layouters.Decl Language.Haskell.Brittany.Internal.Layouters.Expr - Language.Haskell.Brittany.Internal.Layouters.IE - Language.Haskell.Brittany.Internal.Layouters.Import - Language.Haskell.Brittany.Internal.Layouters.Module - Language.Haskell.Brittany.Internal.Layouters.Pattern Language.Haskell.Brittany.Internal.Layouters.Stmt - Language.Haskell.Brittany.Internal.Layouters.Type - Language.Haskell.Brittany.Internal.Obfuscation - Language.Haskell.Brittany.Internal.ParseModule - Language.Haskell.Brittany.Internal.Prelude - Language.Haskell.Brittany.Internal.PreludeUtils + Language.Haskell.Brittany.Internal.Layouters.Pattern Language.Haskell.Brittany.Internal.Transformations.Alt - Language.Haskell.Brittany.Internal.Transformations.Columns Language.Haskell.Brittany.Internal.Transformations.Floating - Language.Haskell.Brittany.Internal.Transformations.Indent Language.Haskell.Brittany.Internal.Transformations.Par - Language.Haskell.Brittany.Internal.Types - Language.Haskell.Brittany.Internal.Utils - Language.Haskell.Brittany.Main - Paths_brittany + Language.Haskell.Brittany.Internal.Transformations.Columns + Language.Haskell.Brittany.Internal.Transformations.Indent + } + ghc-options: { + -Wall + -fno-warn-unused-imports + -fno-warn-redundant-constraints + } + if flag(brittany-dev) { + ghc-options: -O0 -Werror -fobject-code + } + build-depends: + { base >=4.9 && <4.11 + , ghc >=8.0.1 && <8.3 + , ghc-paths >=0.1.0.9 && <0.2 + , ghc-exactprint >=0.5.3.0 && <0.6 + , transformers >=0.5.2.0 && <0.6 + , containers >=0.5.7.1 && <0.6 + , mtl >=2.2.1 && <2.3 + , text >=1.2 && <1.3 + , multistate >=0.7.1.1 && <0.8 + , syb >=0.6 && <0.8 + , neat-interpolation >=0.3.2 && <0.4 + , data-tree-print + , pretty >=1.1.3.3 && <1.2 + , bytestring >=0.10.8.1 && <0.11 + , directory >=1.2.6.2 && <1.4 + , butcher >=1.1.0.0 && <1.2 + , yaml >=0.8.18 && <0.9 + , aeson >=1.0.1.0 && <1.3 + , extra >=1.4.10 && <1.7 + , uniplate >=1.6.12 && <1.7 + , strict >=0.3.2 && <0.4 + , monad-memo >=0.4.1 && <0.5 + , unsafe >=0.0 && <0.1 + , safe >=0.3.9 && <0.4 + , deepseq >=1.4.2.0 && <1.5 + , either >=4.4.1.1 && <4.5 + , semigroups >=0.18.2 && <0.19 + , cmdargs >=0.10.14 && <0.11 + , czipwith >=1.0.0.0 && <1.1 + , ghc-boot-th >=8.0.1 && <8.3 + } + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + include-dirs: + srcinc +} executable brittany - import: executable - - hs-source-dirs: source/executable - main-is: Main.hs - -test-suite brittany-test-suite - import: executable - + if flag(brittany-dev-lib) { + buildable: False + } else { + buildable: True + } + main-is: Main.hs + other-modules: { + Paths_brittany + } + -- other-extensions: build-depends: - , hspec ^>= 2.8.3 - hs-source-dirs: source/test-suite - main-is: Main.hs - type: exitcode-stdio-1.0 + { brittany + , base + , ghc + , ghc-paths + , ghc-exactprint + , transformers + , containers + , mtl + , text + , multistate + , syb + , neat-interpolation + , data-tree-print + , pretty + , bytestring + , directory + , butcher + , yaml + , aeson + , extra + , uniplate + , strict + , monad-memo + , unsafe + , safe + , deepseq + , either + , semigroups + , cmdargs + , czipwith + , ghc-boot-th + , hspec >=2.4.1 && <2.5 + , filepath >=1.4.1.0 && <1.5 + } + hs-source-dirs: src-brittany + default-language: Haskell2010 + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -fno-spec-constr + -fno-warn-unused-imports + -fno-warn-redundant-constraints + -rtsopts + -with-rtsopts "-M2G" + } + if flag(brittany-dev) { + ghc-options: + -O0 + -Werror + -fobject-code + -fprof-auto + -fprof-cafs + } + +test-suite unittests + if flag(brittany-dev-lib) { + buildable: False + } else { + buildable: True + } + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: + { brittany + , base + , ghc + , ghc-paths + , ghc-exactprint + , transformers + , containers + , mtl + , text + , multistate + , syb + , neat-interpolation + , data-tree-print + , pretty + , bytestring + , directory + , butcher + , yaml + , aeson + , extra + , uniplate + , strict + , monad-memo + , unsafe + , safe + , deepseq + , either + , semigroups + , cmdargs + , czipwith + , ghc-boot-th + , hspec >=2.4.1 && <2.5 + } + ghc-options: -Wall + main-is: TestMain.hs + other-modules: TestUtils + AsymptoticPerfTests + hs-source-dirs: src-unittests + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -fno-warn-unused-imports + -rtsopts + -with-rtsopts "-M2G" + } + if flag(brittany-dev) { + ghc-options: -O0 -Werror -fobject-code + } + +test-suite littests + if flag(brittany-dev-lib) { + buildable: False + } else { + buildable: True + } + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: + { brittany + , base + , ghc + , ghc-paths + , ghc-exactprint + , transformers + , containers + , mtl + , text + , multistate + , syb + , neat-interpolation + , data-tree-print + , pretty + , bytestring + , directory + , butcher + , yaml + , aeson + , extra + , uniplate + , strict + , monad-memo + , unsafe + , safe + , deepseq + , either + , semigroups + , cmdargs + , czipwith + , ghc-boot-th + , hspec >=2.4.1 && <2.5 + , parsec >=3.1.11 && <3.2 + } + ghc-options: -Wall + main-is: Main.hs + other-modules: + hs-source-dirs: src-literatetests + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -fno-warn-unused-imports + -rtsopts + -with-rtsopts "-M2G" + } + if flag(brittany-dev) { + ghc-options: -O0 -Werror -fobject-code + } + +test-suite libinterfacetests + if flag(brittany-dev-lib) { + buildable: False + } else { + buildable: True + } + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: + { brittany + , base + , text + , transformers + , hspec >=2.4.1 && <2.5 + } + ghc-options: -Wall + main-is: Main.hs + other-modules: + hs-source-dirs: src-libinterfacetests + default-extensions: { + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -fno-warn-unused-imports + -rtsopts + -with-rtsopts "-M2G" + } diff --git a/brittany.yaml b/brittany.yaml deleted file mode 100644 index b85e4ad..0000000 --- a/brittany.yaml +++ /dev/null @@ -1,4 +0,0 @@ -conf_layout: - lconfig_columnAlignMode: - tag: ColumnAlignModeDisabled - lconfig_indentPolicy: IndentPolicyLeft diff --git a/cabal.project b/cabal.project deleted file mode 100644 index 39d048c..0000000 --- a/cabal.project +++ /dev/null @@ -1,9 +0,0 @@ -packages: . - -allow-newer: - -- https://github.com/lspitzner/butcher/issues/7 - , butcher:base - -- https://github.com/lspitzner/data-tree-print/pull/2 - , data-tree-print:base - -- https://github.com/lspitzner/multistate/pull/8 - , multistate:base diff --git a/data/Test1.hs b/data/Test1.hs deleted file mode 100644 index 44e6262..0000000 --- a/data/Test1.hs +++ /dev/null @@ -1 +0,0 @@ -func :: a -> a diff --git a/data/Test10.hs b/data/Test10.hs deleted file mode 100644 index f1b8e0d..0000000 --- a/data/Test10.hs +++ /dev/null @@ -1,3 +0,0 @@ -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) diff --git a/data/Test100.hs b/data/Test100.hs deleted file mode 100644 index f6643c0..0000000 --- a/data/Test100.hs +++ /dev/null @@ -1 +0,0 @@ -func = klajsdas klajsdas klajsdas diff --git a/data/Test101.hs b/data/Test101.hs deleted file mode 100644 index 57bac0e..0000000 --- a/data/Test101.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd diff --git a/data/Test102.hs b/data/Test102.hs deleted file mode 100644 index b361b53..0000000 --- a/data/Test102.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas - lakjsdlajsdljas - lakjsdlajsdljas diff --git a/data/Test103.hs b/data/Test103.hs deleted file mode 100644 index 2b2b052..0000000 --- a/data/Test103.hs +++ /dev/null @@ -1 +0,0 @@ -func = (1 +) diff --git a/data/Test104.hs b/data/Test104.hs deleted file mode 100644 index e8f99be..0000000 --- a/data/Test104.hs +++ /dev/null @@ -1 +0,0 @@ -func = (+ 1) diff --git a/data/Test105.hs b/data/Test105.hs deleted file mode 100644 index 699ead3..0000000 --- a/data/Test105.hs +++ /dev/null @@ -1 +0,0 @@ -func = (1 `abc`) diff --git a/data/Test106.hs b/data/Test106.hs deleted file mode 100644 index ccaa551..0000000 --- a/data/Test106.hs +++ /dev/null @@ -1 +0,0 @@ -func = (`abc` 1) diff --git a/data/Test107.hs b/data/Test107.hs deleted file mode 100644 index 99b30ec..0000000 --- a/data/Test107.hs +++ /dev/null @@ -1 +0,0 @@ -func = (abc, def) diff --git a/data/Test108.hs b/data/Test108.hs deleted file mode 100644 index 90f6d90..0000000 --- a/data/Test108.hs +++ /dev/null @@ -1 +0,0 @@ -func = (abc, ) diff --git a/data/Test109.hs b/data/Test109.hs deleted file mode 100644 index 973aed0..0000000 --- a/data/Test109.hs +++ /dev/null @@ -1 +0,0 @@ -func = (, abc) diff --git a/data/Test11.hs b/data/Test11.hs deleted file mode 100644 index 25670eb..0000000 --- a/data/Test11.hs +++ /dev/null @@ -1,3 +0,0 @@ -func - :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) - -> lakjsdlkjasldkj diff --git a/data/Test110.hs b/data/Test110.hs deleted file mode 100644 index 78d0c01..0000000 --- a/data/Test110.hs +++ /dev/null @@ -1,6 +0,0 @@ -myTupleSection = - ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement - , - , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement - , - ) diff --git a/data/Test111.hs b/data/Test111.hs deleted file mode 100644 index 87acbec..0000000 --- a/data/Test111.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = - ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - ) diff --git a/data/Test112.hs b/data/Test112.hs deleted file mode 100644 index daf62d6..0000000 --- a/data/Test112.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo = if True - then - -- iiiiii - "a " - else - "b " diff --git a/data/Test113.hs b/data/Test113.hs deleted file mode 100644 index 26bb39d..0000000 --- a/data/Test113.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = if cond - then pure 42 - else do - -- test - abc diff --git a/data/Test114.hs b/data/Test114.hs deleted file mode 100644 index ea9f935..0000000 --- a/data/Test114.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = case x of - False -> False - True -> True diff --git a/data/Test115.hs b/data/Test115.hs deleted file mode 100644 index eb88667..0000000 --- a/data/Test115.hs +++ /dev/null @@ -1,7 +0,0 @@ -func = - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of - False -> False - True -> True diff --git a/data/Test116.hs b/data/Test116.hs deleted file mode 100644 index 5d7739c..0000000 --- a/data/Test116.hs +++ /dev/null @@ -1,7 +0,0 @@ -func = do - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of - False -> False - True -> True diff --git a/data/Test117.hs b/data/Test117.hs deleted file mode 100644 index 43e6130..0000000 --- a/data/Test117.hs +++ /dev/null @@ -1 +0,0 @@ -func = case x of {} diff --git a/data/Test118.hs b/data/Test118.hs deleted file mode 100644 index 85c98c6..0000000 --- a/data/Test118.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of {} diff --git a/data/Test119.hs b/data/Test119.hs deleted file mode 100644 index 195201e..0000000 --- a/data/Test119.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = do - case - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - of {} diff --git a/data/Test12.hs b/data/Test12.hs deleted file mode 100644 index fa012f7..0000000 --- a/data/Test12.hs +++ /dev/null @@ -1,5 +0,0 @@ -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> lakjsdlkjasldkj diff --git a/data/Test120.hs b/data/Test120.hs deleted file mode 100644 index 5bbd0e6..0000000 --- a/data/Test120.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = do - stmt - stmt diff --git a/data/Test121.hs b/data/Test121.hs deleted file mode 100644 index aa47dfd..0000000 --- a/data/Test121.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = do - x <- stmt - stmt x diff --git a/data/Test122.hs b/data/Test122.hs deleted file mode 100644 index 589d354..0000000 --- a/data/Test122.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = do - let x = 13 - stmt x diff --git a/data/Test123.hs b/data/Test123.hs deleted file mode 100644 index 6319013..0000000 --- a/data/Test123.hs +++ /dev/null @@ -1,7 +0,0 @@ -func = - foooooo - $ [ case - foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - of - _ -> True - ] diff --git a/data/Test124.hs b/data/Test124.hs deleted file mode 100644 index 1164c0f..0000000 --- a/data/Test124.hs +++ /dev/null @@ -1,4 +0,0 @@ -testMethod foo bar baz qux = - let x = undefined foo bar baz qux qux baz bar :: String - -- some comment explaining the in expression - in undefined foo x :: String diff --git a/data/Test125.hs b/data/Test125.hs deleted file mode 100644 index e711480..0000000 --- a/data/Test125.hs +++ /dev/null @@ -1,4 +0,0 @@ -testMethod foo bar baz qux = - let x = undefined :: String - -- some comment explaining the in expression - in undefined :: String diff --git a/data/Test126.hs b/data/Test126.hs deleted file mode 100644 index e0c379a..0000000 --- a/data/Test126.hs +++ /dev/null @@ -1,3 +0,0 @@ -testMethod foo bar baz qux = - -- some comment explaining the in expression - let x = undefined :: String in undefined :: String diff --git a/data/Test127.hs b/data/Test127.hs deleted file mode 100644 index e446394..0000000 --- a/data/Test127.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo foo bar baz qux = - let a = 1 - b = 2 - c = 3 - -- some comment explaining the in expression - in undefined :: String diff --git a/data/Test128.hs b/data/Test128.hs deleted file mode 100644 index 8e3a783..0000000 --- a/data/Test128.hs +++ /dev/null @@ -1,6 +0,0 @@ -func = - foo - $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - ] - ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] diff --git a/data/Test129.hs b/data/Test129.hs deleted file mode 100644 index 6ca9a1f..0000000 --- a/data/Test129.hs +++ /dev/null @@ -1 +0,0 @@ -module Main where diff --git a/data/Test13.hs b/data/Test13.hs deleted file mode 100644 index 68e8e9e..0000000 --- a/data/Test13.hs +++ /dev/null @@ -1,5 +0,0 @@ -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) diff --git a/data/Test130.hs b/data/Test130.hs deleted file mode 100644 index 43a1fee..0000000 --- a/data/Test130.hs +++ /dev/null @@ -1 +0,0 @@ -module Main () where diff --git a/data/Test131.hs b/data/Test131.hs deleted file mode 100644 index 0fdcb21..0000000 --- a/data/Test131.hs +++ /dev/null @@ -1 +0,0 @@ -module Main (main) where diff --git a/data/Test132.hs b/data/Test132.hs deleted file mode 100644 index 1998fe9..0000000 --- a/data/Test132.hs +++ /dev/null @@ -1 +0,0 @@ -module Main (main, test1, test2) where diff --git a/data/Test133.hs b/data/Test133.hs deleted file mode 100644 index 20fd443..0000000 --- a/data/Test133.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) where diff --git a/data/Test134.hs b/data/Test134.hs deleted file mode 100644 index 20ea610..0000000 --- a/data/Test134.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main - ( main - -- main - , test1 - , test2 - -- Test 3 - , test3 - , test4 - -- Test 5 - , test5 - -- Test 6 - ) where diff --git a/data/Test135.hs b/data/Test135.hs deleted file mode 100644 index 6d7b8eb..0000000 --- a/data/Test135.hs +++ /dev/null @@ -1 +0,0 @@ -module Main (Test(..)) where diff --git a/data/Test136.hs b/data/Test136.hs deleted file mode 100644 index e06cbfc..0000000 --- a/data/Test136.hs +++ /dev/null @@ -1 +0,0 @@ -module Main (module Main) where diff --git a/data/Test137.hs b/data/Test137.hs deleted file mode 100644 index 5f1af50..0000000 --- a/data/Test137.hs +++ /dev/null @@ -1 +0,0 @@ -module Main (Test(Test, a, b)) where diff --git a/data/Test138.hs b/data/Test138.hs deleted file mode 100644 index b436099..0000000 --- a/data/Test138.hs +++ /dev/null @@ -1,6 +0,0 @@ --- comment1 -module Main - ( Test(Test, a, b) - , foo -- comment2 - ) -- comment3 - where diff --git a/data/Test139.hs b/data/Test139.hs deleted file mode 100644 index 6fd114e..0000000 --- a/data/Test139.hs +++ /dev/null @@ -1 +0,0 @@ -module Main (Test()) where diff --git a/data/Test14.hs b/data/Test14.hs deleted file mode 100644 index 05b4cb6..0000000 --- a/data/Test14.hs +++ /dev/null @@ -1 +0,0 @@ -func :: asd -> Either a b diff --git a/data/Test140.hs b/data/Test140.hs deleted file mode 100644 index 6d7a6ef..0000000 --- a/data/Test140.hs +++ /dev/null @@ -1 +0,0 @@ --- Intentionally left empty diff --git a/data/Test141.hs b/data/Test141.hs deleted file mode 100644 index a053bb5..0000000 --- a/data/Test141.hs +++ /dev/null @@ -1 +0,0 @@ -import Data.List diff --git a/data/Test142.hs b/data/Test142.hs deleted file mode 100644 index 1bc9f03..0000000 --- a/data/Test142.hs +++ /dev/null @@ -1 +0,0 @@ -import Data.List as L diff --git a/data/Test143.hs b/data/Test143.hs deleted file mode 100644 index 691c0c1..0000000 --- a/data/Test143.hs +++ /dev/null @@ -1 +0,0 @@ -import qualified Data.List diff --git a/data/Test144.hs b/data/Test144.hs deleted file mode 100644 index b64f22f..0000000 --- a/data/Test144.hs +++ /dev/null @@ -1 +0,0 @@ -import qualified Data.List as L diff --git a/data/Test145.hs b/data/Test145.hs deleted file mode 100644 index 020afa7..0000000 --- a/data/Test145.hs +++ /dev/null @@ -1 +0,0 @@ -import safe Data.List as L diff --git a/data/Test146.hs b/data/Test146.hs deleted file mode 100644 index cad516e..0000000 --- a/data/Test146.hs +++ /dev/null @@ -1 +0,0 @@ -import {-# SOURCE #-} Data.List ( ) diff --git a/data/Test147.hs b/data/Test147.hs deleted file mode 100644 index 42148e0..0000000 --- a/data/Test147.hs +++ /dev/null @@ -1 +0,0 @@ -import safe qualified Data.List diff --git a/data/Test148.hs b/data/Test148.hs deleted file mode 100644 index dd2c6b9..0000000 --- a/data/Test148.hs +++ /dev/null @@ -1 +0,0 @@ -import {-# SOURCE #-} safe qualified Data.List diff --git a/data/Test149.hs b/data/Test149.hs deleted file mode 100644 index 650a6ad..0000000 --- a/data/Test149.hs +++ /dev/null @@ -1 +0,0 @@ -import qualified "base" Data.List diff --git a/data/Test15.hs b/data/Test15.hs deleted file mode 100644 index 668dca4..0000000 --- a/data/Test15.hs +++ /dev/null @@ -1,5 +0,0 @@ -func - :: asd - -> Either - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test150.hs b/data/Test150.hs deleted file mode 100644 index 0c30830..0000000 --- a/data/Test150.hs +++ /dev/null @@ -1,3 +0,0 @@ -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List ( ) -import {-# SOURCE #-} safe qualified Data.List hiding ( ) diff --git a/data/Test151.hs b/data/Test151.hs deleted file mode 100644 index 992b081..0000000 --- a/data/Test151.hs +++ /dev/null @@ -1 +0,0 @@ -import qualified Data.List ( ) diff --git a/data/Test152.hs b/data/Test152.hs deleted file mode 100644 index 631bb4c..0000000 --- a/data/Test152.hs +++ /dev/null @@ -1 +0,0 @@ -import Data.List ( nub ) diff --git a/data/Test153.hs b/data/Test153.hs deleted file mode 100644 index 537fce6..0000000 --- a/data/Test153.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.List ( foldl' - , indexElem - , nub - ) diff --git a/data/Test154.hs b/data/Test154.hs deleted file mode 100644 index 387f268..0000000 --- a/data/Test154.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Test ( Long - , anymore - , fit - , items - , line - , list - , not - , onA - , quite - , single - , that - , will - , with - ) diff --git a/data/Test155.hs b/data/Test155.hs deleted file mode 100644 index 6150ff3..0000000 --- a/data/Test155.hs +++ /dev/null @@ -1,11 +0,0 @@ -import Test ( (+) - , (:!)(..) - , (:*)((:.), T7, t7) - , (:.) - , T - , T2() - , T3(..) - , T4(T4) - , T5(T5, t5) - , T6((<|>)) - ) diff --git a/data/Test156.hs b/data/Test156.hs deleted file mode 100644 index 9eb3db5..0000000 --- a/data/Test156.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Test hiding ( ) -import Test as T - hiding ( ) diff --git a/data/Test157.hs b/data/Test157.hs deleted file mode 100644 index f78c007..0000000 --- a/data/Test157.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Prelude as X - hiding ( head - , init - , last - , maximum - , minimum - , pred - , read - , readFile - , succ - , tail - , undefined - ) diff --git a/data/Test158.hs b/data/Test158.hs deleted file mode 100644 index 0fb60c8..0000000 --- a/data/Test158.hs +++ /dev/null @@ -1,3 +0,0 @@ -import TestJustAbitToLongModuleNameLikeThisOneIs - ( ) -import TestJustShortEnoughModuleNameLikeThisOne ( ) diff --git a/data/Test159.hs b/data/Test159.hs deleted file mode 100644 index 886dfdc..0000000 --- a/data/Test159.hs +++ /dev/null @@ -1,3 +0,0 @@ -import TestJustAbitToLongModuleNameLikeThisOneI - as T -import TestJustShortEnoughModuleNameLikeThisOn as T diff --git a/data/Test16.hs b/data/Test16.hs deleted file mode 100644 index a91f667..0000000 --- a/data/Test16.hs +++ /dev/null @@ -1,6 +0,0 @@ -func - :: asd - -> Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test160.hs b/data/Test160.hs deleted file mode 100644 index eff7fd4..0000000 --- a/data/Test160.hs +++ /dev/null @@ -1,3 +0,0 @@ -import TestJustAbitToLongModuleNameLikeTh - hiding ( ) -import TestJustShortEnoughModuleNameLike hiding ( ) diff --git a/data/Test161.hs b/data/Test161.hs deleted file mode 100644 index 14bd638..0000000 --- a/data/Test161.hs +++ /dev/null @@ -1,10 +0,0 @@ -import MoreThanSufficientlyLongModuleNameWithSome - ( compact - , fit - , inA - , items - , layout - , not - , that - , will - ) diff --git a/data/Test162.hs b/data/Test162.hs deleted file mode 100644 index f09b604..0000000 --- a/data/Test162.hs +++ /dev/null @@ -1,11 +0,0 @@ -import TestJustAbitToLongModuleNameLikeTh - hiding ( abc - , def - , ghci - , jklm - ) -import TestJustShortEnoughModuleNameLike hiding ( abc - , def - , ghci - , jklm - ) diff --git a/data/Test163.hs b/data/Test163.hs deleted file mode 100644 index c71aaba..0000000 --- a/data/Test163.hs +++ /dev/null @@ -1,9 +0,0 @@ -import {-# SOURCE #-} safe qualified "qualifier" A hiding ( ) -import {-# SOURCE #-} safe qualified "qualifiers" A - hiding ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff - as T -import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe - ( ) diff --git a/data/Test164.hs b/data/Test164.hs deleted file mode 100644 index 26469d9..0000000 --- a/data/Test164.hs +++ /dev/null @@ -1,7 +0,0 @@ --- Test -import Data.List ( nub ) -- Test -{- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} --- Test -import Test ( test ) diff --git a/data/Test165.hs b/data/Test165.hs deleted file mode 100644 index af0b6ab..0000000 --- a/data/Test165.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Test ( abc - , def - -- comment - ) diff --git a/data/Test166.hs b/data/Test166.hs deleted file mode 100644 index 3f0a3ea..0000000 --- a/data/Test166.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Test ( abc - -- comment - ) diff --git a/data/Test167.hs b/data/Test167.hs deleted file mode 100644 index fb8c357..0000000 --- a/data/Test167.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Test ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) diff --git a/data/Test168.hs b/data/Test168.hs deleted file mode 100644 index 40ca190..0000000 --- a/data/Test168.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Test ( -- comment - ) diff --git a/data/Test169.hs b/data/Test169.hs deleted file mode 100644 index 12a8008..0000000 --- a/data/Test169.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Test ( longbindingNameThatoverflowsColum - ) -import Test ( Long - ( List - , Of - , Things - ) - ) diff --git a/data/Test17.hs b/data/Test17.hs deleted file mode 100644 index a4bf487..0000000 --- a/data/Test17.hs +++ /dev/null @@ -1,6 +0,0 @@ -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd diff --git a/data/Test170.hs b/data/Test170.hs deleted file mode 100644 index 01d0881..0000000 --- a/data/Test170.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Test ( Thing - ( -- Comments - ) - ) -import Test ( Thing - ( Item - -- and Comment - ) - ) -import Test ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) diff --git a/data/Test171.hs b/data/Test171.hs deleted file mode 100644 index 2716a8d..0000000 --- a/data/Test171.hs +++ /dev/null @@ -1,2 +0,0 @@ -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine - ( ) diff --git a/data/Test172.hs b/data/Test172.hs deleted file mode 100644 index 190cdb1..0000000 --- a/data/Test172.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{- - - Test module - -} -module Test - ( test1 - -- ^ test - , test2 - -- | test - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - -- Test 10 - ) where --- Test -import Data.List ( nub ) -- Test -{- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} --- Test -import Test ( test ) diff --git a/data/Test173.hs b/data/Test173.hs deleted file mode 100644 index ca49c29..0000000 --- a/data/Test173.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Aaa -import Baa diff --git a/data/Test174.hs b/data/Test174.hs deleted file mode 100644 index cb7a8f3..0000000 --- a/data/Test174.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Zaa -import Zab - -import Aaa -import Baa diff --git a/data/Test175.hs b/data/Test175.hs deleted file mode 100644 index b25e13a..0000000 --- a/data/Test175.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Boo -import qualified Zoo diff --git a/data/Test176.hs b/data/Test176.hs deleted file mode 100644 index 3ed3401..0000000 --- a/data/Test176.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Boo ( a ) - -import Boo ( b ) diff --git a/data/Test177.hs b/data/Test177.hs deleted file mode 100644 index 67b690d..0000000 --- a/data/Test177.hs +++ /dev/null @@ -1,2 +0,0 @@ -import A.B.C -import A.B.D diff --git a/data/Test178.hs b/data/Test178.hs deleted file mode 100644 index f4d347f..0000000 --- a/data/Test178.hs +++ /dev/null @@ -1 +0,0 @@ -type MySynonym = String diff --git a/data/Test179.hs b/data/Test179.hs deleted file mode 100644 index dff281d..0000000 --- a/data/Test179.hs +++ /dev/null @@ -1 +0,0 @@ -type MySynonym a = [a] diff --git a/data/Test18.hs b/data/Test18.hs deleted file mode 100644 index aed66fd..0000000 --- a/data/Test18.hs +++ /dev/null @@ -1,5 +0,0 @@ -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) diff --git a/data/Test180.hs b/data/Test180.hs deleted file mode 100644 index 3f41a1a..0000000 --- a/data/Test180.hs +++ /dev/null @@ -1,3 +0,0 @@ --- | Important comment thrown in -type MySynonym b a - = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b diff --git a/data/Test181.hs b/data/Test181.hs deleted file mode 100644 index 727c443..0000000 --- a/data/Test181.hs +++ /dev/null @@ -1,7 +0,0 @@ -type MySynonym3 b a - = MySynonym a b - -> MySynonym a b - -- ^ RandomComment - -> MyParamType a b - -> MyParamType a b - -> MySynonym2 b a diff --git a/data/Test182.hs b/data/Test182.hs deleted file mode 100644 index 142a73a..0000000 --- a/data/Test182.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE StarIsType #-} -type MySynonym (a :: * -> *) - = MySynonym a b - -> MySynonym a b - -> MyParamType a b - -> MyParamType a b - -> MySynonym2 b a diff --git a/data/Test183.hs b/data/Test183.hs deleted file mode 100644 index a48b11c..0000000 --- a/data/Test183.hs +++ /dev/null @@ -1 +0,0 @@ -type MySynonym a = Num a => a -> Int diff --git a/data/Test184.hs b/data/Test184.hs deleted file mode 100644 index 7b868ea..0000000 --- a/data/Test184.hs +++ /dev/null @@ -1,5 +0,0 @@ -type MySynonym a - = Num a - => AReallyLongTypeName - -> AnotherReallyLongTypeName - -> AThirdTypeNameToOverflow diff --git a/data/Test185.hs b/data/Test185.hs deleted file mode 100644 index 69107a7..0000000 --- a/data/Test185.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -type MySynonym = forall a . [a] diff --git a/data/Test186.hs b/data/Test186.hs deleted file mode 100644 index ed9c0e4..0000000 --- a/data/Test186.hs +++ /dev/null @@ -1 +0,0 @@ -type (:+:) a b = (a, b) diff --git a/data/Test187.hs b/data/Test187.hs deleted file mode 100644 index 3b94215..0000000 --- a/data/Test187.hs +++ /dev/null @@ -1 +0,0 @@ -type a `MySynonym` b = a -> b diff --git a/data/Test188.hs b/data/Test188.hs deleted file mode 100644 index d7ba4a9..0000000 --- a/data/Test188.hs +++ /dev/null @@ -1 +0,0 @@ -type a :+: b = (a, b) diff --git a/data/Test189.hs b/data/Test189.hs deleted file mode 100644 index 7228f6d..0000000 --- a/data/Test189.hs +++ /dev/null @@ -1 +0,0 @@ -type (a `Foo` b) c = (a, b, c) diff --git a/data/Test19.hs b/data/Test19.hs deleted file mode 100644 index 92634de..0000000 --- a/data/Test19.hs +++ /dev/null @@ -1,7 +0,0 @@ -func - :: Trither - asd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) diff --git a/data/Test190.hs b/data/Test190.hs deleted file mode 100644 index b686bf0..0000000 --- a/data/Test190.hs +++ /dev/null @@ -1,3 +0,0 @@ -type Foo a -- fancy type comment - = -- strange comment - Int diff --git a/data/Test191.hs b/data/Test191.hs deleted file mode 100644 index b6ce836..0000000 --- a/data/Test191.hs +++ /dev/null @@ -1 +0,0 @@ -type (a :+: b) = (a, b) diff --git a/data/Test192.hs b/data/Test192.hs deleted file mode 100644 index f08498a..0000000 --- a/data/Test192.hs +++ /dev/null @@ -1,6 +0,0 @@ -type Foo - = ( -- t1 - A -- t2 - , -- t3 - B -- t4 - ) -- t5 diff --git a/data/Test193.hs b/data/Test193.hs deleted file mode 100644 index b422133..0000000 --- a/data/Test193.hs +++ /dev/null @@ -1,2 +0,0 @@ -instance MyClass Int where - myMethod x = x + 1 diff --git a/data/Test194.hs b/data/Test194.hs deleted file mode 100644 index 69107c6..0000000 --- a/data/Test194.hs +++ /dev/null @@ -1,4 +0,0 @@ -instance MyClass Int where - myMethod x = - -- insightful comment - x + 1 diff --git a/data/Test195.hs b/data/Test195.hs deleted file mode 100644 index 3de314a..0000000 --- a/data/Test195.hs +++ /dev/null @@ -1,3 +0,0 @@ -instance MyClass Int where - myMethod :: Int -> Int - myMethod x = x + 1 diff --git a/data/Test196.hs b/data/Test196.hs deleted file mode 100644 index 63f0d95..0000000 --- a/data/Test196.hs +++ /dev/null @@ -1,9 +0,0 @@ -instance MyClass Int where - myMethod - :: Int - -> Int - -> AReallyLongType - -> AReallyLongType - -> AReallyLongType - -> Int - myMethod x = x + 1 diff --git a/data/Test197.hs b/data/Test197.hs deleted file mode 100644 index d7c7d3c..0000000 --- a/data/Test197.hs +++ /dev/null @@ -1,3 +0,0 @@ -instance MyClass Int where - myMethod x = x + 1 - myMethod2 x = x + 1 diff --git a/data/Test198.hs b/data/Test198.hs deleted file mode 100644 index 811e7c4..0000000 --- a/data/Test198.hs +++ /dev/null @@ -1,11 +0,0 @@ -instance MyClass Int where - myMethod - :: Int - -> Int - -> AReallyLongType - -> AReallyLongType - -> AReallyLongType - -> Int - myMethod x = x + 1 - myMethod2 :: Int -> Int - myMethod2 x = x + 1 diff --git a/data/Test199.hs b/data/Test199.hs deleted file mode 100644 index 9b9cf38..0000000 --- a/data/Test199.hs +++ /dev/null @@ -1,4 +0,0 @@ --- | This instance should be commented on -instance MyClass Int where - -- | This method is also comment-worthy - myMethod x = x + 1 diff --git a/data/Test2.hs b/data/Test2.hs deleted file mode 100644 index b0d734a..0000000 --- a/data/Test2.hs +++ /dev/null @@ -1,3 +0,0 @@ -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test20.hs b/data/Test20.hs deleted file mode 100644 index 4ad54b6..0000000 --- a/data/Test20.hs +++ /dev/null @@ -1,7 +0,0 @@ -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) diff --git a/data/Test200.hs b/data/Test200.hs deleted file mode 100644 index c184597..0000000 --- a/data/Test200.hs +++ /dev/null @@ -1,4 +0,0 @@ -instance MyClass Int where - type MyType = Int - myMethod :: MyType -> Int - myMethod x = x + 1 diff --git a/data/Test201.hs b/data/Test201.hs deleted file mode 100644 index 1dcbe3a..0000000 --- a/data/Test201.hs +++ /dev/null @@ -1,5 +0,0 @@ -instance MyClass Int where - type MyType = String - myMethod :: MyType -> Int - myMethod x = x + 1 - type MyType = Int diff --git a/data/Test202.hs b/data/Test202.hs deleted file mode 100644 index b2789c2..0000000 --- a/data/Test202.hs +++ /dev/null @@ -1,8 +0,0 @@ -instance MyClass Int where - -- | This data is very important - data MyData = IntData - { intData :: String - , intData2 :: Int - } - myMethod :: MyData -> Int - myMethod = intData2 diff --git a/data/Test203.hs b/data/Test203.hs deleted file mode 100644 index 04353a6..0000000 --- a/data/Test203.hs +++ /dev/null @@ -1,11 +0,0 @@ -instance MyClass Int where - -- | This data is important - data MyData = Test Int Int - myMethod :: MyData -> Int - myMethod = intData2 - -- | This data is also important - data MyData2 = IntData - { intData :: String - -- ^ Interesting field - , intData2 :: Int - } diff --git a/data/Test204.hs b/data/Test204.hs deleted file mode 100644 index 7ad4fc6..0000000 --- a/data/Test204.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Lib where -instance Foo () where - newtype Bar () = Baz () - deriving (Eq, Ord, Show) - bar = Baz diff --git a/data/Test205.hs b/data/Test205.hs deleted file mode 100644 index a224c18..0000000 --- a/data/Test205.hs +++ /dev/null @@ -1,4 +0,0 @@ -instance Foo Int where - newtype Bar Int = BarInt - { unBarInt :: Int - } diff --git a/data/Test206.hs b/data/Test206.hs deleted file mode 100644 index 7266b3e..0000000 --- a/data/Test206.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# language TypeFamilies #-} -type family F a -type instance F Int = IO Int diff --git a/data/Test207.hs b/data/Test207.hs deleted file mode 100644 index 9bb7ba2..0000000 --- a/data/Test207.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# language TypeFamilies #-} -type family F a -type instance F Int = IO Int -- x diff --git a/data/Test208.hs b/data/Test208.hs deleted file mode 100644 index 0e3c3f8..0000000 --- a/data/Test208.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# language TypeFamilies #-} -module M where -type family F a -type instance F Int = IO Int diff --git a/data/Test209.hs b/data/Test209.hs deleted file mode 100644 index f103480..0000000 --- a/data/Test209.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# language TypeFamilies #-} -data family F a -newtype instance F Int = N Int diff --git a/data/Test21.hs b/data/Test21.hs deleted file mode 100644 index d27183e..0000000 --- a/data/Test21.hs +++ /dev/null @@ -1,7 +0,0 @@ -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test210.hs b/data/Test210.hs deleted file mode 100644 index 659bd8a..0000000 --- a/data/Test210.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# language TypeFamilies #-} -data family F a -newtype instance F Int = N Int -- x diff --git a/data/Test211.hs b/data/Test211.hs deleted file mode 100644 index 9e71377..0000000 --- a/data/Test211.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# language TypeFamilies #-} -module M where -data family F a -newtype instance F Int = N Int diff --git a/data/Test212.hs b/data/Test212.hs deleted file mode 100644 index 715990f..0000000 --- a/data/Test212.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# language TypeFamilies #-} -data family F a -data instance F Int = D Int diff --git a/data/Test213.hs b/data/Test213.hs deleted file mode 100644 index 0194c4c..0000000 --- a/data/Test213.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# language TypeFamilies #-} -data family F a -data instance F Int = D Int -- x diff --git a/data/Test214.hs b/data/Test214.hs deleted file mode 100644 index 81d27db..0000000 --- a/data/Test214.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# language TypeFamilies #-} -module M where -data family F a -data instance F Int = D Int diff --git a/data/Test215.hs b/data/Test215.hs deleted file mode 100644 index feaf541..0000000 --- a/data/Test215.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# language TypeFamilies #-} -class C a where - type family F a -instance C Int where - type F Int = IO Int diff --git a/data/Test216.hs b/data/Test216.hs deleted file mode 100644 index 13dcee5..0000000 --- a/data/Test216.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# language TypeFamilies #-} -class C a where - type family F a -instance C Int where - type F Int = IO Int -- x diff --git a/data/Test217.hs b/data/Test217.hs deleted file mode 100644 index c14956e..0000000 --- a/data/Test217.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# language TypeFamilies #-} -module M where -class C a where - type family F a -instance C Int where - type F Int = IO Int diff --git a/data/Test218.hs b/data/Test218.hs deleted file mode 100644 index 824b034..0000000 --- a/data/Test218.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - newtype F Int = N Int diff --git a/data/Test219.hs b/data/Test219.hs deleted file mode 100644 index 1df22e4..0000000 --- a/data/Test219.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - newtype F Int = N Int -- x diff --git a/data/Test22.hs b/data/Test22.hs deleted file mode 100644 index 35b8134..0000000 --- a/data/Test22.hs +++ /dev/null @@ -1,7 +0,0 @@ -func - :: ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd diff --git a/data/Test220.hs b/data/Test220.hs deleted file mode 100644 index 6f6dc67..0000000 --- a/data/Test220.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# language TypeFamilies #-} -module M where -class C a where - data family F a -instance C Int where - newtype F Int = N Int diff --git a/data/Test221.hs b/data/Test221.hs deleted file mode 100644 index 1ec34f4..0000000 --- a/data/Test221.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - data F Int = D Int diff --git a/data/Test222.hs b/data/Test222.hs deleted file mode 100644 index 84a1f5f..0000000 --- a/data/Test222.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# language TypeFamilies #-} -class C a where - data family F a -instance C Int where - data F Int = D Int -- x diff --git a/data/Test223.hs b/data/Test223.hs deleted file mode 100644 index 677369b..0000000 --- a/data/Test223.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# language TypeFamilies #-} -module M where -class C a where - data family F a -instance C Int where - data F Int = D Int diff --git a/data/Test224.hs b/data/Test224.hs deleted file mode 100644 index 8798205..0000000 --- a/data/Test224.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Main where -import Prelude -firstDecl = True diff --git a/data/Test225.hs b/data/Test225.hs deleted file mode 100644 index e5861f4..0000000 --- a/data/Test225.hs +++ /dev/null @@ -1,10 +0,0 @@ -func = do - -- complex first step - aaa - -- complex second step - bbb - where - helper :: Helper - helper = helpful - other :: Other - other = True diff --git a/data/Test226.hs b/data/Test226.hs deleted file mode 100644 index d999644..0000000 --- a/data/Test226.hs +++ /dev/null @@ -1 +0,0 @@ -type instance MyFam Bool = String diff --git a/data/Test227.hs b/data/Test227.hs deleted file mode 100644 index a67980b..0000000 --- a/data/Test227.hs +++ /dev/null @@ -1 +0,0 @@ -type instance MyFam (Maybe a) = a -> Bool diff --git a/data/Test228.hs b/data/Test228.hs deleted file mode 100644 index 21a82dc..0000000 --- a/data/Test228.hs +++ /dev/null @@ -1,4 +0,0 @@ -type instance MyFam ALongishType - = AMuchLongerTypeThanThat - -> AnEvenLongerTypeThanTheLastOne - -> ShouldDefinitelyOverflow diff --git a/data/Test229.hs b/data/Test229.hs deleted file mode 100644 index 9299647..0000000 --- a/data/Test229.hs +++ /dev/null @@ -1,3 +0,0 @@ --- | A happy family -type instance MyFam Bool -- This is an odd one - = AnotherType -- Here's another diff --git a/data/Test23.hs b/data/Test23.hs deleted file mode 100644 index 45b6ecc..0000000 --- a/data/Test23.hs +++ /dev/null @@ -1 +0,0 @@ -func :: [a -> b] diff --git a/data/Test230.hs b/data/Test230.hs deleted file mode 100644 index c7daa9c..0000000 --- a/data/Test230.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -func = if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test231.hs b/data/Test231.hs deleted file mode 100644 index 4580c39..0000000 --- a/data/Test231.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -func = do - foo - bar $ if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test232.hs b/data/Test232.hs deleted file mode 100644 index a1e09b1..0000000 --- a/data/Test232.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -func = \case - FooBar -> x - Baz -> y diff --git a/data/Test233.hs b/data/Test233.hs deleted file mode 100644 index c4b3a93..0000000 --- a/data/Test233.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -func :: (?asd::Int) -> () diff --git a/data/Test234.hs b/data/Test234.hs deleted file mode 100644 index 55305cf..0000000 --- a/data/Test234.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -func - :: ( ?asd - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> () diff --git a/data/Test235.hs b/data/Test235.hs deleted file mode 100644 index 41406a4..0000000 --- a/data/Test235.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -foo = do - rec a <- f b - b <- g a - return (a, b) diff --git a/data/Test236.hs b/data/Test236.hs deleted file mode 100644 index ebf2076..0000000 --- a/data/Test236.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -foo = do - rec -- comment - a <- f b - b <- g a - return (a, b) diff --git a/data/Test237.hs b/data/Test237.hs deleted file mode 100644 index 78ecef2..0000000 --- a/data/Test237.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} -module Test (type (++), (++), pattern Foo) where diff --git a/data/Test238.hs b/data/Test238.hs deleted file mode 100644 index 61444fa..0000000 --- a/data/Test238.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE PatternSynonyms #-} -import Test ( type (++) - , (++) - , pattern (:.) - , pattern Foo - ) diff --git a/data/Test239.hs b/data/Test239.hs deleted file mode 100644 index f535c48..0000000 --- a/data/Test239.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern J x = Just x diff --git a/data/Test24.hs b/data/Test24.hs deleted file mode 100644 index 272c2b4..0000000 --- a/data/Test24.hs +++ /dev/null @@ -1,4 +0,0 @@ -func - :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ] diff --git a/data/Test240.hs b/data/Test240.hs deleted file mode 100644 index 82251e5..0000000 --- a/data/Test240.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern F x <- (x, _) diff --git a/data/Test241.hs b/data/Test241.hs deleted file mode 100644 index e00b3ca..0000000 --- a/data/Test241.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern HeadC x <- x : xs where - HeadC x = [x] diff --git a/data/Test242.hs b/data/Test242.hs deleted file mode 100644 index f6587d6..0000000 --- a/data/Test242.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern Head2 x y <- x : y : xs where - Head2 x y = [x, y] diff --git a/data/Test243.hs b/data/Test243.hs deleted file mode 100644 index 4ffaf11..0000000 --- a/data/Test243.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern x :> y = [x, y] diff --git a/data/Test244.hs b/data/Test244.hs deleted file mode 100644 index d61801f..0000000 --- a/data/Test244.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern MyData { a, b, c } = [a, b, c] diff --git a/data/Test245.hs b/data/Test245.hs deleted file mode 100644 index 78869f8..0000000 --- a/data/Test245.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = - [myLongLeftVariableName, myLongRightVariableName] diff --git a/data/Test246.hs b/data/Test246.hs deleted file mode 100644 index 811bb22..0000000 --- a/data/Test246.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- - [myLongLeftVariableName, myLongRightVariableName] where - MyInfixPatternMatcher x y = [x, x, y] diff --git a/data/Test247.hs b/data/Test247.hs deleted file mode 100644 index cd38165..0000000 --- a/data/Test247.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern J :: a -> Maybe a -pattern J x = Just x diff --git a/data/Test248.hs b/data/Test248.hs deleted file mode 100644 index 823e1f4..0000000 --- a/data/Test248.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed x <- (asSigned -> x) where - Signed (Neg x) = -x - Signed Zero = 0 - Signed (Pos x) = x diff --git a/data/Test249.hs b/data/Test249.hs deleted file mode 100644 index 9b69561..0000000 --- a/data/Test249.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- - (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where - Signed (Neg x) = -x - Signed Zero = 0 - Signed (Pos x) = x diff --git a/data/Test25.hs b/data/Test25.hs deleted file mode 100644 index 142958b..0000000 --- a/data/Test25.hs +++ /dev/null @@ -1,5 +0,0 @@ -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] diff --git a/data/Test250.hs b/data/Test250.hs deleted file mode 100644 index 8493743..0000000 --- a/data/Test250.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -pattern Signed x <- (asSigned -> x) where - Signed (Neg x) = -x -- negative comment - Signed Zero = 0 -- zero comment - Signed (Pos x) = x -- positive comment diff --git a/data/Test251.hs b/data/Test251.hs deleted file mode 100644 index 3ea9b99..0000000 --- a/data/Test251.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern J, K :: a -> Maybe a diff --git a/data/Test252.hs b/data/Test252.hs deleted file mode 100644 index 54eb4c5..0000000 --- a/data/Test252.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -pattern LongMatcher - :: longlongtypevar - -> longlongtypevar - -> longlongtypevar - -> Maybe [longlongtypevar] -pattern LongMatcher x y z = Just [x, y, z] diff --git a/data/Test253.hs b/data/Test253.hs deleted file mode 100644 index 25fc4ce..0000000 --- a/data/Test253.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} -spanKey :: (# Int, Int #) -> (# Int, Int #) -spanKey = case foo of - (# bar, baz #) -> (# baz, bar #) diff --git a/data/Test254.hs b/data/Test254.hs deleted file mode 100644 index 3ceb254..0000000 --- a/data/Test254.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -spanKey :: (# Int#, Int# #) -> (# Int#, Int# #) -spanKey = case foo of - (# bar#, baz# #) -> (# baz# +# bar#, bar# #) diff --git a/data/Test255.hs b/data/Test255.hs deleted file mode 100644 index a644156..0000000 --- a/data/Test255.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -func = [blub| - asd - qwe - |] diff --git a/data/Test256.hs b/data/Test256.hs deleted file mode 100644 index 1624200..0000000 --- a/data/Test256.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -func = [blub| - asd - qwe|] diff --git a/data/Test257.hs b/data/Test257.hs deleted file mode 100644 index 20f877f..0000000 --- a/data/Test257.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -func = do - let body = [json| - hello - |] - pure True diff --git a/data/Test258.hs b/data/Test258.hs deleted file mode 100644 index 29039ca..0000000 --- a/data/Test258.hs +++ /dev/null @@ -1,9 +0,0 @@ --- brittany { lconfig_allowHangingQuasiQuotes: False } -{-# LANGUAGE QuasiQuotes #-} -func = do - let - body = - [json| - hello - |] - pure True diff --git a/data/Test259.hs b/data/Test259.hs deleted file mode 100644 index 2407ef8..0000000 --- a/data/Test259.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -foo = #bar diff --git a/data/Test26.hs b/data/Test26.hs deleted file mode 100644 index cdc1e7e..0000000 --- a/data/Test26.hs +++ /dev/null @@ -1 +0,0 @@ -func :: (a, b, c) diff --git a/data/Test260.hs b/data/Test260.hs deleted file mode 100644 index d7cc187..0000000 --- a/data/Test260.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -foo = #bar . #baz $ fmap #foo xs diff --git a/data/Test261.hs b/data/Test261.hs deleted file mode 100644 index f56379d..0000000 --- a/data/Test261.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -foo = ?bar diff --git a/data/Test262.hs b/data/Test262.hs deleted file mode 100644 index 0ed092e..0000000 --- a/data/Test262.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -foo = let ?bar = Foo in value diff --git a/data/Test263.hs b/data/Test263.hs deleted file mode 100644 index a85a777..0000000 --- a/data/Test263.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -foo :: (?bar::Bool) => () -foo = () diff --git a/data/Test264.hs b/data/Test264.hs deleted file mode 100644 index d3ebee3..0000000 --- a/data/Test264.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = do - abc <- foo ---abc -return () diff --git a/data/Test265.hs b/data/Test265.hs deleted file mode 100644 index c965c63..0000000 --- a/data/Test265.hs +++ /dev/null @@ -1 +0,0 @@ -func = (()) diff --git a/data/Test266.hs b/data/Test266.hs deleted file mode 100644 index b6a3539..0000000 --- a/data/Test266.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = do - let foo True = True - foo _ = False - return () diff --git a/data/Test267.hs b/data/Test267.hs deleted file mode 100644 index 65d2172..0000000 --- a/data/Test267.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } diff --git a/data/Test268.hs b/data/Test268.hs deleted file mode 100644 index 6d369d8..0000000 --- a/data/Test268.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state - , _lstate_foo = _lstate_foo state - } diff --git a/data/Test269.hs b/data/Test269.hs deleted file mode 100644 index 4741485..0000000 --- a/data/Test269.hs +++ /dev/null @@ -1,6 +0,0 @@ -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } diff --git a/data/Test27.hs b/data/Test27.hs deleted file mode 100644 index 774cc9d..0000000 --- a/data/Test27.hs +++ /dev/null @@ -1 +0,0 @@ -func :: ((a, b, c), (a, b, c), (a, b, c)) diff --git a/data/Test270.hs b/data/Test270.hs deleted file mode 100644 index cd17597..0000000 --- a/data/Test270.hs +++ /dev/null @@ -1 +0,0 @@ -func = Foo { _lstate_indent = _lstate_indent state } diff --git a/data/Test271.hs b/data/Test271.hs deleted file mode 100644 index 112af5e..0000000 --- a/data/Test271.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_fooo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } diff --git a/data/Test272.hs b/data/Test272.hs deleted file mode 100644 index 3d0a415..0000000 --- a/data/Test272.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = do - Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } diff --git a/data/Test273.hs b/data/Test273.hs deleted file mode 100644 index 172b344..0000000 --- a/data/Test273.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = do --- abc - -- def - return () diff --git a/data/Test274.hs b/data/Test274.hs deleted file mode 100644 index 13d9924..0000000 --- a/data/Test274.hs +++ /dev/null @@ -1,6 +0,0 @@ -func = do - do - return () - -- abc - -- def - return () diff --git a/data/Test275.hs b/data/Test275.hs deleted file mode 100644 index 45fbb05..0000000 --- a/data/Test275.hs +++ /dev/null @@ -1,6 +0,0 @@ -func - :: Int -- basic indentation amount - -> Int -- currently used width in current line (after indent) - -- used to accurately calc placing of the current-line - -> LayoutDesc - -> Int diff --git a/data/Test276.hs b/data/Test276.hs deleted file mode 100644 index 1a55b76..0000000 --- a/data/Test276.hs +++ /dev/null @@ -1,7 +0,0 @@ -func = - ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj - $ abc - $ def - $ ghi - $ jkl - ) diff --git a/data/Test277.hs b/data/Test277.hs deleted file mode 100644 index 954c81d..0000000 --- a/data/Test277.hs +++ /dev/null @@ -1,2 +0,0 @@ -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where reassoc (v, e, w) = (v, (e, w)) diff --git a/data/Test278.hs b/data/Test278.hs deleted file mode 100644 index 012222d..0000000 --- a/data/Test278.hs +++ /dev/null @@ -1,4 +0,0 @@ -downloadRepoPackage = case repo of - RepoLocal {..} -> return () - RepoLocal { abc } -> return () - RepoLocal{} -> return () diff --git a/data/Test279.hs b/data/Test279.hs deleted file mode 100644 index 2a53d37..0000000 --- a/data/Test279.hs +++ /dev/null @@ -1,6 +0,0 @@ -func = do - let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' - -- default local dir target if there's no given target - utargets'' = "foo" - return () diff --git a/data/Test28.hs b/data/Test28.hs deleted file mode 100644 index 06bd705..0000000 --- a/data/Test28.hs +++ /dev/null @@ -1,5 +0,0 @@ -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) diff --git a/data/Test280.hs b/data/Test280.hs deleted file mode 100644 index 0ea93d9..0000000 --- a/data/Test280.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = - [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_ : _)) <- nosuchFooThing - , gast <- award - ] diff --git a/data/Test281.hs b/data/Test281.hs deleted file mode 100644 index 6366436..0000000 --- a/data/Test281.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = if x - then if y -- y is important - then foo - else bar - else Nothing diff --git a/data/Test282.hs b/data/Test282.hs deleted file mode 100644 index c6cba2d..0000000 --- a/data/Test282.hs +++ /dev/null @@ -1,7 +0,0 @@ -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR diff --git a/data/Test283.hs b/data/Test283.hs deleted file mode 100644 index 21044e6..0000000 --- a/data/Test283.hs +++ /dev/null @@ -1,6 +0,0 @@ -layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () diff --git a/data/Test284.hs b/data/Test284.hs deleted file mode 100644 index f6a21c7..0000000 --- a/data/Test284.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -readMergePersConfig path shouldCreate conf = do - exists <- liftIO $ System.Directory.doesFileExist path - if - | exists -> do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn e - mzero - Right x -> return x - return $ fileConf Semigroup.<> conf - | shouldCreate -> do - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) - staticDefaultConfig - return $ conf - | otherwise -> do - return conf diff --git a/data/Test285.hs b/data/Test285.hs deleted file mode 100644 index 388281d..0000000 --- a/data/Test285.hs +++ /dev/null @@ -1,12 +0,0 @@ -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _ ) -> InstallOk diff --git a/data/Test286.hs b/data/Test286.hs deleted file mode 100644 index 388281d..0000000 --- a/data/Test286.hs +++ /dev/null @@ -1,12 +0,0 @@ -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _ ) -> InstallOk diff --git a/data/Test287.hs b/data/Test287.hs deleted file mode 100644 index a50af8b..0000000 --- a/data/Test287.hs +++ /dev/null @@ -1,35 +0,0 @@ -showPackageDetailedInfo pkginfo = - renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) - $ char '*' - $+$ something - [ entry "Synopsis" synopsis hideIfNull reflowParagraphs - , entry "Versions available" - sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry - "Versions installed" - installedVersions - (altText - null - (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") - ) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description hideIfNull reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) - then empty - else text "Modules:" - $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ] diff --git a/data/Test288.hs b/data/Test288.hs deleted file mode 100644 index 3289dd7..0000000 --- a/data/Test288.hs +++ /dev/null @@ -1,2 +0,0 @@ -isValidPosition position | validX && validY = Just position - | otherwise = Nothing diff --git a/data/Test289.hs b/data/Test289.hs deleted file mode 100644 index 023032c..0000000 --- a/data/Test289.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do - (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String - -> IO Bool ) <- - ReflexHost.newExternalEvent - liftIO . forkIO . forever $ getLine >>= inputFire - ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent diff --git a/data/Test29.hs b/data/Test29.hs deleted file mode 100644 index fc19ba1..0000000 --- a/data/Test29.hs +++ /dev/null @@ -1,6 +0,0 @@ -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) diff --git a/data/Test290.hs b/data/Test290.hs deleted file mode 100644 index 689fa70..0000000 --- a/data/Test290.hs +++ /dev/null @@ -1,2 +0,0 @@ -foldrDesc f z = unSwitchQueue $ \q -> - switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/data/Test291.hs b/data/Test291.hs deleted file mode 100644 index 68face0..0000000 --- a/data/Test291.hs +++ /dev/null @@ -1,5 +0,0 @@ -autocheckCases = - [ ("Never Deadlocks" , representative deadlocksNever) - , ("No Exceptions" , representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative - ] diff --git a/data/Test292.hs b/data/Test292.hs deleted file mode 100644 index cc6ecb2..0000000 --- a/data/Test292.hs +++ /dev/null @@ -1,7 +0,0 @@ -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions" , representative exceptionsNever) - , ( "Consistent Result" - , alwaysSame -- already representative - ) - ] diff --git a/data/Test293.hs b/data/Test293.hs deleted file mode 100644 index 596f9ea..0000000 --- a/data/Test293.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = - [ (abc, (1111, 1111)) - , (def, (2, 2)) - , foo -- comment - ] diff --git a/data/Test294.hs b/data/Test294.hs deleted file mode 100644 index 927da51..0000000 --- a/data/Test294.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - where g a b = b + b * a diff --git a/data/Test295.hs b/data/Test295.hs deleted file mode 100644 index 2b6fc80..0000000 --- a/data/Test295.hs +++ /dev/null @@ -1 +0,0 @@ -foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo diff --git a/data/Test296.hs b/data/Test296.hs deleted file mode 100644 index 1954213..0000000 --- a/data/Test296.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = do - abc <- expr - abcccccccccccccccccc <- expr - abcccccccccccccccccccccccccccccccccccccccccc <- expr - abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr diff --git a/data/Test297.hs b/data/Test297.hs deleted file mode 100644 index 198bd69..0000000 --- a/data/Test297.hs +++ /dev/null @@ -1,3 +0,0 @@ -func (MyLongFoo abc def) = 1 -func (Bar a d ) = 2 -func _ = 3 diff --git a/data/Test298.hs b/data/Test298.hs deleted file mode 100644 index 17013e2..0000000 --- a/data/Test298.hs +++ /dev/null @@ -1,14 +0,0 @@ -parserCompactLocation = - [ try - $ [ ParseRelAbs (Text.Read.read digits) _ _ - | digits <- many1 digit - , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe - [ case divPart of - Nothing -> Left $ Text.Read.read digits - Just ddigits -> - Right $ Text.Read.read digits % Text.Read.read ddigits - | digits <- many1 digit - , divPart <- optionMaybe (string "/" *> many1 digit) - ] - ] - ] diff --git a/data/Test299.hs b/data/Test299.hs deleted file mode 100644 index 26927f9..0000000 --- a/data/Test299.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo diff --git a/data/Test3.hs b/data/Test3.hs deleted file mode 100644 index 98d8196..0000000 --- a/data/Test3.hs +++ /dev/null @@ -1,4 +0,0 @@ -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj diff --git a/data/Test30.hs b/data/Test30.hs deleted file mode 100644 index 2ed144e..0000000 --- a/data/Test30.hs +++ /dev/null @@ -1,6 +0,0 @@ -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] diff --git a/data/Test300.hs b/data/Test300.hs deleted file mode 100644 index 0338df4..0000000 --- a/data/Test300.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = - fooooooooooooooooooooooooooooooooo - + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo diff --git a/data/Test301.hs b/data/Test301.hs deleted file mode 100644 index bd8d21c..0000000 --- a/data/Test301.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo - [ foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - ] diff --git a/data/Test302.hs b/data/Test302.hs deleted file mode 100644 index 946346c..0000000 --- a/data/Test302.hs +++ /dev/null @@ -1,18 +0,0 @@ -parserPrim = - [ r - | r <- - [ SGPPrimFloat $ bool id (0 -) minus $ readGnok "parserPrim" - (d1 ++ d2 ++ d3 ++ d4) - | d2 <- string "." - , d3 <- many1 (oneOf "0123456789") - , _ <- string "f" - ] - <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "f" - ] - <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "i" - ] - ] diff --git a/data/Test303.hs b/data/Test303.hs deleted file mode 100644 index d3f4d9e..0000000 --- a/data/Test303.hs +++ /dev/null @@ -1,2 +0,0 @@ -samples = (SV.unpackaaaaadat) <&> \f -> - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test304.hs b/data/Test304.hs deleted file mode 100644 index c62bfc0..0000000 --- a/data/Test304.hs +++ /dev/null @@ -1,9 +0,0 @@ -runBrittany tabSize text = do - let config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text diff --git a/data/Test305.hs b/data/Test305.hs deleted file mode 100644 index a288c39..0000000 --- a/data/Test305.hs +++ /dev/null @@ -1,11 +0,0 @@ --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -runBrittany tabSize text = do - let - config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text diff --git a/data/Test306.hs b/data/Test306.hs deleted file mode 100644 index 822d18a..0000000 --- a/data/Test306.hs +++ /dev/null @@ -1,7 +0,0 @@ -foo = - ( a - , -- comment1 - b - -- comment2 - , c - ) diff --git a/data/Test307.hs b/data/Test307.hs deleted file mode 100644 index 0d54fb5..0000000 --- a/data/Test307.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -foo = bar @Baz diff --git a/data/Test308.hs b/data/Test308.hs deleted file mode 100644 index ca3fd97..0000000 --- a/data/Test308.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do - docAlt - $ -- one-line solution - [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - | not hasComments - , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> [] - ] - ++ -- one-line solution + where in next line(s) - [ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] - ] - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] diff --git a/data/Test309.hs b/data/Test309.hs deleted file mode 100644 index d02a8c6..0000000 --- a/data/Test309.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -func = do - let foo = if - | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO - -> max - (defLen - 0.2) -- TODO - (defLen * 0.8) - | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO - return True diff --git a/data/Test31.hs b/data/Test31.hs deleted file mode 100644 index 7e217d5..0000000 --- a/data/Test31.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b diff --git a/data/Test310.hs b/data/Test310.hs deleted file mode 100644 index a6f54fa..0000000 --- a/data/Test310.hs +++ /dev/null @@ -1,5 +0,0 @@ -foo n = case n of - 1 -> True - -1 -> False -bar n = case n of - (-2, -2) -> (-2, -2) diff --git a/data/Test311.hs b/data/Test311.hs deleted file mode 100644 index 99e92c5..0000000 --- a/data/Test311.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -foo = - let a = b @1 - cccc = () - in foo diff --git a/data/Test312.hs b/data/Test312.hs deleted file mode 100644 index 615e416..0000000 --- a/data/Test312.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -v = A { a = 1, .. } where b = 2 diff --git a/data/Test313.hs b/data/Test313.hs deleted file mode 100644 index 1f5f34f..0000000 --- a/data/Test313.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -v = A { .. } where b = 2 diff --git a/data/Test314.hs b/data/Test314.hs deleted file mode 100644 index e0cc55d..0000000 --- a/data/Test314.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -v = A { a = 1, b = 2, c = 3 } diff --git a/data/Test315.hs b/data/Test315.hs deleted file mode 100644 index 8bd72ce..0000000 --- a/data/Test315.hs +++ /dev/null @@ -1 +0,0 @@ -test :: Proxy 'Int diff --git a/data/Test316.hs b/data/Test316.hs deleted file mode 100644 index e5a8eef..0000000 --- a/data/Test316.hs +++ /dev/null @@ -1 +0,0 @@ -test :: Proxy '[ 'True] diff --git a/data/Test317.hs b/data/Test317.hs deleted file mode 100644 index 79d5442..0000000 --- a/data/Test317.hs +++ /dev/null @@ -1 +0,0 @@ -test :: Proxy '[Bool] diff --git a/data/Test318.hs b/data/Test318.hs deleted file mode 100644 index f2c5673..0000000 --- a/data/Test318.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RankNTypes, KindSignatures #-} -func - :: forall m str - . (Str str, Monad m) - => Int - -> Proxy (str :: [*]) - -> m (Tagged str String) diff --git a/data/Test319.hs b/data/Test319.hs deleted file mode 100644 index 1c6ce85..0000000 --- a/data/Test319.hs +++ /dev/null @@ -1,13 +0,0 @@ -widgetsDyn = - [ [ vBox - [ padTop Max outputLinesWidget - , padRight Max wid1 <+> flowWidget -- alignment here is strange/buggy - , padBottom (Pad 5) help - ] - ] - | wid1 <- promptDyn - , (flowWidget, _) <- flowResultD - , outputLinesWidget <- outputLinesWidgetD - , help <- suggestionHelpBox - , parser <- cmdParserD - ] diff --git a/data/Test32.hs b/data/Test32.hs deleted file mode 100644 index 19e72f4..0000000 --- a/data/Test32.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . Foo - => ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () diff --git a/data/Test320.hs b/data/Test320.hs deleted file mode 100644 index c7e9eae..0000000 --- a/data/Test320.hs +++ /dev/null @@ -1,2 +0,0 @@ -fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b -fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) diff --git a/data/Test321.hs b/data/Test321.hs deleted file mode 100644 index 5cee20d..0000000 --- a/data/Test321.hs +++ /dev/null @@ -1 +0,0 @@ -cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] diff --git a/data/Test322.hs b/data/Test322.hs deleted file mode 100644 index f515f6d..0000000 --- a/data/Test322.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -deriveFromJSON (unPrefix "assignPost") ''AssignmentPost diff --git a/data/Test323.hs b/data/Test323.hs deleted file mode 100644 index ae0ee2e..0000000 --- a/data/Test323.hs +++ /dev/null @@ -1,7 +0,0 @@ -main = -- a - let --b - x = 1 -- x - y = 2 -- y - in do - print x - print y diff --git a/data/Test324.hs b/data/Test324.hs deleted file mode 100644 index fcbe491..0000000 --- a/data/Test324.hs +++ /dev/null @@ -1,9 +0,0 @@ -alternatives :: Parser (Maybe Text) -alternatives = - alternativeOne -- first try this one - <|> alterantiveTwo -- then this one - <|> alternativeThree -- then this one - where - alternativeOne = purer "one" - alternativeTwo = purer "two" - alterantiveThree = purer "three" diff --git a/data/Test325.hs b/data/Test325.hs deleted file mode 100644 index b8d67d0..0000000 --- a/data/Test325.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -func = do - let !forced = some - pure () diff --git a/data/Test326.hs b/data/Test326.hs deleted file mode 100644 index 0435d04..0000000 --- a/data/Test326.hs +++ /dev/null @@ -1,4 +0,0 @@ -spanKey p q = case minViewWithKey q of - Just ((k, _), q') | p k -> - let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') - _ -> ([], q) diff --git a/data/Test327.hs b/data/Test327.hs deleted file mode 100644 index b7efa94..0000000 --- a/data/Test327.hs +++ /dev/null @@ -1 +0,0 @@ -a :: () ':- () diff --git a/data/Test328.hs b/data/Test328.hs deleted file mode 100644 index c2ace2f..0000000 --- a/data/Test328.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = do - createDirectoryIfMissing True path - openFile fileName AppendMode diff --git a/data/Test329.hs b/data/Test329.hs deleted file mode 100644 index 449cf88..0000000 --- a/data/Test329.hs +++ /dev/null @@ -1,7 +0,0 @@ -alternatives :: Parser (Maybe Text) -alternatives = -- a - ( -- b - alternativeOne -- c - <|> alterantiveTwo -- d - <|> alternativeThree -- e - ) -- f diff --git a/data/Test33.hs b/data/Test33.hs deleted file mode 100644 index 335c68e..0000000 --- a/data/Test33.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () diff --git a/data/Test330.hs b/data/Test330.hs deleted file mode 100644 index 0485ac6..0000000 --- a/data/Test330.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall a - . () - => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa -func - :: () - => aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -> aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test331.hs b/data/Test331.hs deleted file mode 100644 index 9737285..0000000 --- a/data/Test331.hs +++ /dev/null @@ -1,5 +0,0 @@ -go l [] = Right l -go l ((IRType, _a) : eqr) = go l eqr -go l ((_, IRType) : eqr) = go l eqr -go _ ((IRTypeError ps t1 t2, _) : _) = Left $ makeError ps t1 t2 -go _ ((_, IRTypeError ps t1 t2) : _) = Left $ makeError ps t1 t2 diff --git a/data/Test332.hs b/data/Test332.hs deleted file mode 100644 index 1785320..0000000 --- a/data/Test332.hs +++ /dev/null @@ -1,2 +0,0 @@ -type instance XPure StageParse = () -type Pair a = (a, a) diff --git a/data/Test333.hs b/data/Test333.hs deleted file mode 100644 index 0b87f50..0000000 --- a/data/Test333.hs +++ /dev/null @@ -1,18 +0,0 @@ --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = - let - eyuAfrarIso' - :: (RveoexdxunuAafalm -> Axlau (Axlau (a, OinejrdCplle))) - -> Gbodoy - -> Axlau (Axlau OinejrdCplle, Gbodoy) - eyuAfrarIso' = ulcPaaekBst cnehokzozwbVaguvu - amkgoxEhalazJjxunecCuIfaw - :: Axlau (Axlau OinejrdCplle, Gbodoy) -> Axlau RqlnrluYqednbCiggxi - amkgoxEhalazJjxunecCuIfaw uKqviuBisjtn = do - (sEmo, quc) <- uKqviuBisjtn - pure (xoheccewfWoeyiagOkfodiq sEmo quc) - xoheccewfWoeyiagOkfodiq - :: Axlau OinejrdCplle -> Gbodoy -> RqlnrluYqednbCiggxi - xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of - Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo - in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) diff --git a/data/Test334.hs b/data/Test334.hs deleted file mode 100644 index f97dfd6..0000000 --- a/data/Test334.hs +++ /dev/null @@ -1,5 +0,0 @@ -spec = do - it "creates a snapshot at the given level" . withGraph runDB $ do - lift $ do - studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x - elaSnapshotReadingLevel snapshot `shouldBe` 12 diff --git a/data/Test335.hs b/data/Test335.hs deleted file mode 100644 index 0a2a760..0000000 --- a/data/Test335.hs +++ /dev/null @@ -1,12 +0,0 @@ -jaicyhHumzo btrKpeyiFej mava = do - m :: VtohxeRgpmgsu <- qloxIfiq mava - case m of - ZumnaoFujayerIswadabo kkecm chlixxag -> do - imomue <- ozisduRaqiseSBAob btrKpeyiFej $ \s -> - case MizA.pigevo kkecm (_tc_gulawulu s) of - Ebocaba -> - ( s { _tc_gulawulu = MizA.jxariu kkecm rwuRqxzhjo (_tc_gulawulu s) } - , Gtzvonm - ) - Xcde{} -> (s, Pioemav) - pure imomue diff --git a/data/Test336.hs b/data/Test336.hs deleted file mode 100644 index 5876f85..0000000 --- a/data/Test336.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_indentPolicy: IndentPolicyMultiple } -foo = bar - arg1 -- this is the first argument - arg2 -- this is the second argument - arg3 -- this is the third argument, now I'll skip one comment - arg4 - arg5 -- this is the fifth argument - arg6 -- this is the sixth argument diff --git a/data/Test337.hs b/data/Test337.hs deleted file mode 100644 index 917af95..0000000 --- a/data/Test337.hs +++ /dev/null @@ -1,4 +0,0 @@ -True `nand` True = False -nand _ _ = True -nor False False = True -_ `nor` _ = False diff --git a/data/Test338.hs b/data/Test338.hs deleted file mode 100644 index e6df6c6..0000000 --- a/data/Test338.hs +++ /dev/null @@ -1 +0,0 @@ -f ((:) a as) = undefined diff --git a/data/Test339.hs b/data/Test339.hs deleted file mode 100644 index cfa949d..0000000 --- a/data/Test339.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -a = \x -> x -b = \ ~x -> x -c = \ !x -> x -d = \(~x) -> x diff --git a/data/Test34.hs b/data/Test34.hs deleted file mode 100644 index 24f6b28..0000000 --- a/data/Test34.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -addFlagStringParam - :: forall f out - . (Applicative f) - => String -- ^ short flag chars, i.e. "v" for -v - -> [String] -- ^ list of long names, i.e. ["verbose"] - -> String -- ^ param name - -> Flag String -- ^ properties - -> CmdParser f out String diff --git a/data/Test340.hs b/data/Test340.hs deleted file mode 100644 index fb61bc1..0000000 --- a/data/Test340.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -func :: forall b . Show b => b -> String diff --git a/data/Test341.hs b/data/Test341.hs deleted file mode 100644 index cea68da..0000000 --- a/data/Test341.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -f :: ((~) a b) => a -> b -f = id diff --git a/data/Test342.hs b/data/Test342.hs deleted file mode 100644 index c522948..0000000 --- a/data/Test342.hs +++ /dev/null @@ -1,50 +0,0 @@ --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -vakjkeSulxudbFokvir = Duotpo - { _ekku_gcrpbze = xgonae (1 :: Int) - , _oola_louwu = FoqsiYcuidx - { _xxagu_umea_iaztoj = xgonae False - , _tuktg_tizo_kfikacygsqf = xgonae False - , _ahzbo_xpow_otq_nzeyufq = xgonae False - , _uagpi_lzps_luy_xcjn = xgonae False - , _dxono_qjef_aqtafq_bes = xgonae False - , _yzuaf_nviy_vuhwxe_ihnbo_uhw = xgonae False - , _iwcit_fzjs_yerakt_dicox_mtryitko = xgonae False - , _ehjim_ucfe_dewarp_newrt_gso = xgonae False - , _ogtxb_ivoj_amqgai_rttui_xuwhetb = xgonae False - , _bhycb_iexz_megaug_qunoa_ohaked = xgonae False - , _nnmbe_uqgt_ewsuga_vaiis = xgonae False - , _otzil_ucvugaiyj_aosoiatunx_asir = xgonae False - } - , _iwsc_lalojz = XqspaiDainqw - { _uajznac_ugah = xgonae (80 :: Int) - , _qayziku_gazibzDejipj = xgonae DewizeCxwgyiKjig - , _auhebll_fiqjxyArfxia = xgonae (2 :: Int) - , _zubfuhq_dupiwnIoophXameeet = xgonae True - , _oavnuqg_opkreyOufuIkifiin = xgonae True - , _ufojfwy_fhuzcePeqwfu = xgonae (50 :: Int) - , _mlosikq_zajdxxSeRoelpf = xgonae (50 :: Int) - , _heemavf_fjgOfoaikh = xgonae (FyoVfvdygaZuzuvbeWarwuq 3) - , _ohxmeoq_ogtbfoPtqezVseu = xgonae (EdjotoLcbapUdiuMmytwoig 0.7) - , _omupuiu_ituamexjuLccwu = xgonae (30 :: Int) - , _xoseksf_atvwwdwaoHanofMyUvujjopoz = xgonae True - , _umuuuat_nuamezwWeqfUqzrnaxwp = xgonae False - , _uuriguz_wixhutbuKecigaFiwosret = xgonae True - , _betohxp_scixaLsvcesErtwItxrnaJmuz = xgonae False - , _lchxgee_olaetGcqzuqxVujenCzexub = xgonae True - , _egeibao_imamkuigqikhZdcbpidokVcixiqew = xgonae False - } - , _nloo_cfmrgZcisiugk = YuwodSavxwnicBekuel - { _oebew_rrtpvthUzlizjAqIwesly = xgonae False - , _blkff_Acxoid = xgonae False - , _datei_YewolAowoqOpunvpgu = xgonae BeekgUzojaPnixxaruJehyPmnnfu - , _ejfrj_eheb_justvh_pumcp_ismya = xgonae False - } - , _kena_uzeddovosoki = NyoRvshullezUpauud - { _mtfuwi_TUVEmoi = xgonae RZXKoytUtogx - , _larqam_adaxPehaylZafeqgpc = xgonae False - } - , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } - , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False - , _qaqb_eykzuyuwi = xgonae False - -- test comment - } diff --git a/data/Test343.hs b/data/Test343.hs deleted file mode 100644 index bb5d7d2..0000000 --- a/data/Test343.hs +++ /dev/null @@ -1,10 +0,0 @@ --- brittany { lconfig_indentPolicy: IndentPolicyLeft } -vakjkeSulxudbFokvir = Duotpo - { _ekku_gcrpbze = xgonae (1 :: Int) - , _spob_qipaarx = KaxavsmOtoyeaq { _rusrirw_okx = Tajemkix [] } - , _vmah_uivucnfka_ikaquebxay_gzcm = xgonae False - , _qaqb_eykzuyuwi = xgonae False - -- test comment - , -- N.B. - .. -- x - } diff --git a/data/Test344.hs b/data/Test344.hs deleted file mode 100644 index 53649fc..0000000 --- a/data/Test344.hs +++ /dev/null @@ -1,7 +0,0 @@ -func = abc + def - -- a - -- b - -- comment - where - abc = 13 - def = 1 diff --git a/data/Test345.hs b/data/Test345.hs deleted file mode 100644 index 613a398..0000000 --- a/data/Test345.hs +++ /dev/null @@ -1,13 +0,0 @@ -zItazySunefp twgq nlyo lwojjoBiecao = - let mhIarjyai = - ukwAausnfcn - $ XojlsTOSR.vuwOvuvdAZUOJaa - $ XojlsTOSR.vkesForanLiufjeDI - $ XojlsTOSR.vkesForanLiufjeDI - $ XojlsTOSR.popjAyijoWarueeP - $ XojlsTOSR.jpwuPmafuDqlbkt nlyo - $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng - $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow - $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) - $ etOslnoz lwojjoBiecao - in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) diff --git a/data/Test346.hs b/data/Test346.hs deleted file mode 100644 index 83ba0bc..0000000 --- a/data/Test346.hs +++ /dev/null @@ -1,2 +0,0 @@ --- test -module MyModule where diff --git a/data/Test347.hs b/data/Test347.hs deleted file mode 100644 index d01c656..0000000 --- a/data/Test347.hs +++ /dev/null @@ -1,8 +0,0 @@ -foo = - [ ("xxx", "xx") - , -- - ("xx" , "xx") - -- - , ("xx" , "xxxxx") - , ("xx" , "xx") - ] diff --git a/data/Test348.hs b/data/Test348.hs deleted file mode 100644 index d0b4eb5..0000000 --- a/data/Test348.hs +++ /dev/null @@ -1,8 +0,0 @@ -foo = - [ ("xx", "xx") - , ( "xx" -- - , "xx" - ) - , ("xx", "xxxxx") - , ("xx", "xx") - ] diff --git a/data/Test349.hs b/data/Test349.hs deleted file mode 100644 index 0d374de..0000000 --- a/data/Test349.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main - ( DataTypeI - , DataTypeII(DataConstructor) - -- * Haddock heading - , name - ) where diff --git a/data/Test35.hs b/data/Test35.hs deleted file mode 100644 index 7e217d5..0000000 --- a/data/Test35.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b diff --git a/data/Test350.hs b/data/Test350.hs deleted file mode 100644 index 0f5b4e9..0000000 --- a/data/Test350.hs +++ /dev/null @@ -1,23 +0,0 @@ -xeoeqibIaib - :: ( KqujhIsaus m - , XivuvIpoboi Droqifim m - , IgorvOtowtf m - , RyagaYaqac m - , QouruDU m - ) - => MaptAdfuxgu - -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd - -> QNOZqwuzg - -> Eoattuq - '[ XkatytdWdquraosu -- test comment - , KyezKijim -- another test comment - , DjmioeePuoeg - , NinrxoiOwezc - , QATAlrijacpk - , TrutvotwIwifiqOjdtu - , CoMmuatjwr - , BoZckzqyodseZole - , VagfwoXaeChfqe - ] - m - () diff --git a/data/Test351.hs b/data/Test351.hs deleted file mode 100644 index fe25514..0000000 --- a/data/Test351.hs +++ /dev/null @@ -1,7 +0,0 @@ -createRedirectedProcess processConfig = do - let redirectedProc = (_processConfig_inner processConfig) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - foo diff --git a/data/Test352.hs b/data/Test352.hs deleted file mode 100644 index 3e5d558..0000000 --- a/data/Test352.hs +++ /dev/null @@ -1,5 +0,0 @@ -instance HasDependencies SomeDataModel where - -- N.B. Here is a bunch of explanatory context about the relationship - -- between these data models or whatever. - type Dependencies SomeDataModel - = (SomeOtherDataModelId, SomeOtherOtherDataModelId) diff --git a/data/Test353.hs b/data/Test353.hs deleted file mode 100644 index cedb99d..0000000 --- a/data/Test353.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = - do - y - >>= x diff --git a/data/Test354.hs b/data/Test354.hs deleted file mode 100644 index e082c6d..0000000 --- a/data/Test354.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test355.hs b/data/Test355.hs deleted file mode 100644 index 56cf385..0000000 --- a/data/Test355.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo diff --git a/data/Test356.hs b/data/Test356.hs deleted file mode 100644 index 94a19a4..0000000 --- a/data/Test356.hs +++ /dev/null @@ -1,11 +0,0 @@ --- brittany { lconfig_indentAmount: 8, lconfig_indentPolicy: IndentPolicyMultiple } -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo -foo = do - let aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa = - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - foo diff --git a/data/Test357.hs b/data/Test357.hs deleted file mode 100644 index 9fd454a..0000000 --- a/data/Test357.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_indentAmount: 4, lconfig_indentPolicy: IndentPolicyMultiple } -foo = asdyf8asdf - "ajsdfas" - [ asjdf asyhf $ do - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - ] diff --git a/data/Test358.hs b/data/Test358.hs deleted file mode 100644 index 7a121e7..0000000 --- a/data/Test358.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: a -> a diff --git a/data/Test359.hs b/data/Test359.hs deleted file mode 100644 index 6991c53..0000000 --- a/data/Test359.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test36.hs b/data/Test36.hs deleted file mode 100644 index 7fc70e4..0000000 --- a/data/Test36.hs +++ /dev/null @@ -1 +0,0 @@ -func :: a -> b -- comment diff --git a/data/Test360.hs b/data/Test360.hs deleted file mode 100644 index b7c0128..0000000 --- a/data/Test360.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj diff --git a/data/Test361.hs b/data/Test361.hs deleted file mode 100644 index ffd3ff9..0000000 --- a/data/Test361.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: ((a)) diff --git a/data/Test362.hs b/data/Test362.hs deleted file mode 100644 index df79511..0000000 --- a/data/Test362.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: (a -> a) -> a diff --git a/data/Test363.hs b/data/Test363.hs deleted file mode 100644 index 921d92d..0000000 --- a/data/Test363.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: a -> (a -> a) diff --git a/data/Test364.hs b/data/Test364.hs deleted file mode 100644 index ed845fb..0000000 --- a/data/Test364.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: (((((((((()))))))))) --- current output is.. funny. wonder if that can/needs to be improved.. diff --git a/data/Test365.hs b/data/Test365.hs deleted file mode 100644 index bf8f673..0000000 --- a/data/Test365.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: () diff --git a/data/Test366.hs b/data/Test366.hs deleted file mode 100644 index a478841..0000000 --- a/data/Test366.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - ) diff --git a/data/Test367.hs b/data/Test367.hs deleted file mode 100644 index 165c111..0000000 --- a/data/Test367.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) diff --git a/data/Test368.hs b/data/Test368.hs deleted file mode 100644 index 4a1e980..0000000 --- a/data/Test368.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) - -> lakjsdlkjasldkj diff --git a/data/Test369.hs b/data/Test369.hs deleted file mode 100644 index ed4d90c..0000000 --- a/data/Test369.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> lakjsdlkjasldkj diff --git a/data/Test37.hs b/data/Test37.hs deleted file mode 100644 index 70aa3c6..0000000 --- a/data/Test37.hs +++ /dev/null @@ -1,2 +0,0 @@ -funcA :: a -> b -- comment A -funcB :: a -> b -- comment B diff --git a/data/Test370.hs b/data/Test370.hs deleted file mode 100644 index 4621ea3..0000000 --- a/data/Test370.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) diff --git a/data/Test371.hs b/data/Test371.hs deleted file mode 100644 index 0ec2ac4..0000000 --- a/data/Test371.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: asd -> Either a b diff --git a/data/Test372.hs b/data/Test372.hs deleted file mode 100644 index 2adc98c..0000000 --- a/data/Test372.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: asd - -> Either - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test373.hs b/data/Test373.hs deleted file mode 100644 index faee723..0000000 --- a/data/Test373.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: asd - -> Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test374.hs b/data/Test374.hs deleted file mode 100644 index be2766e..0000000 --- a/data/Test374.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd diff --git a/data/Test375.hs b/data/Test375.hs deleted file mode 100644 index 6efe43f..0000000 --- a/data/Test375.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) diff --git a/data/Test376.hs b/data/Test376.hs deleted file mode 100644 index 8d7a7ae..0000000 --- a/data/Test376.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: Trither - asd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) diff --git a/data/Test377.hs b/data/Test377.hs deleted file mode 100644 index 16d6ee7..0000000 --- a/data/Test377.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) diff --git a/data/Test378.hs b/data/Test378.hs deleted file mode 100644 index b7a24ca..0000000 --- a/data/Test378.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: asd - -> ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd diff --git a/data/Test379.hs b/data/Test379.hs deleted file mode 100644 index 50f95b2..0000000 --- a/data/Test379.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: ( Trither - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> asd diff --git a/data/Test38.hs b/data/Test38.hs deleted file mode 100644 index 6978eb6..0000000 --- a/data/Test38.hs +++ /dev/null @@ -1,11 +0,0 @@ --- a -func -- b - :: -- c - a -- d - -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j --- k diff --git a/data/Test380.hs b/data/Test380.hs deleted file mode 100644 index 4453786..0000000 --- a/data/Test380.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: [a -> b] diff --git a/data/Test381.hs b/data/Test381.hs deleted file mode 100644 index faf63f1..0000000 --- a/data/Test381.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ] diff --git a/data/Test382.hs b/data/Test382.hs deleted file mode 100644 index fbcaa1c..0000000 --- a/data/Test382.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] diff --git a/data/Test383.hs b/data/Test383.hs deleted file mode 100644 index edfefd8..0000000 --- a/data/Test383.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: (a, b, c) diff --git a/data/Test384.hs b/data/Test384.hs deleted file mode 100644 index cb8e4cd..0000000 --- a/data/Test384.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: ((a, b, c), (a, b, c), (a, b, c)) diff --git a/data/Test385.hs b/data/Test385.hs deleted file mode 100644 index 8177c7f..0000000 --- a/data/Test385.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) diff --git a/data/Test386.hs b/data/Test386.hs deleted file mode 100644 index e3efa79..0000000 --- a/data/Test386.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ) diff --git a/data/Test387.hs b/data/Test387.hs deleted file mode 100644 index 3a64ee9..0000000 --- a/data/Test387.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - ] diff --git a/data/Test388.hs b/data/Test388.hs deleted file mode 100644 index 15b0b06..0000000 --- a/data/Test388.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b diff --git a/data/Test389.hs b/data/Test389.hs deleted file mode 100644 index 5acb0b6..0000000 --- a/data/Test389.hs +++ /dev/null @@ -1,11 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . Foo - => ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () diff --git a/data/Test39.hs b/data/Test39.hs deleted file mode 100644 index 9c9b324..0000000 --- a/data/Test39.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = f - where - {-# INLINE f #-} - f = id diff --git a/data/Test390.hs b/data/Test390.hs deleted file mode 100644 index 72f2d0a..0000000 --- a/data/Test390.hs +++ /dev/null @@ -1,11 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE ScopedTypeVariables #-} -func - :: forall m - . ColMap2 - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> ColInfo - -> m () diff --git a/data/Test391.hs b/data/Test391.hs deleted file mode 100644 index 15b0b06..0000000 --- a/data/Test391.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE ScopedTypeVariables #-} -func :: forall (a :: *) b . a -> b diff --git a/data/Test392.hs b/data/Test392.hs deleted file mode 100644 index de8ad75..0000000 --- a/data/Test392.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func :: a -> b -- comment diff --git a/data/Test393.hs b/data/Test393.hs deleted file mode 100644 index 1a15a53..0000000 --- a/data/Test393.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -funcA :: a -> b -- comment A -funcB :: a -> b -- comment B diff --git a/data/Test394.hs b/data/Test394.hs deleted file mode 100644 index 44eb854..0000000 --- a/data/Test394.hs +++ /dev/null @@ -1,11 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } --- a -func -- b - :: -- c - a -- d - -> -- e - ( -- f - c -- g - , -- h - d -- i - ) -- j-- k diff --git a/data/Test395.hs b/data/Test395.hs deleted file mode 100644 index 729290d..0000000 --- a/data/Test395.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE ImplicitParams #-} -func :: (?asd::Int) -> () diff --git a/data/Test396.hs b/data/Test396.hs deleted file mode 100644 index f706d17..0000000 --- a/data/Test396.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE ImplicitParams #-} -func - :: ( ?asd - :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - ) - -> () diff --git a/data/Test397.hs b/data/Test397.hs deleted file mode 100644 index 750f3f9..0000000 --- a/data/Test397.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = f - where - {-# INLINE f #-} - f = id diff --git a/data/Test398.hs b/data/Test398.hs deleted file mode 100644 index 8770767..0000000 --- a/data/Test398.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = ($) - where - {-# INLINE ($) #-} - ($) = id diff --git a/data/Test399.hs b/data/Test399.hs deleted file mode 100644 index 996e831..0000000 --- a/data/Test399.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = f - where - {-# INLINE CONLIKE [1] f #-} - f = id diff --git a/data/Test4.hs b/data/Test4.hs deleted file mode 100644 index e517aa0..0000000 --- a/data/Test4.hs +++ /dev/null @@ -1 +0,0 @@ -func :: ((a)) diff --git a/data/Test40.hs b/data/Test40.hs deleted file mode 100644 index c182430..0000000 --- a/data/Test40.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = ($) - where - {-# INLINE ($) #-} - ($) = id diff --git a/data/Test400.hs b/data/Test400.hs deleted file mode 100644 index 8b00a95..0000000 --- a/data/Test400.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = f - where - {-# INLINE [~1] f #-} - f = id diff --git a/data/Test401.hs b/data/Test401.hs deleted file mode 100644 index 7d334ba..0000000 --- a/data/Test401.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -data Foo = Bar - { foo :: Baz - } diff --git a/data/Test402.hs b/data/Test402.hs deleted file mode 100644 index f94f463..0000000 --- a/data/Test402.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -data Foo = Bar - { foo, bar :: Baz - } diff --git a/data/Test403.hs b/data/Test403.hs deleted file mode 100644 index 3b2e688..0000000 --- a/data/Test403.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } diff --git a/data/Test404.hs b/data/Test404.hs deleted file mode 100644 index 9144cc0..0000000 --- a/data/Test404.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -data Foo = Bar - { foo, biz :: Baz - , bar :: Bizzz - } diff --git a/data/Test405.hs b/data/Test405.hs deleted file mode 100644 index 7d20e0d..0000000 --- a/data/Test405.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - deriving Show diff --git a/data/Test406.hs b/data/Test406.hs deleted file mode 100644 index cfe7ae2..0000000 --- a/data/Test406.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -data Foo = Bar - { foo :: Baz - , bar :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test407.hs b/data/Test407.hs deleted file mode 100644 index b889d43..0000000 --- a/data/Test407.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func x = x diff --git a/data/Test408.hs b/data/Test408.hs deleted file mode 100644 index 2764fb5..0000000 --- a/data/Test408.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -x *** y = x diff --git a/data/Test409.hs b/data/Test409.hs deleted file mode 100644 index a9a0917..0000000 --- a/data/Test409.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -(***) x y = x diff --git a/data/Test41.hs b/data/Test41.hs deleted file mode 100644 index 205a728..0000000 --- a/data/Test41.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = f - where - {-# INLINE CONLIKE [1] f #-} - f = id diff --git a/data/Test410.hs b/data/Test410.hs deleted file mode 100644 index 155d06d..0000000 --- a/data/Test410.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func _ = x diff --git a/data/Test411.hs b/data/Test411.hs deleted file mode 100644 index 73dc40a..0000000 --- a/data/Test411.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = - x diff --git a/data/Test412.hs b/data/Test412.hs deleted file mode 100644 index 92a61f3..0000000 --- a/data/Test412.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x diff --git a/data/Test413.hs b/data/Test413.hs deleted file mode 100644 index a5f08d9..0000000 --- a/data/Test413.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b - = x diff --git a/data/Test414.hs b/data/Test414.hs deleted file mode 100644 index c0690eb..0000000 --- a/data/Test414.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func (A a) = a diff --git a/data/Test415.hs b/data/Test415.hs deleted file mode 100644 index fb95ff8..0000000 --- a/data/Test415.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func (x : xr) = x diff --git a/data/Test416.hs b/data/Test416.hs deleted file mode 100644 index 490720c..0000000 --- a/data/Test416.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func (x :+: xr) = x diff --git a/data/Test417.hs b/data/Test417.hs deleted file mode 100644 index 8ee6b8b..0000000 --- a/data/Test417.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func | True = x diff --git a/data/Test418.hs b/data/Test418.hs deleted file mode 100644 index 506b4d1..0000000 --- a/data/Test418.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func x - | x = simple expression - | otherwise = 0 diff --git a/data/Test419.hs b/data/Test419.hs deleted file mode 100644 index ee128f1..0000000 --- a/data/Test419.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func x - | a somewhat longer guard x = "and a somewhat longer expession that does not" - | otherwise = "fit without putting the guards in new lines" diff --git a/data/Test42.hs b/data/Test42.hs deleted file mode 100644 index cfd38bb..0000000 --- a/data/Test42.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# NOINLINE func #-} -func :: Int diff --git a/data/Test420.hs b/data/Test420.hs deleted file mode 100644 index a8f1881..0000000 --- a/data/Test420.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func x - | very long guard, another rather long guard that refers to x = nontrivial - expression - foo - bar - alsdkjlasdjlasj - | otherwise = 0 diff --git a/data/Test421.hs b/data/Test421.hs deleted file mode 100644 index 5dd669d..0000000 --- a/data/Test421.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func x - | very long guard, another rather long guard that refers to x - = nontrivialexpression foo bar alsdkjlasdjlasj - | otherwise - = 0 diff --git a/data/Test422.hs b/data/Test422.hs deleted file mode 100644 index 830e3ee..0000000 --- a/data/Test422.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func x - | very loooooooooooooooooooooooooooooong guard - , another rather long guard that refers to x - = nontrivial expression foo bar alsdkjlasdjlasj - | otherwise - = 0 diff --git a/data/Test423.hs b/data/Test423.hs deleted file mode 100644 index 88d75b3..0000000 --- a/data/Test423.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = x -describe "infix op" $ do diff --git a/data/Test424.hs b/data/Test424.hs deleted file mode 100644 index 1258fc6..0000000 --- a/data/Test424.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = x + x diff --git a/data/Test425.hs b/data/Test425.hs deleted file mode 100644 index 1ed0c86..0000000 --- a/data/Test425.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test426.hs b/data/Test426.hs deleted file mode 100644 index e70a294..0000000 --- a/data/Test426.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj diff --git a/data/Test427.hs b/data/Test427.hs deleted file mode 100644 index 38b5fd2..0000000 --- a/data/Test427.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test428.hs b/data/Test428.hs deleted file mode 100644 index ab8bc90..0000000 --- a/data/Test428.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = 1 -func = "abc" -func = 1.1e5 -func = 'x' -func = 981409823458910394810928414192837123987123987123 diff --git a/data/Test429.hs b/data/Test429.hs deleted file mode 100644 index 6fcf5ea..0000000 --- a/data/Test429.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE LambdaCase #-} -func = \case - FooBar -> x - Baz -> y diff --git a/data/Test43.hs b/data/Test43.hs deleted file mode 100644 index 83572d8..0000000 --- a/data/Test43.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = f - where - {-# INLINE [~1] f #-} - f = id diff --git a/data/Test430.hs b/data/Test430.hs deleted file mode 100644 index 3efc267..0000000 --- a/data/Test430.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = \x -> abc -describe "app" $ do diff --git a/data/Test431.hs b/data/Test431.hs deleted file mode 100644 index c1c1c58..0000000 --- a/data/Test431.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = klajsdas klajsdas klajsdas diff --git a/data/Test432.hs b/data/Test432.hs deleted file mode 100644 index aa2b380..0000000 --- a/data/Test432.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd diff --git a/data/Test433.hs b/data/Test433.hs deleted file mode 100644 index 851e5cb..0000000 --- a/data/Test433.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - lakjsdlajsdljas - lakjsdlajsdljas - lakjsdlajsdljas diff --git a/data/Test434.hs b/data/Test434.hs deleted file mode 100644 index f52edc1..0000000 --- a/data/Test434.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = (1 +) diff --git a/data/Test435.hs b/data/Test435.hs deleted file mode 100644 index 09d341e..0000000 --- a/data/Test435.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = (+ 1) diff --git a/data/Test436.hs b/data/Test436.hs deleted file mode 100644 index 25a7bda..0000000 --- a/data/Test436.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = (1 `abc`) diff --git a/data/Test437.hs b/data/Test437.hs deleted file mode 100644 index 3c56cf8..0000000 --- a/data/Test437.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = (`abc` 1) diff --git a/data/Test438.hs b/data/Test438.hs deleted file mode 100644 index a9c30d5..0000000 --- a/data/Test438.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = (abc, def) diff --git a/data/Test439.hs b/data/Test439.hs deleted file mode 100644 index 90cb29d..0000000 --- a/data/Test439.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - ( lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd - ) diff --git a/data/Test44.hs b/data/Test44.hs deleted file mode 100644 index 7dd43f0..0000000 --- a/data/Test44.hs +++ /dev/null @@ -1,2 +0,0 @@ -data Foo = Bar {} -data Biz = Baz diff --git a/data/Test440.hs b/data/Test440.hs deleted file mode 100644 index 0d46933..0000000 --- a/data/Test440.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -foo = - let longIdentifierForShortValue = 1 - in longIdentifierForShortValue + longIdentifierForShortValue diff --git a/data/Test441.hs b/data/Test441.hs deleted file mode 100644 index 6a77a85..0000000 --- a/data/Test441.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - stmt - stmt diff --git a/data/Test442.hs b/data/Test442.hs deleted file mode 100644 index 3ab95e7..0000000 --- a/data/Test442.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - x <- stmt - stmt x diff --git a/data/Test443.hs b/data/Test443.hs deleted file mode 100644 index c832f21..0000000 --- a/data/Test443.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - let x = 13 - stmt x diff --git a/data/Test444.hs b/data/Test444.hs deleted file mode 100644 index 31b1cc7..0000000 --- a/data/Test444.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - foooooo - $ [ case - foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - of - _ -> True - ] diff --git a/data/Test445.hs b/data/Test445.hs deleted file mode 100644 index c3f325f..0000000 --- a/data/Test445.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE MultiWayIf #-} -func = if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test446.hs b/data/Test446.hs deleted file mode 100644 index 4d8efd2..0000000 --- a/data/Test446.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE MultiWayIf #-} -func = do - foo - bar $ if - | cond1 -> loooooooooooooooooooooooooooooong expr1 - | cond2 -> loooooooooooooooooooooooooooooong expr2 diff --git a/data/Test447.hs b/data/Test447.hs deleted file mode 100644 index 6e718f0..0000000 --- a/data/Test447.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - foo - $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - ] - ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] diff --git a/data/Test448.hs b/data/Test448.hs deleted file mode 100644 index 3884989..0000000 --- a/data/Test448.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main where diff --git a/data/Test449.hs b/data/Test449.hs deleted file mode 100644 index 7a6295f..0000000 --- a/data/Test449.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main () where diff --git a/data/Test45.hs b/data/Test45.hs deleted file mode 100644 index d1c8c85..0000000 --- a/data/Test45.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Foo = Bar - { foo :: Baz - } diff --git a/data/Test450.hs b/data/Test450.hs deleted file mode 100644 index 89316b0..0000000 --- a/data/Test450.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main (main) where diff --git a/data/Test451.hs b/data/Test451.hs deleted file mode 100644 index a55d851..0000000 --- a/data/Test451.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main (main, test1, test2) where diff --git a/data/Test452.hs b/data/Test452.hs deleted file mode 100644 index 4fe8cbf..0000000 --- a/data/Test452.hs +++ /dev/null @@ -1,13 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) where diff --git a/data/Test453.hs b/data/Test453.hs deleted file mode 100644 index eaeb665..0000000 --- a/data/Test453.hs +++ /dev/null @@ -1,13 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main - ( main - -- main - , test1 - , test2 - -- Test 3 - , test3 - , test4 - -- Test 5 - , test5 - -- Test 6 - ) where diff --git a/data/Test454.hs b/data/Test454.hs deleted file mode 100644 index c2e7a8e..0000000 --- a/data/Test454.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main (Test(..)) where diff --git a/data/Test455.hs b/data/Test455.hs deleted file mode 100644 index 6191afd..0000000 --- a/data/Test455.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main (module Main) where diff --git a/data/Test456.hs b/data/Test456.hs deleted file mode 100644 index 3d9694b..0000000 --- a/data/Test456.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main (Test(Test, a, b)) where diff --git a/data/Test457.hs b/data/Test457.hs deleted file mode 100644 index 82a8e14..0000000 --- a/data/Test457.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -module Main (Test()) where diff --git a/data/Test458.hs b/data/Test458.hs deleted file mode 100644 index df50e76..0000000 --- a/data/Test458.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } --- Intentionally left empty diff --git a/data/Test459.hs b/data/Test459.hs deleted file mode 100644 index 0dea4be..0000000 --- a/data/Test459.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Data.List diff --git a/data/Test46.hs b/data/Test46.hs deleted file mode 100644 index 2472782..0000000 --- a/data/Test46.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Foo = Bar - { foo, bar :: Baz - } diff --git a/data/Test460.hs b/data/Test460.hs deleted file mode 100644 index 50b8621..0000000 --- a/data/Test460.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Data.List as L diff --git a/data/Test461.hs b/data/Test461.hs deleted file mode 100644 index 835646b..0000000 --- a/data/Test461.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import qualified Data.List diff --git a/data/Test462.hs b/data/Test462.hs deleted file mode 100644 index 7e772a5..0000000 --- a/data/Test462.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import qualified Data.List as L diff --git a/data/Test463.hs b/data/Test463.hs deleted file mode 100644 index 1bfa264..0000000 --- a/data/Test463.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import safe Data.List as L diff --git a/data/Test464.hs b/data/Test464.hs deleted file mode 100644 index 53fad4c..0000000 --- a/data/Test464.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import {-# SOURCE #-} Data.List () diff --git a/data/Test465.hs b/data/Test465.hs deleted file mode 100644 index 8e5b381..0000000 --- a/data/Test465.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import safe qualified Data.List hiding (nub) diff --git a/data/Test466.hs b/data/Test466.hs deleted file mode 100644 index 73046d6..0000000 --- a/data/Test466.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import {-# SOURCE #-} safe qualified Data.List diff --git a/data/Test467.hs b/data/Test467.hs deleted file mode 100644 index 7745833..0000000 --- a/data/Test467.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import qualified "base" Data.List diff --git a/data/Test468.hs b/data/Test468.hs deleted file mode 100644 index 2c704b4..0000000 --- a/data/Test468.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List () -import {-# SOURCE #-} safe qualified Data.List hiding () diff --git a/data/Test469.hs b/data/Test469.hs deleted file mode 100644 index fa53576..0000000 --- a/data/Test469.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import qualified Data.List () diff --git a/data/Test47.hs b/data/Test47.hs deleted file mode 100644 index 2dbac94..0000000 --- a/data/Test47.hs +++ /dev/null @@ -1,4 +0,0 @@ -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } diff --git a/data/Test470.hs b/data/Test470.hs deleted file mode 100644 index 97ce770..0000000 --- a/data/Test470.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Data.List (nub) diff --git a/data/Test471.hs b/data/Test471.hs deleted file mode 100644 index fb499b1..0000000 --- a/data/Test471.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Data.List (foldl', indexElem, nub) diff --git a/data/Test472.hs b/data/Test472.hs deleted file mode 100644 index 39cfd67..0000000 --- a/data/Test472.hs +++ /dev/null @@ -1,16 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test - ( Long - , anymore - , fit - , items - , line - , list - , not - , onA - , quite - , single - , that - , will - , with - ) diff --git a/data/Test473.hs b/data/Test473.hs deleted file mode 100644 index 016a6b7..0000000 --- a/data/Test473.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>))) diff --git a/data/Test474.hs b/data/Test474.hs deleted file mode 100644 index 1716691..0000000 --- a/data/Test474.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test hiding () -import Test as T hiding () diff --git a/data/Test475.hs b/data/Test475.hs deleted file mode 100644 index adbfb6e..0000000 --- a/data/Test475.hs +++ /dev/null @@ -1,15 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Prelude as X - hiding - ( head - , init - , last - , maximum - , minimum - , pred - , read - , readFile - , succ - , tail - , undefined - ) diff --git a/data/Test476.hs b/data/Test476.hs deleted file mode 100644 index 900fb1f..0000000 --- a/data/Test476.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import MoreThanSufficientlyLongModuleNameWithSome - (compact, fit, inA, items, layout, not, that, will) -import TestJustAbitToLongModuleNameLikeThisOneIs () -import TestJustShortEnoughModuleNameLikeThisOne () diff --git a/data/Test477.hs b/data/Test477.hs deleted file mode 100644 index 0f32c77..0000000 --- a/data/Test477.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import TestJustAbitToLongModuleNameLikeThisOneI as T -import TestJustShortEnoughModuleNameLikeThisOn as T diff --git a/data/Test478.hs b/data/Test478.hs deleted file mode 100644 index 3c047b9..0000000 --- a/data/Test478.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import TestJustAbitToLongModuleNameLikeTh hiding () -import TestJustShortEnoughModuleNameLike hiding () diff --git a/data/Test479.hs b/data/Test479.hs deleted file mode 100644 index 3e8adc0..0000000 --- a/data/Test479.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import MoreThanSufficientlyLongModuleNameWithSome - (compact, fit, inA, items, layout, not, that, will) diff --git a/data/Test48.hs b/data/Test48.hs deleted file mode 100644 index 56c5cba..0000000 --- a/data/Test48.hs +++ /dev/null @@ -1,4 +0,0 @@ -data Foo = Bar - { foo, biz :: Baz - , bar :: Bizzz - } diff --git a/data/Test480.hs b/data/Test480.hs deleted file mode 100644 index 4bc1c0c..0000000 --- a/data/Test480.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) diff --git a/data/Test481.hs b/data/Test481.hs deleted file mode 100644 index b6f7509..0000000 --- a/data/Test481.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } --- Test -import Data.List (nub) -- Test -{- Test -} -import qualified Data.List as L (foldl') {- Test -} diff --git a/data/Test482.hs b/data/Test482.hs deleted file mode 100644 index 4fd065e..0000000 --- a/data/Test482.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test - ( abc - , def - -- comment - ) diff --git a/data/Test483.hs b/data/Test483.hs deleted file mode 100644 index 5a03da5..0000000 --- a/data/Test483.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test - ( abc - -- comment - ) diff --git a/data/Test484.hs b/data/Test484.hs deleted file mode 100644 index 7749c61..0000000 --- a/data/Test484.hs +++ /dev/null @@ -1,12 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test - ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) --- Test -import Test (test) diff --git a/data/Test485.hs b/data/Test485.hs deleted file mode 100644 index a1879a2..0000000 --- a/data/Test485.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test - ( -- comment - ) diff --git a/data/Test486.hs b/data/Test486.hs deleted file mode 100644 index e66d47a..0000000 --- a/data/Test486.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test (longbindingNameThatoverflowsColum) -import Test (Long(List, Of, Things)) diff --git a/data/Test487.hs b/data/Test487.hs deleted file mode 100644 index 4fa860d..0000000 --- a/data/Test487.hs +++ /dev/null @@ -1,27 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import Test - ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) -import Test - ( Thing - ( Item - -- and Comment - ) - ) -import Test - ( Thing - ( With - -- Comments - , and - -- also - , items - -- ! - ) - ) diff --git a/data/Test488.hs b/data/Test488.hs deleted file mode 100644 index f65f0d6..0000000 --- a/data/Test488.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine - () diff --git a/data/Test489.hs b/data/Test489.hs deleted file mode 100644 index f16fa76..0000000 --- a/data/Test489.hs +++ /dev/null @@ -1,25 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE BangPatterns #-} -{- - - Test module - -} -module Test - ( test1 - -- ^ test - , test2 - -- | test - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - ) where --- Test -import Data.List (nub) -- Test -{- Test -} -import qualified Data.List as L (foldl') {- Test -} --- Test -import Test (test) diff --git a/data/Test49.hs b/data/Test49.hs deleted file mode 100644 index 3b236c6..0000000 --- a/data/Test49.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Foo = Bar - { fooz :: Baz - , bar :: Bizzz - } - deriving Show diff --git a/data/Test490.hs b/data/Test490.hs deleted file mode 100644 index 0cf1f73..0000000 --- a/data/Test490.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - abc <- foo ---abc -return () diff --git a/data/Test491.hs b/data/Test491.hs deleted file mode 100644 index b625fed..0000000 --- a/data/Test491.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = (()) diff --git a/data/Test492.hs b/data/Test492.hs deleted file mode 100644 index 2585e2d..0000000 --- a/data/Test492.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - let - foo True = True - foo _ = False - return () diff --git a/data/Test493.hs b/data/Test493.hs deleted file mode 100644 index 2585e2d..0000000 --- a/data/Test493.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - let - foo True = True - foo _ = False - return () diff --git a/data/Test494.hs b/data/Test494.hs deleted file mode 100644 index 872a368..0000000 --- a/data/Test494.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - let - foo = True - b = False - return () diff --git a/data/Test495.hs b/data/Test495.hs deleted file mode 100644 index 43d52fe..0000000 --- a/data/Test495.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - let - foo = True - b = False - in return () diff --git a/data/Test496.hs b/data/Test496.hs deleted file mode 100644 index d06ea75..0000000 --- a/data/Test496.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - s <- mGet - mSet $ s { _lstate_indent = _lstate_indent state } diff --git a/data/Test497.hs b/data/Test497.hs deleted file mode 100644 index f862333..0000000 --- a/data/Test497.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent state - , _lstate_foo = _lstate_foo state - } diff --git a/data/Test498.hs b/data/Test498.hs deleted file mode 100644 index 52505be..0000000 --- a/data/Test498.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - s <- mGet - mSet $ s - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo kasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } diff --git a/data/Test499.hs b/data/Test499.hs deleted file mode 100644 index 7362219..0000000 --- a/data/Test499.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = Foo { _lstate_indent = _lstate_indent state } diff --git a/data/Test5.hs b/data/Test5.hs deleted file mode 100644 index 71a352d..0000000 --- a/data/Test5.hs +++ /dev/null @@ -1 +0,0 @@ -func :: (a -> a) -> a diff --git a/data/Test50.hs b/data/Test50.hs deleted file mode 100644 index f249e56..0000000 --- a/data/Test50.hs +++ /dev/null @@ -1,8 +0,0 @@ -data MyRecord = MyConstructor - { bar1, bar2 - :: Loooooooooooooooooooooooooooooooong - -> Loooooooooooooooooooooooooooooooong - , foo1, foo2 - :: Loooooooooooooooooooooooooooooooonger - -> Loooooooooooooooooooooooooooooooonger - } diff --git a/data/Test500.hs b/data/Test500.hs deleted file mode 100644 index 9b188e5..0000000 --- a/data/Test500.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } diff --git a/data/Test501.hs b/data/Test501.hs deleted file mode 100644 index 1cac41f..0000000 --- a/data/Test501.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - Foo - { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - } diff --git a/data/Test502.hs b/data/Test502.hs deleted file mode 100644 index 2482992..0000000 --- a/data/Test502.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do --- abc - -- def - return () diff --git a/data/Test503.hs b/data/Test503.hs deleted file mode 100644 index 36aa1f1..0000000 --- a/data/Test503.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - do - return () - -- abc - -- def - return () diff --git a/data/Test504.hs b/data/Test504.hs deleted file mode 100644 index 3c3d575..0000000 --- a/data/Test504.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func - :: Int -- basic indentation amount - -> Int -- currently used width in current line (after indent) - -- used to accurately calc placing of the current-line - -> LayoutDesc - -> Int diff --git a/data/Test505.hs b/data/Test505.hs deleted file mode 100644 index 0157f35..0000000 --- a/data/Test505.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - (lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj - $ abc - $ def - $ ghi - $ jkl - ) diff --git a/data/Test506.hs b/data/Test506.hs deleted file mode 100644 index ed27504..0000000 --- a/data/Test506.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) - where reassoc (v, e, w) = (v, (e, w)) diff --git a/data/Test507.hs b/data/Test507.hs deleted file mode 100644 index 1795543..0000000 --- a/data/Test507.hs +++ /dev/null @@ -1,5 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -downloadRepoPackage = case repo of - RepoLocal {..} -> return () - RepoLocal { abc } -> return () - RepoLocal{} -> return () diff --git a/data/Test508.hs b/data/Test508.hs deleted file mode 100644 index 5ecfcc9..0000000 --- a/data/Test508.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - let - (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' - -- default local dir target if there's no given target - utargets'' = "foo" - return () diff --git a/data/Test509.hs b/data/Test509.hs deleted file mode 100644 index f66ac30..0000000 --- a/data/Test509.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_ : _)) <- nosuchFooThing - , gast <- award - ] diff --git a/data/Test51.hs b/data/Test51.hs deleted file mode 100644 index ba064e1..0000000 --- a/data/Test51.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE DatatypeContexts #-} -data - ( LooooooooooooooooooooongConstraint a - , LooooooooooooooooooooongConstraint b - ) => - MyRecord a b - = MyConstructor - { foo1, foo2 - :: loooooooooooooooooooooooooooooooong - -> loooooooooooooooooooooooooooooooong - , bar :: a - , bazz :: b - } diff --git a/data/Test510.hs b/data/Test510.hs deleted file mode 100644 index e939f8f..0000000 --- a/data/Test510.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = if x - then if y -- y is important - then foo - else bar - else Nothing diff --git a/data/Test511.hs b/data/Test511.hs deleted file mode 100644 index fcc4b7c..0000000 --- a/data/Test511.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return $ Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR diff --git a/data/Test512.hs b/data/Test512.hs deleted file mode 100644 index 721607a..0000000 --- a/data/Test512.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -layoutWriteNewlineBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiWriter (Seq String) m - ) - => m () diff --git a/data/Test513.hs b/data/Test513.hs deleted file mode 100644 index 19308aa..0000000 --- a/data/Test513.hs +++ /dev/null @@ -1,25 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE MultiWayIf #-} -readMergePersConfig path shouldCreate conf = do - exists <- liftIO $ System.Directory.doesFileExist path - if - | exists -> do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn e - mzero - Right x -> return x - return $ fileConf Semigroup.<> conf - | shouldCreate -> do - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Option . Just . runIdentity) - staticDefaultConfig - return $ conf - | otherwise -> do - return conf diff --git a/data/Test514.hs b/data/Test514.hs deleted file mode 100644 index 8dcc5a1..0000000 --- a/data/Test514.hs +++ /dev/null @@ -1,13 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _) -> InstallOk diff --git a/data/Test515.hs b/data/Test515.hs deleted file mode 100644 index 8dcc5a1..0000000 --- a/data/Test515.hs +++ /dev/null @@ -1,13 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = BuildReport - where - convertInstallOutcome = case result of - Left BR.PlanningFailed -> PlanningFailed - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.TestsFailed _) -> TestsFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _ _) -> InstallOk diff --git a/data/Test516.hs b/data/Test516.hs deleted file mode 100644 index ccf86e7..0000000 --- a/data/Test516.hs +++ /dev/null @@ -1,37 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -showPackageDetailedInfo pkginfo = - renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) - $ char '*' - $+$ something - [ entry "Synopsis" synopsis hideIfNull reflowParagraphs - , entry - "Versions available" - sourceVersions - (altText null "[ Not available from server ]") - (dispTopVersions 9 (preferredVersions pkginfo)) - , entry - "Versions installed" - installedVersions - (altText - null - (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") - ) - (dispTopVersions 4 (preferredVersions pkginfo)) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description hideIfNull reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) - then empty - else text "Modules:" - $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ] diff --git a/data/Test517.hs b/data/Test517.hs deleted file mode 100644 index 5b5926c..0000000 --- a/data/Test517.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -isValidPosition position - | validX && validY = Just position - | otherwise = Nothing diff --git a/data/Test518.hs b/data/Test518.hs deleted file mode 100644 index 5583847..0000000 --- a/data/Test518.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do - (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String - -> IO Bool) <- - ReflexHost.newExternalEvent - liftIO . forkIO . forever $ getLine >>= inputFire - ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent diff --git a/data/Test519.hs b/data/Test519.hs deleted file mode 100644 index 88cd872..0000000 --- a/data/Test519.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } --- Test.hs -module Test where -data X = X diff --git a/data/Test52.hs b/data/Test52.hs deleted file mode 100644 index a8b49da..0000000 --- a/data/Test52.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- brittany { lconfig_allowSinglelineRecord: true } -data MyRecord = forall a . Show a => Bar - { foo :: abittoolongbutnotvery -> abittoolongbutnotvery - } diff --git a/data/Test520.hs b/data/Test520.hs deleted file mode 100644 index d9dac4b..0000000 --- a/data/Test520.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -foldrDesc f z = unSwitchQueue $ \q -> - switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/data/Test521.hs b/data/Test521.hs deleted file mode 100644 index ff6208b..0000000 --- a/data/Test521.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative - ] diff --git a/data/Test522.hs b/data/Test522.hs deleted file mode 100644 index d3c2fb0..0000000 --- a/data/Test522.hs +++ /dev/null @@ -1,8 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -autocheckCases = - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ( "Consistent Result" - , alwaysSame -- already representative - ) - ] diff --git a/data/Test523.hs b/data/Test523.hs deleted file mode 100644 index 78897cd..0000000 --- a/data/Test523.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - [ (abc, (1111, 1111)) - , (def, (2, 2)) - , foo -- comment - ] diff --git a/data/Test524.hs b/data/Test524.hs deleted file mode 100644 index 0aeb4a8..0000000 --- a/data/Test524.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo - where g a b = b + b * a diff --git a/data/Test525.hs b/data/Test525.hs deleted file mode 100644 index 74d9df7..0000000 --- a/data/Test525.hs +++ /dev/null @@ -1,2 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo diff --git a/data/Test526.hs b/data/Test526.hs deleted file mode 100644 index ae6bb6a..0000000 --- a/data/Test526.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = do - abc <- expr - abcccccccccccccccccc <- expr - abcccccccccccccccccccccccccccccccccccccccccc <- expr - abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr diff --git a/data/Test527.hs b/data/Test527.hs deleted file mode 100644 index f3664cd..0000000 --- a/data/Test527.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func (MyLongFoo abc def) = 1 -func (Bar a d) = 2 -func _ = 3 diff --git a/data/Test528.hs b/data/Test528.hs deleted file mode 100644 index 2867ab4..0000000 --- a/data/Test528.hs +++ /dev/null @@ -1,15 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -parserCompactLocation = - [ try - $ [ ParseRelAbs (Text.Read.read digits) _ _ - | digits <- many1 digit - , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe - [ case divPart of - Nothing -> Left $ Text.Read.read digits - Just ddigits -> - Right $ Text.Read.read digits % Text.Read.read ddigits - | digits <- many1 digit - , divPart <- optionMaybe (string "/" *> many1 digit) - ] - ] - ] diff --git a/data/Test529.hs b/data/Test529.hs deleted file mode 100644 index f2b42a8..0000000 --- a/data/Test529.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo diff --git a/data/Test53.hs b/data/Test53.hs deleted file mode 100644 index 82be3f3..0000000 --- a/data/Test53.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a - . LooooooooooooooooooooongConstraint a => - LoooooooooooongConstructor - { foo :: abittoolongbutnotvery -> abittoolongbutnotvery - } diff --git a/data/Test530.hs b/data/Test530.hs deleted file mode 100644 index ae12740..0000000 --- a/data/Test530.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = - fooooooooooooooooooooooooooooooooo - + foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo - foooooooooooooooooooooooooooooooo diff --git a/data/Test531.hs b/data/Test531.hs deleted file mode 100644 index fc1335c..0000000 --- a/data/Test531.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo - [ foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - , foooooooooooooooooooooooooooooooo - ] diff --git a/data/Test532.hs b/data/Test532.hs deleted file mode 100644 index fcda0ed..0000000 --- a/data/Test532.hs +++ /dev/null @@ -1,20 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -parserPrim = - [ r - | r <- - [ SGPPrimFloat $ bool id (0 -) minus $ readGnok - "parserPrim" - (d1 ++ d2 ++ d3 ++ d4) - | d2 <- string "." - , d3 <- many1 (oneOf "0123456789") - , _ <- string "f" - ] - <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "f" - ] - <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral - (readGnok "parserPrim" d1 :: Integer) - | _ <- string "i" - ] - ] diff --git a/data/Test533.hs b/data/Test533.hs deleted file mode 100644 index 3f54efe..0000000 --- a/data/Test533.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -samples = (SV.unpackaaaaadat) <&> \f -> - aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa diff --git a/data/Test534.hs b/data/Test534.hs deleted file mode 100644 index 33c5182..0000000 --- a/data/Test534.hs +++ /dev/null @@ -1,11 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -runBrittany tabSize text = do - let - config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') - { _lconfig_indentAmount = coerce tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } - parsePrintModule config text diff --git a/data/Test535.hs b/data/Test535.hs deleted file mode 100644 index cb2da37..0000000 --- a/data/Test535.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE TypeApplications #-} -foo = bar @Baz diff --git a/data/Test536.hs b/data/Test536.hs deleted file mode 100644 index 8674ebf..0000000 --- a/data/Test536.hs +++ /dev/null @@ -1,51 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE TypeApplications #-} -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do - docAlt - $ -- one-line solution - [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart - ] - ] - | not hasComments - , [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , wherePart <- case mWhereDocs of - Nothing -> return @[] $ docEmpty - Just [w] -> return @[] $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> [] - ] - ++ -- one-line solution + where in next line(s) - [ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] - ] - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - , Data.Maybe.isJust mWhereDocs - ] - ++ -- two-line solution + where in next line(s) - [ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - | [(guards, body, _bodyRaw)] <- [clauseDocs] - , let guardPart = singleLineGuardsDoc guards - ] diff --git a/data/Test537.hs b/data/Test537.hs deleted file mode 100644 index 12526a2..0000000 --- a/data/Test537.hs +++ /dev/null @@ -1,11 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE MultiWayIf #-} -func = do - let - foo = if - | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO - -> max - (defLen - 0.2) -- TODO - (defLen * 0.8) - | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO - return True diff --git a/data/Test538.hs b/data/Test538.hs deleted file mode 100644 index a527909..0000000 --- a/data/Test538.hs +++ /dev/null @@ -1,6 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -foo n = case n of - 1 -> True - -1 -> False -bar n = case n of - (-2, -2) -> (-2, -2) diff --git a/data/Test539.hs b/data/Test539.hs deleted file mode 100644 index 7da39e1..0000000 --- a/data/Test539.hs +++ /dev/null @@ -1,7 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -{-# LANGUAGE TypeApplications #-} -foo = - let - a = b @1 - cccc = () - in foo diff --git a/data/Test54.hs b/data/Test54.hs deleted file mode 100644 index 7d2cb1b..0000000 --- a/data/Test54.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor - { a :: a - , b :: b - } diff --git a/data/Test540.hs b/data/Test540.hs deleted file mode 100644 index 936c1cd..0000000 --- a/data/Test540.hs +++ /dev/null @@ -1,14 +0,0 @@ --- brittany { lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }, lconfig_indentPolicy: IndentPolicyLeft } -record :: Record -record = Record - { rProperties = - [ "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - , "foo" .= "bar" - ] - } diff --git a/data/Test55.hs b/data/Test55.hs deleted file mode 100644 index e49c0da..0000000 --- a/data/Test55.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -data MyStruct - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor (ToBriDocM BriDocNumbered) - (ToBriDocM BriDocNumbered) - (ToBriDocM BriDocNumbered) diff --git a/data/Test56.hs b/data/Test56.hs deleted file mode 100644 index 941107b..0000000 --- a/data/Test56.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -data MyRecord - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor - { foo, foo2 - :: loooooooooooooooooooooooooooooooong - -> loooooooooooooooooooooooooooooooong - , bar :: a - , bazz :: b - } - deriving Show diff --git a/data/Test57.hs b/data/Test57.hs deleted file mode 100644 index 6bcfc1b..0000000 --- a/data/Test57.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test58.hs b/data/Test58.hs deleted file mode 100644 index 6b228a2..0000000 --- a/data/Test58.hs +++ /dev/null @@ -1,12 +0,0 @@ -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving Show - deriving (Eq, Ord) - deriving stock Show - deriving stock (Eq, Ord) - deriving anyclass Show - deriving anyclass (Show, Eq, Monad, Functor) - deriving newtype Show - deriving newtype (Traversable, Foldable) diff --git a/data/Test59.hs b/data/Test59.hs deleted file mode 100644 index 5721ef0..0000000 --- a/data/Test59.hs +++ /dev/null @@ -1,6 +0,0 @@ -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - deriving ToJSON via (SomeType) - deriving (ToJSON, FromJSON) via (SomeType) diff --git a/data/Test6.hs b/data/Test6.hs deleted file mode 100644 index 9bf7bb6..0000000 --- a/data/Test6.hs +++ /dev/null @@ -1 +0,0 @@ -func :: a -> (a -> a) diff --git a/data/Test60.hs b/data/Test60.hs deleted file mode 100644 index 79ccc7a..0000000 --- a/data/Test60.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -data Foo = forall a . Show a => Bar - { foo :: a - } diff --git a/data/Test61.hs b/data/Test61.hs deleted file mode 100644 index 81d41bf..0000000 --- a/data/Test61.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -data Foo = forall a b . (Show a, Eq b) => Bar - { foo :: a - , bars :: b - } diff --git a/data/Test62.hs b/data/Test62.hs deleted file mode 100644 index 8762559..0000000 --- a/data/Test62.hs +++ /dev/null @@ -1,3 +0,0 @@ --- before -data MyData = MyData Int --- after diff --git a/data/Test63.hs b/data/Test63.hs deleted file mode 100644 index 5532f33..0000000 --- a/data/Test63.hs +++ /dev/null @@ -1,5 +0,0 @@ -data MyRecord = MyRecord - { a :: Int - -- comment - , b :: Int - } diff --git a/data/Test64.hs b/data/Test64.hs deleted file mode 100644 index 0d37152..0000000 --- a/data/Test64.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Foo = Bar -- a - { foo :: Baz -- b - , bars :: Bizzz -- c - } -- d - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e diff --git a/data/Test65.hs b/data/Test65.hs deleted file mode 100644 index dd2506f..0000000 --- a/data/Test65.hs +++ /dev/null @@ -1,9 +0,0 @@ -data Foo = Bar - { -- a - foo -- b - :: -- c - Baz -- d - , -- e - bars :: Bizzz - } - deriving (Show, Eq, Monad, Functor, Traversable, Foldable) diff --git a/data/Test66.hs b/data/Test66.hs deleted file mode 100644 index 3c7aeaa..0000000 --- a/data/Test66.hs +++ /dev/null @@ -1,11 +0,0 @@ -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -- a - deriving --b - ( -- c - ToJSON -- d - , -- e - FromJSON --f - ) -- g diff --git a/data/Test67.hs b/data/Test67.hs deleted file mode 100644 index a3a915b..0000000 --- a/data/Test67.hs +++ /dev/null @@ -1,13 +0,0 @@ -data Foo = Bar - { foo :: Baz - , bars :: Bizzz - } - -- a - deriving --a - ToJSON --b - via -- c - ( -- d - SomeType --e - , -- f - ABC --g - ) diff --git a/data/Test68.hs b/data/Test68.hs deleted file mode 100644 index 0375bbb..0000000 --- a/data/Test68.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -data MyRecord - -- test comment - = forall a b - . ( Loooooooooooooooooooooooooooooooong a - , Loooooooooooooooooooooooooooooooong b - ) => - MyConstructor a b diff --git a/data/Test69.hs b/data/Test69.hs deleted file mode 100644 index a1759f1..0000000 --- a/data/Test69.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany {lconfig_indentPolicy: IndentPolicyLeft } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] diff --git a/data/Test7.hs b/data/Test7.hs deleted file mode 100644 index 6fd2b47..0000000 --- a/data/Test7.hs +++ /dev/null @@ -1,2 +0,0 @@ -func :: (((((((((()))))))))) --- current output is.. funny. wonder if that can/needs to be improved.. diff --git a/data/Test70.hs b/data/Test70.hs deleted file mode 100644 index a2147f6..0000000 --- a/data/Test70.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany {lconfig_indentPolicy: IndentPolicyFree } -data GrantsForCompanyResp = GrantsForCompanyResp Types.Company - [EnterpriseGrantResponse] diff --git a/data/Test71.hs b/data/Test71.hs deleted file mode 100644 index 5de2318..0000000 --- a/data/Test71.hs +++ /dev/null @@ -1,4 +0,0 @@ --- brittany {lconfig_indentPolicy: IndentPolicyFree } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] diff --git a/data/Test72.hs b/data/Test72.hs deleted file mode 100644 index af66351..0000000 --- a/data/Test72.hs +++ /dev/null @@ -1,3 +0,0 @@ --- brittany {lconfig_indentPolicy: IndentPolicyMultiple } -data GrantsForCompanyResp = GrantsForCompanyResp Types.Company - [EnterpriseGrantResponse] diff --git a/data/Test73.hs b/data/Test73.hs deleted file mode 100644 index 260d671..0000000 --- a/data/Test73.hs +++ /dev/null @@ -1,22 +0,0 @@ -data XIILqcacwiuNiu = XIILqcacwiuNiu - { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo - , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] - , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo - , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo - , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int - , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq - , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq - , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo - , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn - , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo - , opjUxtkxzkiKse_luqjuZazt - :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] - -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () - , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo - , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn - , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn - , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn - , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn - , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep - , jeyOcuesexaYoy_vpqn :: Jgtoyuh () - } diff --git a/data/Test74.hs b/data/Test74.hs deleted file mode 100644 index e9e6d4f..0000000 --- a/data/Test74.hs +++ /dev/null @@ -1 +0,0 @@ -func x = x diff --git a/data/Test75.hs b/data/Test75.hs deleted file mode 100644 index 2e7361d..0000000 --- a/data/Test75.hs +++ /dev/null @@ -1 +0,0 @@ -x *** y = x diff --git a/data/Test76.hs b/data/Test76.hs deleted file mode 100644 index 877399e..0000000 --- a/data/Test76.hs +++ /dev/null @@ -1 +0,0 @@ -(***) x y = x diff --git a/data/Test77.hs b/data/Test77.hs deleted file mode 100644 index b0795a1..0000000 --- a/data/Test77.hs +++ /dev/null @@ -1 +0,0 @@ -(f >=> g) k = f k >>= g diff --git a/data/Test78.hs b/data/Test78.hs deleted file mode 100644 index 1f3d4e7..0000000 --- a/data/Test78.hs +++ /dev/null @@ -1,4 +0,0 @@ -(Left a <$$> Left dd) e f = True -(Left a <$$> Right d ) e f = True -(Right a <$$> Left d ) e f = False -(Right a <$$> Right dd) e f = True diff --git a/data/Test79.hs b/data/Test79.hs deleted file mode 100644 index bc6cbe5..0000000 --- a/data/Test79.hs +++ /dev/null @@ -1 +0,0 @@ -func _ = x diff --git a/data/Test8.hs b/data/Test8.hs deleted file mode 100644 index 9b1b57b..0000000 --- a/data/Test8.hs +++ /dev/null @@ -1 +0,0 @@ -func :: () diff --git a/data/Test80.hs b/data/Test80.hs deleted file mode 100644 index 5c29c83..0000000 --- a/data/Test80.hs +++ /dev/null @@ -1,2 +0,0 @@ -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable = - x diff --git a/data/Test81.hs b/data/Test81.hs deleted file mode 100644 index 7649b18..0000000 --- a/data/Test81.hs +++ /dev/null @@ -1,2 +0,0 @@ -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable - = x diff --git a/data/Test82.hs b/data/Test82.hs deleted file mode 100644 index dcb58cf..0000000 --- a/data/Test82.hs +++ /dev/null @@ -1,2 +0,0 @@ -func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable a b - = x diff --git a/data/Test83.hs b/data/Test83.hs deleted file mode 100644 index 2e709c1..0000000 --- a/data/Test83.hs +++ /dev/null @@ -1 +0,0 @@ -func (A a) = a diff --git a/data/Test84.hs b/data/Test84.hs deleted file mode 100644 index 58f9aca..0000000 --- a/data/Test84.hs +++ /dev/null @@ -1 +0,0 @@ -func (x : xr) = x diff --git a/data/Test85.hs b/data/Test85.hs deleted file mode 100644 index f097653..0000000 --- a/data/Test85.hs +++ /dev/null @@ -1 +0,0 @@ -func (x :+: xr) = x diff --git a/data/Test86.hs b/data/Test86.hs deleted file mode 100644 index f5eccc0..0000000 --- a/data/Test86.hs +++ /dev/null @@ -1 +0,0 @@ -func (x `Foo` xr) = x diff --git a/data/Test87.hs b/data/Test87.hs deleted file mode 100644 index 5a64709..0000000 --- a/data/Test87.hs +++ /dev/null @@ -1 +0,0 @@ -func | True = x diff --git a/data/Test88.hs b/data/Test88.hs deleted file mode 100644 index ca71136..0000000 --- a/data/Test88.hs +++ /dev/null @@ -1,2 +0,0 @@ -func x | x = simple expression - | otherwise = 0 diff --git a/data/Test89.hs b/data/Test89.hs deleted file mode 100644 index c18a534..0000000 --- a/data/Test89.hs +++ /dev/null @@ -1,3 +0,0 @@ -func x - | a somewhat longer guard x = "and a somewhat longer expession that does not" - | otherwise = "fit without putting the guards in new lines" diff --git a/data/Test9.hs b/data/Test9.hs deleted file mode 100644 index 1b64914..0000000 --- a/data/Test9.hs +++ /dev/null @@ -1,5 +0,0 @@ -func - :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd - -> lakjsdlkjasldkj - -> lakjsdlkjasldkj - ) diff --git a/data/Test90.hs b/data/Test90.hs deleted file mode 100644 index 6f9ef8f..0000000 --- a/data/Test90.hs +++ /dev/null @@ -1,7 +0,0 @@ -func x - | very long guard, another rather long guard that refers to x = nontrivial - expression - foo - bar - alsdkjlasdjlasj - | otherwise = 0 diff --git a/data/Test91.hs b/data/Test91.hs deleted file mode 100644 index 9256c3f..0000000 --- a/data/Test91.hs +++ /dev/null @@ -1,5 +0,0 @@ -func x - | very long guard, another rather long guard that refers to x - = nontrivialexpression foo bar alsdkjlasdjlasj - | otherwise - = 0 diff --git a/data/Test92.hs b/data/Test92.hs deleted file mode 100644 index 289aa8b..0000000 --- a/data/Test92.hs +++ /dev/null @@ -1,6 +0,0 @@ -func x - | very loooooooooooooooooooooooooooooong guard - , another rather long guard that refers to x - = nontrivial expression foo bar alsdkjlasdjlasj - | otherwise - = 0 diff --git a/data/Test93.hs b/data/Test93.hs deleted file mode 100644 index 48053a4..0000000 --- a/data/Test93.hs +++ /dev/null @@ -1,2 +0,0 @@ -func = x -describe "infix op" $ do diff --git a/data/Test94.hs b/data/Test94.hs deleted file mode 100644 index aa1fd8f..0000000 --- a/data/Test94.hs +++ /dev/null @@ -1 +0,0 @@ -func = x + x diff --git a/data/Test95.hs b/data/Test95.hs deleted file mode 100644 index 2d99eaf..0000000 --- a/data/Test95.hs +++ /dev/null @@ -1,3 +0,0 @@ -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test96.hs b/data/Test96.hs deleted file mode 100644 index d9a2015..0000000 --- a/data/Test96.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = - mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj diff --git a/data/Test97.hs b/data/Test97.hs deleted file mode 100644 index 094383e..0000000 --- a/data/Test97.hs +++ /dev/null @@ -1,4 +0,0 @@ -func = - mweroiuxlskdfjlksj - + mweroiuxlskdfjlksj - + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj diff --git a/data/Test98.hs b/data/Test98.hs deleted file mode 100644 index cc29546..0000000 --- a/data/Test98.hs +++ /dev/null @@ -1,5 +0,0 @@ -func = 1 -func = "abc" -func = 1.1e5 -func = 'x' -func = 981409823458910394810928414192837123987123987123 diff --git a/data/Test99.hs b/data/Test99.hs deleted file mode 100644 index efcec60..0000000 --- a/data/Test99.hs +++ /dev/null @@ -1,2 +0,0 @@ -func = \x -> abc -describe "app" $ do diff --git a/data/brittany.yaml b/data/brittany.yaml deleted file mode 100644 index b9b9aab..0000000 --- a/data/brittany.yaml +++ /dev/null @@ -1,4 +0,0 @@ -conf_layout: - lconfig_allowSingleLineExportList: true - lconfig_importAsColumn: 60 - lconfig_importColumn: 60 diff --git a/doc-svg-gen/doc-svg-gen.cabal b/doc-svg-gen/doc-svg-gen.cabal index aff5aa4..cb093c9 100644 --- a/doc-svg-gen/doc-svg-gen.cabal +++ b/doc-svg-gen/doc-svg-gen.cabal @@ -1,15 +1,16 @@ name: doc-svg-gen version: 0.1.0.0 build-type: Simple +extra-source-files: ChangeLog.md cabal-version: >=1.10 executable doc-svg-gen - buildable: False + buildable: True main-is: Main.hs -- other-modules: -- other-extensions: build-depends: - { base >=4.9 && <4.11 + { base >=4.9 && <4.10 , text , graphviz >=2999.19.0.0 } diff --git a/doc/hcar/Brittany.tex b/doc/hcar/Brittany.tex index f181b2f..5c6760d 100644 --- a/doc/hcar/Brittany.tex +++ b/doc/hcar/Brittany.tex @@ -1,6 +1,6 @@ -% Brittany-LB.tex -\begin{hcarentry}[updated]{Brittany} -\report{Lennart Spitzner}%11/17 +% Brittany-LE.tex +\begin{hcarentry}[new]{Brittany} +\report{Lennart Spitzner}%11/16 \status{work in progress} \makeheader @@ -11,35 +11,44 @@ haskell-src-exts such as hindent or haskell-formatter. The goals of the project are to: \begin{compactitem} -\item support the full ghc-haskell syntax including syntactic extensions; -\item retain newlines and comments unmodified (to the degree possible when - code around them gets reformatted); -\item be clever about using horizontal space while not overflowing it if it - cannot be avoided; -\item have linear complexity in the size of the input text / the number of +\item + support the full ghc-haskell syntax including syntactic extensions; +\item + retain newlines and comments unmodified (to the degree possible when code + around them gets reformatted); +\item + be clever about using horizontal space while not overflowing it if it cannot + be avoided; +\item + have linear complexity in the size of the input text / the number of syntactic nodes in the input. -\item support horizontal alignments (e.g. different equations/pattern matches - in the some function's definition). +\item + support horizontal alignments (e.g. different equations/pattern matches in + the some function's definition). \end{compactitem} -In contrast to other formatters brittany internally works in two steps: -Firstly transforming the syntax tree into a document tree representation, -similar to the document representation in general-purpose pretty-printers such -as the \emph{pretty} package, but much more specialized for the specific -purpose of handling a Haskell source code document. Secondly this document -representation is transformed into the output text document. This approach -allows to handle many different syntactic constructs in a uniform way, making -it possible to attain the above goals with a manageable amount of work. +In contrast to other formatters brittany internally works in two steps: Firstly +transforming the syntax tree into a document tree representation, similar to +the document representation in general-purpose pretty-printers such as the +\emph{pretty} package, but much more specialized for the specific purpose of +handling a Haskell source code document. Secondly this document representation +is transformed into the output text document. This approach allows to handle +many different syntactic constructs in a uniform way, making it possible +to attain the above goals with a manageable amount of work. Brittany is work in progress; currently only type signatures and function bindings are transformed, and not all syntactic constructs are supported. -Nonetheless Brittany is safe to try/use as there are checks in place to ensure -that the output is syntactically valid. +Nonetheless Brittany is safe to try/use as there are checks in place to +ensure that the output is syntactically valid. -Brittany requires ghc-8.*, and is available on Hackage and on Stackage. +Brittany requires ghc-8, and is not released on hackage yet; for a description +of how to build it see the repository README. \FurtherReading +{\small \begin{compactitem} - \item \url{https://github.com/lspitzner/brittany} + \item + \url{https://github.com/lspitzner/brittany} \end{compactitem} +} \end{hcarentry} diff --git a/doc/implementation/exactprinting.md b/doc/implementation/exactprinting.md deleted file mode 100644 index 3f99acc..0000000 --- a/doc/implementation/exactprinting.md +++ /dev/null @@ -1,412 +0,0 @@ -# Exactprinting - -Brittany uses the `ghc-exactprint` library/wrapper around the GHC API to -parse haskell source code into a syntax tree and into "annotations". The -unannotated syntax tree would lose information, such as the exact (relative) -position in the source text, or any comments; this is what annotations provide. - -Following that name, we'll call "exactprinting" the aspect of reproducing -comments and relative positions - most importantly additional newlines - while -round-tripping through brittany. The focus is not on the API of the -`ghc-exactprint` library, but on the corresponding data-flow through brittany. - -**Take note that the `--dump-bridoc-*` output filters out the constructors -responsible for comments and for applying DeltaPositions.** -This is done to keep the output more readable, but could confuse you if you -try to understand how comments work. - -## TLDR - Practical Suggestions for Implementing Layouters - -This advice does not explain how comments work, but if you are implementing -a layouter it might cover most cases without requiring you to understand the -details. - -- Ideally, we should wrap the `BriDoc` of any construct that as a location - (i.e. has the form `(L _ something)`) (and consequently has an `AnnKey`) - using `docWrapNode`. As an example, look at the `layoutExpr` function and - how it applies `docWrapNode lexpr $ ..` right at the top. - -- If we have not done the above, it is somewhat likely that comments - "get eaten". For such cases: - - 1. Take a small reproduction case - - 1. Throw it at `brittany --dump-ast-full` and see where the comment is - in the syntax tree. See where the corresponding syntax node is - consumed/transformed by brittany and wrap it with `docWrapNode`. - - 1. If it is unclear what alternative (of a `docAlt` or - `runFilteredAlternative`) applies, try inserting `docDebug "myLabel"` - nodes to track down which alternative applies. - -- For comments that _do_ appear in the output but at the wrong location, there - are two classes of problems: Firstly we have comments that move "down" past - other stuff (even switching order of comments is possible). Use the steps - from the last item to figure out which syntax tree constructor is relevant, - and try inserting `docMoveToKWDP` or replace `docWrapNode` with a manually - refined combination of `docWrapNodePrior` and `docWrapNodeRest`. - -- For comments that _do_ appear in the output in roughly the right position, - only with the wrong indentation, the cause most likely is a - mis-interpretation of DPs that can be fixed by inserting a - `docSetIndentLevel` at the right position - right before printing the - thing that provides the "layouting rule" indentation, i.e. the body of a - `do`/`let`/`where` block. - -- There is one other cause for off-by-one errors in comment position: - Whitespace. In general, layouters should prefer to use `docSeparator` to - insert space between syntax elements rather than including spaces in - literal strings. As an example, use `docSeq [docLit "then", docSeparator]` - or the equivalent `appSep (docLit "then")` rather than `docLit "then "`. - The reason is that comment positions are relative to the last non-whitespace, - and `docSeparator` is interpreted in just the right fashion: It inserts - a whitespace, but keeps track of the correct comment offset. (Also, - subsequent `docSeparators` are merged into one.) - -- If all of this fails, read below, bother the maintainers and/or make use of - the more advanced debugging features (there is a `#define` in - `BackendUtils.hs` that you can turn on to insert all kinds of verbose - output in-line with the actual output). - -## A Small Example - -~~~~.hs -main = do - putStr "hello" -- very suspense - putStrLn " world" --nice -~~~~ - -If you pass this to `brittany --dump-ast-full` you'll see .. a 100 line syntax -tree. Yeah, raw syntax tree are a bit unwieldly. - -(btw I'd use `clipread | brittany --dump-ast-full` for that purpose, where -`clipread` boils down to `xclip -o -selection clipboard`. If you have not set -up that script on your system, you really should.) - -To simplify this slightly, we will focus down on just the syntax tree of -the `do` block, which is the `HsDo` constructor. - -~~~~ ----- ast ---- -A Just (Ann (DP (0,0)) [] [] [((AnnComment (Comment "--nice" stdin:3:21-26 Nothing)),DP (0,1)),((G AnnEofPos),DP (1,0))] Nothing Nothing) - HsModule - .. - [ A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) - ValD - FunBind - A Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) - Unqual {OccName: main} - MG - A Nothing - [ A Just (Ann (DP (0,0)) [] [] [((G AnnEqual),DP (0,1))] Nothing Nothing) - Match - FunRhs - ..main.. - Prefix - NoSrcStrict - [] - GRHSs - [ A Just (Ann (DP (0,-1)) [] [] [] Nothing Nothing) - GRHS - [] - A Just (Ann (DP (0,1)) [] [] [((G AnnDo),DP (0,0))] Nothing Nothing) - HsDo - DoExpr - A Nothing - [ A Just (Ann (DP (1,2)) [] [] [] Nothing Nothing) - BodyStmt - A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) - HsApp - ..putStr.. - .."hello".. - .. - .. - , A Just (Ann (DP (1,0)) [((Comment "-- very suspense" stdin:2:18-33 Nothing),DP (0,1))] [] [] Nothing Nothing) - BodyStmt - A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) - HsApp - ..putStrLn.. - .." world".. - .. - .. - ] - ] - A (Nothing) (EmptyLocalBinds) - ] - FromSource - WpHole - [] - ] - .. -~~~~ - -So this is a haskell module, `HsModule` containing a function bind `FunBind` -containing a match group, containing a Match, containing some right-hand-side -expression which in this case is just a do block `HsDo` which contains two -applications `HsApp` of a function `putStr(Ln)` plus some string literal. - -There is no need to understand this, as long as you can roughly see how this -representation corresponds to the input source code. - -For the purpose of exactprinting, what we need to look at are the annotations. -The `ghc-exactprint` library returns the syntax tree and annotations as two -different entities: -- [You can start looking at the module level](https://downloads.haskell.org/ghc/latest/docs/html/libraries/ghc-8.8.1/HsSyn.html#v:HsModule) -and work your way down to any syntactical construct from there; -- The [Annotation type and its `Ann` constructor](https://hackage.haskell.org/package/ghc-exactprint-0.6.2/docs/Language-Haskell-GHC-ExactPrint-Types.html#t:Annotation). - -In the above `--dump-ast-full` output these two are mixed together using the -fake `A` constructor that is just a pair of a `Maybe Annotation` and of one -node in the syntax tree. It was produced by recursively printing the syntax -tree, and for each node `n` we print `A (getAnnotation n) n`. So let's focus -on the `Annotation` type. - -## The `ghc-exactprint` Annotation Type - -~~~~.hs -Ann - { annEntryDelta :: !DeltaPos - , annPriorComments :: ![(Comment, DeltaPos)] - , annFollowingComments :: ![(Comment, DeltaPos)] - , annsDP :: ![(KeywordId, DeltaPos)] - , annSortKey :: !(Maybe [SrcSpan]) - , annCapturedSpan :: !(Maybe AnnKey) - } -~~~~ - -But please refer to [the ghc-exactprint docs](https://hackage.haskell.org/package/ghc-exactprint-0.6.2/docs/Language-Haskell-GHC-ExactPrint-Types.html#t:Annotation) for the fully commented version. - -A few things to point out: - -- There are _three_ constructors that contain the `Comment` type in that - constructor. `annPriorComments` and `annFollowingComments` are obvious, but - a third hides behind the `KeywordId` type. Source code comments may appear - in one of these three locations. -- The `DeltaPos` type and its `DP` constructor can be seen in the above output - everywhere. It contains information about relative positioning of both - comments and syntax nodes. Please test what changes if you insert a newline - before `putStrLn`, or add spaces before one of the comments, and see how the - `--dump-ast-full` output changes. -- The exact semantics of the `DP` value, especially when it comes to - indentation, are a source of constant joy. If the values don't make sense, - you are on the right track. Just figure out what DP is connected to what - change in the syntax tree for now. -- We have two comments in the source code, which appear in opposite order - in the `--dump-ast-full` output. The reason is that comments mostly appear - in the middle of two AST nodes, and it is somewhat arbitary whether we - connected them as an "after" comment of the first or as an "before" comment - of the second node. And keep in mind that we have a third constructor that - can contain comments that are somewhere in the "middle" of a node, too. -- We have `DP`s with negative offsets. Did I mention how much fun `DP`s are? - I have no idea where the above `-1` comes from. -- The `annsDP` field may also contain the `DP`s of syntax that is somewhere - "in the middle" of a syntax node, e.g. the position of the `else` keyword. - - We will discuss the semantics of `DP` further down below. - -## Data-Flow of a Comment When Round-Tripping - -Parsing with `ghc-exactprint` returns both a syntax tree and a map of -annotations (`Map AnnKey Annotation`). Let's consider just the comment -"-- very suspense" in the above example: The annotations map would contain -the following mapping: - -~~~~ -AnnKey {stdin:3:3-19} (CN "BodyStmt") - -> Ann { annEntryDelta = DP (1,0) - , annPriorComments = - [((Comment "-- very suspense" stdin:2:18-33 Nothing),DP (0,1))] - , annFollowingComments = [] - , annsDB = [] - , annSortKey = Nothing - , annCapturedSpan = Nothing - } -~~~~ - -where the `AnnKey` is connected to the syntax node `BodyStmt` with the given -source location. - -Brittany keeps the annotations map around, and the `BriDoc` structure contains -nodes that have `AnnKey` values, i.e. the `BriDoc` nested documented structure -similarly only contains references into the annotations map. The corresponding -constructors of the `BriDoc(F)` type are: - -~~~~.hs -data BriDoc - = .. - | BDAnnotationPrior AnnKey BriDoc - | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc - | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset - | .. -~~~~ - -when rendering a `BriDoc` to text, the semantics of the above nodes can be -described roughly like this: -- `render (BDAnnotationPrior annkey bd)` extracts the "before" type comments - under the given `annkey` from the annotations map (this is a stateful - process - they are really removed from the map). It renders these comments. - If we are in a new line, we respect the `annEntryDelta :: DeltaPos` value - to insert newlines. The "if in a new line" check prevents us from inserting - newlines in the case that brittany chose to transform a multi-line layout - into a single-line layout. - - Then we recursively process `render bd`. -- `render (BDAnnotationsKW annkey mkwId bd)` similarly first renders the comments - extracted from the annotations map under the given `annkey` before calling - `render bd`. For example, this would allow us to print the comments _before_ - the closing bracket `]` of an empty list literal e.g. - `[{-put numbers here to do X-}]`. -- `render (BDMoveToKWDP annkey kwId xToo bd` moves to the relative position of - the given keyword before continuing with `render bd`. - It is used for example to insert newlines before a `where` keyword to - match those of the original source code. -- `render (BDAnnotationsRest annkey bd)` first calls `render bd` and _then_ - takes _any remaining comments_ it can find in the annotations map under the - given `annkey` and prints them. - -### Some Notes to This Design - -- We heavily rely on the `ghc-exactprint` library and its types and - their semantics. We could define our own data structures to capture comments - and whitespace offsets. While this could allow us to make the later steps - of the process easier by more closely matching the information we need when - rendering a `BriDoc` document, it would involve a mildly complex - extra transformation step from `ghc-exactprint` annotations to hypothetical - `brittany` annotations. - -- For those cases where we rely on `ghc-exactprint` to output syntax that - `brittany` does not know yet, it is mandatory that we keep the annotations - around. - -- We make the rendering stateful in the annotations. The main advantage to - this is that we can keep track of any comments that have not yet been - reproduced in the output, and as a last resort append them at the end. The - effect of that is that comments "move" down in the document when brittany is - not exact, but at least it does not "eat" comments. The latter can still - happen though if we forget to include a given `AnnKey` at all in the `BriDoc` - document. - - Of course this is a bit yucky, but it seems to be a sensible measure for - the long transitioning period where `brittany` is not perfect. - -- It may be surprising to nest things like we do in the `BriDoc` type. - The intuitive document representation for something like - - ~~~~.hs - -- before - foo - -- after - ~~~~ - - might be - - ~~~~ - sequence [comment "-- before", text "foo", comment "-- after"] - ~~~~ - - but instead we use - - ~~~~ - BDAnnotationsPrior annkey1 -- yields "-- before" - BDAnnotationsRest annkey1 -- yields "-- after" - BDLit "foo" - ~~~~ - - which may seem unnecessarily nested. But this representation has certain - advantages, most importantly rewriting/restructuring the tree is - straigh-forward: consider how `BDAnnotationsPrior annkey (BDSeq [a, b])` can - be transformed into `BDSeq [BDAnnotationsPrior annkey a, b]`. You can do the - same transformation using the "flat" representation, but there are way more - cases to consider. - -## DeltaPosition semantics - -DeltaPositions (we'll just say `DP` which matches the constructor name for this -type) are used to specify where to place comments and regular syntax (including -keywords). This covers both newlines and indentation, and for indentation -includes the case where indentation is mandatory ("layouting rule"). - -Let us look at this example, which was constructed so that each comment -contains its own DP: - -~~~~.hs -do -- DP (0, 1) - - -- DP (2, 2) two newlines, two spaces indentation - abc - -- DB (1, 0) one newline, zero indentation relative to the do-indentation - def -~~~~ - -The first comment is of the easy sort, because it occurs at the end of a -non-empty line: There is no row offset, and the column offset matches the -number of spaces (before the "--") after the last thing in the line. - -The second comment _does_ have a row offset: After the last comment, we have -to insert two line-breaks, then apply the indentation (two spaces) and then -insert the comment starting with "--". This is straight-forward so far. - -The third comment however highlights how DPs are affected by the layouting -rule. - -### Caveat One: Indentation relative to layouting rule indentation level - -Following the first two cases, one would assume that the DP would be -`(1, 2)`. However, for cases where the layouting rule applies -(`do`, `let`, `where`) the indentation of the comments is expressed relative -to the _current indentation_ according to the layouting rule. Unfortunately, -this _current indentation_ is not known until the first construct after -the let, so in the above example, the comment between the `do` and the first -construct (`abc`) has an indentation relative to the enclosing indentation -level (which is 0 for this example). This applies _even_ if the comment is -connected to the first construct (if the first comment is a "prior" comment -of the "abc" syntax node). - -This applies not only to comments, but also to the DPs of all syntax nodes -(including keywords). - -This also means that it is possible to have negative indentation. Consider -this comment: - -~~~~.hs -do - abc - -- fancy comment - def -~~~~ - -### Caveat Two: Caveat one applies to more than the layouting rule - -There are syntactic constructs, for example data declarations, where the -layouting rule does not apply, but for the purpose of `DP` indentations -`ghc-exactprint` pretends that it does. For example: - -~~~~.hs -data Foo = Foo - { myInt :: Int - -- DP (1, -7) relative to the `Foo` constructor (!) - } -~~~~ - -The layouting rule does _not apply in any way_ here. Still, we get a rather -unexpected DP. - -### DeltaPositions of keywords and syntax nodes - -We have mostly talked about comments, but DPs exist and work for keywords -and syntax nodes just like they do for comments. - -~~~~.hs -func = x - - where - - x = 42 -~~~~ - -here, the `where` keyword has a DP of `(2, 1)` and the `x = 42` equation -has a DP of `(2, 2)`. We make use of these DPs using the `BDMoveToKWDP` or the -`BDAnnotationPrior` constructors of the `BriDoc` document. The former would be -used for the `where` keyword, the latter would be applied to the equation -document. diff --git a/doc/implementation/index.md b/doc/implementation/index.md index 5e22d2a..f6adfad 100644 --- a/doc/implementation/index.md +++ b/doc/implementation/index.md @@ -18,11 +18,6 @@ Specifying the semantics of the different (smart) constructors of the `BriDoc` type. -- [exactprinting](exactprinting.md) - - A closer look at how we achieve exactprinting, i.e. keeping comments and - certain whitespace (empty lines) as they appear in the input source code. - - Brittany uses the following (randomly deemed noteworthy) libraries: - [`ghc-exactprint`](https://hackage.haskell.org/package/ghc-exactprint) diff --git a/doc/implementation/theory.md b/doc/implementation/theory.md index df88366..f01b1ba 100644 --- a/doc/implementation/theory.md +++ b/doc/implementation/theory.md @@ -1,6 +1,6 @@ # Introduction -[The readme](../../README.md) mentions a couple of goals for this +[The readme](../../master/README.md) mentions a couple of goals for this project, including the following two: - Be clever about using the available horizontal space while not overflowing @@ -18,7 +18,7 @@ will first consider Every haskell module can be written in a single line - of course, in most cases, an unwieldly long one. We humans prefer our lines limitted to some -laughingly small limit like 80 or 160. Further, we generally +laughingly small limit like 80 or 160 or whatever. Further, we generally prefer the indentation of our expressions(, statements etc.) line up with its syntactic structure. This preferences (and the layouting rule which already enforces it partially) still leaves a good amount of choice for @@ -39,9 +39,8 @@ myList = ~~~~ While consistency has the first priority, we also prefer short code: If it -fits, we prefer the version/layout with less lines of code. So coming from the -everything-in-one-line version, we wish to trade more lines to achieve less -columns, but stop immediately when everything fits into 80 columns. +fits, we prefer the version/layout with less lines of code. So we wish to trade +more lines for less columns, but only until things fit. For simple cases we can give a trivial rule: If there is space for the one-line layout, use it; otherwise use the indented-multiline @@ -109,19 +108,15 @@ not help at all in pruning the alternatives on a given layer. In the above `nestedCaseExpr` example, we might obtain a better solution by looking not at just the first, but the first n possible layouts, but against an exponential search-space, this does not scale: Just consider the possibility that there -are exponentially many sub-solutions for layout 2) (replace the literal "good" -in the above example with some slightly more complex expression). -You basically always end up with either +are exponentially many sub-solutions for layout 2) (replace "good" with some +slightly more complex expression). You basically always end up with either "the current line is not yet full, try to fill it up" or "more than n columns used, abort". But a (pure) bottom-up approach does not work either: If we have no clue about the "current" indentation while layouting some node of our syntax tree, information about the (potential) size of (the layout of) child-nodes does -not allow us to make good decisions - if we have a choice between a layout -that takes 40 and a layout that takes 60 columns, we _need_ to know whether -the current indentation is bigger or smaller than 20, otherwise our result -will be non-optimal in general. +not allow us to make good decisions. So we need information to flow bottom-to-top to allow for pruning whole trees of possible layouts, and top-to-bottom for making the actual decisions.. well, @@ -145,11 +140,6 @@ if func x -- => 3 lines, 13 columns used ~~~~ -So internally, to the syntax node of this if-then-else expression we connect -a label containing these two choices, and including the spacing information: -`[(1, 32, someDoc1), (3, 13, someDoc2)]`. where the `someDoc`s are document -representations that can reproduce the above two source code layouts. - This is heavily simplified; in Brittany spacing information is (as usual) a bit more complex. @@ -157,8 +147,7 @@ We restrict the size of these sets. Given the sets of spacings for the child-nodes in the syntax-tree, we generate a limited number of possible spacings in the current node. We then prune nodes that already violate desired properties, e.g. any spacing that already uses more columns locally than -globally available - we would not have something like `(_, 90, _)` in the -above list when our limit is 80 columns. +globally available. The second pass is top-down and uses the spacing-information to decide on one of the possible layouts for the current node. It passes the current diff --git a/doc/showcases/Layout_Types.md b/doc/showcases/Layout_Types.md index abf05e8..d34ca14 100644 --- a/doc/showcases/Layout_Types.md +++ b/doc/showcases/Layout_Types.md @@ -44,7 +44,6 @@ linewise -> RH.AppHost t () ~~~~ -~~~~.hs linewise :: forall n t. (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t)) @@ -55,9 +54,8 @@ linewise :: , R.Behavior t String -- tab-completion value , R.Dynamic t (Widget n))) -> RH.AppHost t () -~~~~ -~~~~.hs + processDefault :: ( ExactPrint.Annotate.Annotate ast , MonadMultiWriter Text.Builder.Builder m @@ -65,4 +63,3 @@ processDefault :: ) => Located ast -> m () -~~~~ diff --git a/doc/showcases/Module.md b/doc/showcases/Module.md deleted file mode 100644 index 31a062f..0000000 --- a/doc/showcases/Module.md +++ /dev/null @@ -1,118 +0,0 @@ - -Last updated for brittany version `0.10.0.0`. - -# Example layouting of the module header (exports/imports) - -## On default settings - -default settings are: - -~~~~ -conf_layout: - lconfig_indentPolicy: IndentPolicyFree - lconfig_importColumn: 50 - lconfig_importAsColumn: 50 -~~~~ - - -~~~~.hs -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} - -module Main - ( main - ) -where - -import qualified Paths_brittany -import Language.Haskell.Brittany - -import Network.Wai -import Network.HTTP.Types -import qualified Network.Wai.Handler.Warp as Warp - -import Data.String - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL - -import Control.Monad.Loops - -import qualified Data.Text.Encoding as Text -import qualified Data.Text as Text - -import Data.Version ( showVersion ) - -import qualified System.Mem -import qualified Control.Concurrent -import Control.Concurrent.Async ( async - , waitEitherCatch - , waitEitherCatchCancel - ) -import qualified Data.Aeson as Aeson -import Data.Time.Clock -import Data.Time.Format -import Text.Parsec hiding ( (<|>) ) -~~~~ - -For long module names, things will be moved one line below and aligned as -before. Long identifiers may overflow our 80 column limit: - -~~~~.hs -import qualified Example.Very.Long.Module.Name.Internal - as T -import Example.Very.Long.Module.Name.Internal - ( someFunc - , MyDataType - , globalConstant - ) -import Example.Very.Long.Module.Name.Internal - ( someVeryLongAndDescriptiveFunctionName - ) -~~~~ - -## Alternative setting - long identifiers - -If you have many long module names or use large identifiers, you might -be interested in these alternative settings: - -~~~~ -conf_layout: - lconfig_importColumn: 21 - lconfig_importAsColumn: 70 -~~~~ - -Now, our previous examples becomes: - -~~~~.hs -import qualified Example.Very.Long.Module.Name.Internal as T -import Example.Very.Long.Module.Name.Internal - ( someFunc - , MyDataType - , globalConstant - ) -import Example.Very.Long.Module.Name.Internal - ( someVeryLongAndDescriptiveFunctionName ) -~~~~ - -## Alternative setting - "IndentPolicyLeft" - -The global switch "indent policy" that has the rough intention of removing any -cases of "hanging indentation" also affects module layouting: - -~~~~ -conf_layout: - lconfig_indentPolicy: IndentPolicyLeft -~~~~ - -Now, our previous examples becomes: - -~~~~.hs -import qualified Example.Very.Long.Module.Name.Internal as T -import Example.Very.Long.Module.Name.Internal - (someFunc, MyDataType, globalConstant) -import Example.Very.Long.Module.Name.Internal - (someVeryLongAndDescriptiveFunctionName) -~~~~ diff --git a/output/.gitignore b/output/.gitignore deleted file mode 100644 index d6b7ef3..0000000 --- a/output/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -* -!.gitignore diff --git a/source/executable/Main.hs b/source/executable/Main.hs deleted file mode 100644 index 7a5ae94..0000000 --- a/source/executable/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -import qualified Language.Haskell.Brittany.Main as BrittanyMain - -main :: IO () -main = BrittanyMain.main diff --git a/source/library/Language/Haskell/Brittany.hs b/source/library/Language/Haskell/Brittany.hs deleted file mode 100644 index a2726c8..0000000 --- a/source/library/Language/Haskell/Brittany.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany - ( parsePrintModule - , staticDefaultConfig - , forwardOptionsSyntaxExtsEnabled - , userConfigPath - , findLocalConfigPath - , readConfigs - , readConfigsWithUserConfig - , Config - , CConfig(..) - , CDebugConfig(..) - , CLayoutConfig(..) - , CErrorHandlingConfig(..) - , CForwardOptions(..) - , CPreProcessorConfig(..) - , BrittanyError(..) - ) where - -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Types diff --git a/source/library/Language/Haskell/Brittany/Internal.hs b/source/library/Language/Haskell/Brittany/Internal.hs deleted file mode 100644 index 06cbb63..0000000 --- a/source/library/Language/Haskell/Brittany/Internal.hs +++ /dev/null @@ -1,684 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal - ( parsePrintModule - , parsePrintModuleTests - , pPrintModule - , pPrintModuleAndCheck - -- re-export from utils: - , parseModule - , parseModuleFromString - , extractCommentConfigs - , getTopLevelDeclNameMap - ) where - -import Control.Monad.Trans.Except -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Char (isSpace) -import Data.HList.HList -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Data.Yaml -import qualified GHC hiding (parseModule) -import GHC (GenLocated(L)) -import qualified GHC.Driver.Session as GHC -import GHC.Hs -import qualified GHC.LanguageExtensions.Type as GHC -import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.SrcLoc (SrcSpan) -import Language.Haskell.Brittany.Internal.Backend -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Transformations.Alt -import Language.Haskell.Brittany.Internal.Transformations.Columns -import Language.Haskell.Brittany.Internal.Transformations.Floating -import Language.Haskell.Brittany.Internal.Transformations.Indent -import Language.Haskell.Brittany.Internal.Transformations.Par -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified UI.Butcher.Monadic as Butcher - - - -data InlineConfigTarget - = InlineConfigTargetModule - | InlineConfigTargetNextDecl -- really only next in module - | InlineConfigTargetNextBinding -- by name - | InlineConfigTargetBinding String - -extractCommentConfigs - :: ExactPrint.Anns - -> TopLevelDeclNameMap - -> Either (String, String) (CConfig Maybe, PerItemConfig) -extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do - let - commentLiness = - [ ( k - , [ x - | (ExactPrint.Comment x _ _, _) <- - (ExactPrint.annPriorComments ann - ++ ExactPrint.annFollowingComments ann - ) - ] - ++ [ x - | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- - ExactPrint.annsDP ann - ] - ) - | (k, ann) <- Map.toList anns - ] - let - configLiness = commentLiness <&> second - (Data.Maybe.mapMaybe $ \line -> do - l1 <- - List.stripPrefix "-- BRITTANY" line - <|> List.stripPrefix "--BRITTANY" line - <|> List.stripPrefix "-- brittany" line - <|> List.stripPrefix "--brittany" line - <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") - let l2 = dropWhile isSpace l1 - guard - (("@" `isPrefixOf` l2) - || ("-disable" `isPrefixOf` l2) - || ("-next" `isPrefixOf` l2) - || ("{" `isPrefixOf` l2) - || ("--" `isPrefixOf` l2) - ) - pure l2 - ) - let - configParser = Butcher.addAlternatives - [ ( "commandline-config" - , \s -> "-" `isPrefixOf` dropWhile (== ' ') s - , cmdlineConfigParser - ) - , ( "yaml-config-document" - , \s -> "{" `isPrefixOf` dropWhile (== ' ') s - , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document") - $ fmap (\lconf -> (mempty { _conf_layout = lconf }, "")) - . either (const Nothing) Just - . Data.Yaml.decodeEither' - . Data.ByteString.Char8.pack - -- TODO: use some proper utf8 encoder instead? - ) - ] - parser = do -- we will (mis?)use butcher here to parse the inline config - -- line. - let - nextDecl = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) - Butcher.addCmd "-next-declaration" nextDecl - Butcher.addCmd "-Next-Declaration" nextDecl - Butcher.addCmd "-NEXT-DECLARATION" nextDecl - let - nextBinding = do - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) - Butcher.addCmd "-next-binding" nextBinding - Butcher.addCmd "-Next-Binding" nextBinding - Butcher.addCmd "-NEXT-BINDING" nextBinding - let - disableNextBinding = do - Butcher.addCmdImpl - ( InlineConfigTargetNextBinding - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-binding" disableNextBinding - Butcher.addCmd "-Disable-Next-Binding" disableNextBinding - Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding - let - disableNextDecl = do - Butcher.addCmdImpl - ( InlineConfigTargetNextDecl - , mempty { _conf_roundtrip_exactprint_only = pure $ pure True } - ) - Butcher.addCmd "-disable-next-declaration" disableNextDecl - Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl - Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl - let - disableFormatting = do - Butcher.addCmdImpl - ( InlineConfigTargetModule - , mempty { _conf_disable_formatting = pure $ pure True } - ) - Butcher.addCmd "-disable" disableFormatting - Butcher.addCmd "@" $ do - -- Butcher.addCmd "module" $ do - -- conf <- configParser - -- Butcher.addCmdImpl (InlineConfigTargetModule, conf) - Butcher.addNullCmd $ do - bindingName <- Butcher.addParamString "BINDING" mempty - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) - conf <- configParser - Butcher.addCmdImpl (InlineConfigTargetModule, conf) - lineConfigss <- configLiness `forM` \(k, ss) -> do - r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of - Left err -> Left $ (err, s) - Right c -> Right $ c - pure (k, r) - - let - perModule = foldl' - (<>) - mempty - [ conf - | (_, lineConfigs) <- lineConfigss - , (InlineConfigTargetModule, conf) <- lineConfigs - ] - let - perBinding = Map.fromListWith - (<>) - [ (n, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs - , n <- case target of - InlineConfigTargetBinding s -> [s] - InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> - [name] - _ -> [] - ] - let - perKey = Map.fromListWith - (<>) - [ (k, conf) - | (k, lineConfigs) <- lineConfigss - , (target, conf) <- lineConfigs - , case target of - InlineConfigTargetNextDecl -> True - InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> - True - _ -> False - ] - - pure - $ ( perModule - , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey } - ) - - -getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap -getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = - TopLevelDeclNameMap $ Map.fromList - [ (ExactPrint.mkAnnKey decl, name) - | decl <- decls - , (name : _) <- [getDeclBindingNames decl] - ] - - --- | Exposes the transformation in an pseudo-pure fashion. The signature --- contains `IO` due to the GHC API not exposing a pure parsing function, but --- there should be no observable effects. --- --- Note that this function ignores/resets all config values regarding --- debugging, i.e. it will never use `trace`/write to stderr. --- --- Note that the ghc parsing function used internally currently is wrapped in --- `mask_`, so cannot be killed easily. If you don't control the input, you --- may wish to put some proper upper bound on the input's size as a timeout --- won't do. -parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) -parsePrintModule configWithDebugs inputText = runExceptT $ do - let - config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - let config_pp = config & _conf_preprocessor - let cppMode = config_pp & _ppconf_CPPMode & confUnpack - let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack - (anns, parsedSource, hasCPP) <- do - let - hackF s = - if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s - let - hackTransform = if hackAroundIncludes - then List.intercalate "\n" . fmap hackF . lines' - else id - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - parseResult <- lift $ parseModuleFromString - ghcOptions - "stdin" - cppCheckFunc - (hackTransform $ Text.unpack inputText) - case parseResult of - Left err -> throwE [ErrorInput err] - Right x -> pure x - (inlineConf, perItemConf) <- - either (throwE . (: []) . uncurry ErrorMacroConfig) pure - $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf - let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack - if disableFormatting - then do - return inputText - else do - (errsWarns, outputTextL) <- do - let - omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource - else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let - hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s - pure $ if hackAroundIncludes - then - ( ews - , TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - ) - else (ews, outRaw) - let - customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let - hasErrors = - if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) - if hasErrors - then throwE $ errsWarns - else pure $ TextL.toStrict outputTextL - - - --- BrittanyErrors can be non-fatal warnings, thus both are returned instead --- of an Either. --- This should be cleaned up once it is clear what kinds of errors really --- can occur. -pPrintModule - :: Config - -> PerItemConfig - -> ExactPrint.Anns - -> GHC.ParsedSource - -> ([BrittanyError], TextL.Text) -pPrintModule conf inlineConf anns parsedModule = - let - ((out, errs), debugStrings) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterW - $ MultiRWSS.withMultiReader anns - $ MultiRWSS.withMultiReader conf - $ MultiRWSS.withMultiReader inlineConf - $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) - $ do - traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations - $ annsDoc anns - ppModule parsedModule - tracer = if Seq.null debugStrings - then id - else - trace ("---- DEBUGMESSAGES ---- ") - . foldr (seq . join trace) id debugStrings - in tracer $ (errs, Text.Builder.toLazyText out) - -- unless () $ do - -- - -- debugStrings `forM_` \s -> - -- trace s $ return () - --- | Additionally checks that the output compiles again, appending an error --- if it does not. -pPrintModuleAndCheck - :: Config - -> PerItemConfig - -> ExactPrint.Anns - -> GHC.ParsedSource - -> IO ([BrittanyError], TextL.Text) -pPrintModuleAndCheck conf inlineConf anns parsedModule = do - let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity - let (errs, output) = pPrintModule conf inlineConf anns parsedModule - parseResult <- parseModuleFromString - ghcOptions - "output" - (\_ -> return $ Right ()) - (TextL.unpack output) - let - errs' = errs ++ case parseResult of - Left{} -> [ErrorOutputCheck] - Right{} -> [] - return (errs', output) - - --- used for testing mostly, currently. --- TODO: use parsePrintModule instead and remove this function. -parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) -parsePrintModuleTests conf filename input = do - let inputStr = Text.unpack input - parseResult <- parseModuleFromString - (conf & _conf_forward & _options_ghc & runIdentity) - filename - (const . pure $ Right ()) - inputStr - case parseResult of - Left err -> return $ Left err - Right (anns, parsedModule, _) -> runExceptT $ do - (inlineConf, perItemConf) <- - case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of - Left err -> throwE $ "error in inline config: " ++ show err - Right x -> pure x - let moduleConf = cZipWith fromOptionIdentity conf inlineConf - let - omitCheck = - conf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (errs, ltext) <- if omitCheck - then return $ pPrintModule moduleConf perItemConf anns parsedModule - else lift - $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule - if null errs - then pure $ TextL.toStrict $ ltext - else - let - errStrs = errs <&> \case - ErrorInput str -> str - ErrorUnusedComment str -> str - LayoutWarning str -> str - ErrorUnknownNode str _ -> str - ErrorMacroConfig str _ -> "when parsing inline config: " ++ str - ErrorOutputCheck -> "Output is not syntactically valid." - in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs - --- this approach would for if there was a pure GHC.parseDynamicFilePragma. --- Unfortunately that does not exist yet, so we cannot provide a nominally --- pure interface. - --- parsePrintModuleTests :: Text -> Either String Text --- parsePrintModuleTests input = do --- let dflags = GHC.unsafeGlobalDynFlags --- let fakeFileName = "SomeTestFakeFileName.hs" --- let pragmaInfo = GHC.getOptions --- dflags --- (GHC.stringToStringBuffer $ Text.unpack input) --- fakeFileName --- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo --- let parseResult = ExactPrint.Parsers.parseWith --- dflags1 --- fakeFileName --- GHC.parseModule --- inputStr --- case parseResult of --- Left (_, s) -> Left $ "parsing error: " ++ s --- Right (anns, parsedModule) -> do --- let (out, errs) = runIdentity --- $ runMultiRWSTNil --- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW --- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW --- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns --- $ ppModule parsedModule --- if (not $ null errs) --- then do --- let errStrs = errs <&> \case --- ErrorUnusedComment str -> str --- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs --- else return $ TextL.toStrict $ Text.Builder.toLazyText out - -toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a -toLocal conf anns m = do - (x, write) <- - lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m - MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write) - pure x - -ppModule :: GenLocated SrcSpan HsModule -> PPM () -ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do - defaultAnns <- do - anns <- mAsk - let annKey = ExactPrint.mkAnnKey lmod - let annMap = Map.findWithDefault Map.empty annKey anns - let isEof = (== ExactPrint.AnnEofPos) - let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a } - pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap - - post <- ppPreamble lmod - decls `forM_` \decl -> do - let declAnnKey = ExactPrint.mkAnnKey decl - let declBindingNames = getDeclBindingNames decl - inlineConf <- mAsk - let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf - let - mBindingConfs = - declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf - filteredAnns <- mAsk <&> \annMap -> - Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap - - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns - - config <- mAsk - - let - config' = cZipWith fromOptionIdentity config - $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) - - let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack - toLocal config' filteredAnns $ do - bd <- if exactprintOnly - then briDocMToPPM $ briDocByExactNoComment decl - else do - (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl - mTell debugs - mTell errs - if null errs - then pure r - else briDocMToPPM $ briDocByExactNoComment decl - layoutBriDoc bd - - let - finalComments = filter - (fst .> \case - ExactPrint.AnnComment{} -> True - _ -> False - ) - post - post `forM_` \case - (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do - ppmMoveToExactLoc l - mTell $ Text.Builder.fromString cmStr - (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> - let - folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of - ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm -> - ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span - ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments - in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) - _ -> return () - -getDeclBindingNames :: LHsDecl GhcPs -> [String] -getDeclBindingNames (L _ decl) = case decl of - SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) - ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] - _ -> [] - - --- Prints the information associated with the module annotation --- This includes the imports -ppPreamble - :: GenLocated SrcSpan HsModule - -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L loc m@HsModule{}) = do - filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap - -- Since ghc-exactprint adds annotations following (implicit) - -- modules to both HsModule and the elements in the module - -- this can cause duplication of comments. So strip - -- attached annotations that come after the module's where - -- from the module node - config <- mAsk - let - shouldReformatPreamble = - config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - - let - (filteredAnns', post) = - case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of - Nothing -> (filteredAnns, []) - Just mAnn -> - let - modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post') = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.annsDP = pre } - filteredAnns'' = - Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in (filteredAnns'', post') - traceIfDumpConf - "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns' - - if shouldReformatPreamble - then toLocal config filteredAnns' $ withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc - else - let emptyModule = L loc m { hsmodDecls = [] } - in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule - return post - -_sigHead :: Sig GhcPs -> String -_sigHead = \case - TypeSig _ names _ -> - "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) - _ -> "unknown sig" - -_bindHead :: HsBind GhcPs -> String -_bindHead = \case - FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) - PatBind _ _pat _ ([], []) -> "PatBind smth" - _ -> "unknown bind" - - - -layoutBriDoc :: BriDocNumbered -> PPMLocal () -layoutBriDoc briDoc = do - -- first step: transform the briDoc. - briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do - -- Note that briDoc is BriDocNumbered, but state type is BriDoc. - -- That's why the alt-transform looks a bit special here. - traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw - $ briDocToDoc - $ unwrapBriDocNumbered - $ briDoc - -- bridoc transformation: remove alts - transformAlts briDoc >>= mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyFloating .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf - "bridoc post-floating" - _dconf_dump_bridoc_simpl_floating - -- bridoc transformation: par removal - mGet >>= transformSimplifyPar .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par - -- bridoc transformation: float stuff in - mGet >>= transformSimplifyColumns .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns - -- bridoc transformation: indent - mGet >>= transformSimplifyIndent .> mSet - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent - mGet - >>= briDocToDoc - .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final - -- -- convert to Simple type - -- simpl <- mGet <&> transformToSimple - -- return simpl - - anns :: ExactPrint.Anns <- mAsk - - let - state = LayoutState - { _lstate_baseYs = [0] - , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left - -- here because moveToAnn stuff - -- of the first node needs to do - -- its thing properly. - , _lstate_indLevels = [0] - , _lstate_indLevelLinger = 0 - , _lstate_comments = anns - , _lstate_commentCol = Nothing - , _lstate_addSepSpace = Nothing - , _lstate_commentNewlines = 0 - } - - state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' - - let - remainingComments = - [ c - | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList - (_lstate_comments state') - -- With the new import layouter, we manually process comments - -- without relying on the backend to consume the comments out of - -- the state/map. So they will end up here, and we need to ignore - -- them. - , ExactPrint.unConName con /= "ImportDecl" - , c <- extractAllComments elemAnns - ] - remainingComments - `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) - - return $ () diff --git a/source/library/Language/Haskell/Brittany/Internal/Backend.hs b/source/library/Language/Haskell/Brittany/Internal/Backend.hs deleted file mode 100644 index 55a3c97..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Backend.hs +++ /dev/null @@ -1,732 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.Backend where - -import qualified Control.Monad.Trans.State.Strict as StateS -import qualified Data.Either as Either -import qualified Data.Foldable as Foldable -import qualified Data.IntMap.Lazy as IntMapL -import qualified Data.IntMap.Strict as IntMapS -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.BackendUtils -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types - - - -type ColIndex = Int - -data ColumnSpacing - = ColumnSpacingLeaf Int - | ColumnSpacingRef Int Int - -type ColumnBlock a = [a] -type ColumnBlocks a = Seq [a] -type ColMap1 - = IntMapL.IntMap {- ColIndex -} - (Bool, ColumnBlocks ColumnSpacing) -type ColMap2 - = IntMapL.IntMap {- ColIndex -} - (Float, ColumnBlock Int, ColumnBlocks Int) - -- (ratio of hasSpace, maximum, raw) - -data ColInfo - = ColInfoStart -- start value to begin the mapAccumL. - | ColInfoNo BriDoc - | ColInfo ColIndex ColSig [(Int, ColInfo)] - -instance Show ColInfo where - show ColInfoStart = "ColInfoStart" - show (ColInfoNo bd) = - "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") - show (ColInfo ind sig list) = - "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list - -data ColBuildState = ColBuildState - { _cbs_map :: ColMap1 - , _cbs_index :: ColIndex - } - -type LayoutConstraints m - = ( MonadMultiReader Config m - , MonadMultiReader ExactPrint.Types.Anns m - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiWriter (Seq String) m - , MonadMultiState LayoutState m - ) - -layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () -layoutBriDocM = \case - BDEmpty -> do - return () -- can it be that simple - BDLit t -> do - layoutIndentRestorePostComment - layoutRemoveIndentLevelLinger - layoutWriteAppend t - BDSeq list -> do - list `forM_` layoutBriDocM - -- in this situation, there is nothing to do about cols. - -- i think this one does not happen anymore with the current simplifications. - -- BDCols cSig list | BDPar sameLine lines <- List.last list -> - -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines - BDCols _ list -> do - list `forM_` layoutBriDocM - BDSeparator -> do - layoutAddSepSpace - BDAddBaseY indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ layoutBriDocM bd - BDBaseYPushCur bd -> do - layoutBaseYPushCur - layoutBriDocM bd - BDBaseYPop bd -> do - layoutBriDocM bd - layoutBaseYPop - BDIndentLevelPushCur bd -> do - layoutIndentLevelPushCur - layoutBriDocM bd - BDIndentLevelPop bd -> do - layoutBriDocM bd - layoutIndentLevelPop - BDEnsureIndent indent bd -> do - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteEnsureBlock - layoutBriDocM bd - BDPar indent sameLine indented -> do - layoutBriDocM sameLine - let - indentF = case indent of - BrIndentNone -> id - BrIndentRegular -> layoutWithAddBaseCol - BrIndentSpecial i -> layoutWithAddBaseColN i - indentF $ do - layoutWriteNewlineBlock - layoutBriDocM indented - BDLines lines -> alignColsLines lines - BDAlt [] -> error "empty BDAlt" - BDAlt (alt : _) -> layoutBriDocM alt - BDForceMultiline bd -> layoutBriDocM bd - BDForceSingleline bd -> layoutBriDocM bd - BDForwardLineMode bd -> layoutBriDocM bd - BDExternal annKey subKeys shouldAddComment t -> do - let - tlines = Text.lines $ t <> Text.pack "\n" - tlineCount = length tlines - anns :: ExactPrint.Anns <- mAsk - when shouldAddComment $ do - layoutWriteAppend - $ Text.pack - $ "{-" - ++ show (annKey, Map.lookup annKey anns) - ++ "-}" - zip [1 ..] tlines `forM_` \(i, l) -> do - layoutWriteAppend $ l - unless (i == tlineCount) layoutWriteNewlineBlock - do - state <- mGet - let filterF k _ = not $ k `Set.member` subKeys - mSet $ state - { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state - } - BDPlain t -> do - layoutWriteAppend t - BDAnnotationPrior annKey bd -> do - state <- mGet - let m = _lstate_comments state - let - moveToExactLocationAction = case _lstate_curYOrAddNewline state of - Left{} -> pure () - Right{} -> moveToExactAnn annKey - mAnn <- do - let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - annKey - m - } - return mAnn - case mAnn of - Nothing -> moveToExactLocationAction - Just [] -> moveToExactLocationAction - Just priors -> do - -- layoutResetSepSpace - priors - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) - -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - moveToExactLocationAction - layoutBriDocM bd - BDAnnotationKW annKey keyword bd -> do - layoutBriDocM bd - mComments <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let - mToSpan = case mAnn of - Just anns | Maybe.isNothing keyword -> Just anns - Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> - Just annR - _ -> Nothing - case mToSpan of - Just anns -> do - let - (comments, rest) = flip spanMaybe anns $ \case - (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) - _ -> Nothing - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annsDP = rest }) - annKey - m - } - return $ nonEmpty comments - _ -> return Nothing - case mComments of - Nothing -> pure () - Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack $ comment - -- evil hack for CPP: - case comment of - ('#' : _) -> - layoutMoveToCommentPos y (-999) (length commentLines) - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDAnnotationRest annKey bd -> do - layoutBriDocM bd - annMay <- do - state <- mGet - let m = _lstate_comments state - pure $ Map.lookup annKey m - let mComments = nonEmpty . extractAllComments =<< annMay - let - semiCount = length - [ () - | Just ann <- [annMay] - , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann - ] - shouldAddSemicolonNewlines <- - mAsk - <&> _conf_layout - .> _lconfig_experimentalSemicolonNewlines - .> confUnpack - mModify $ \state -> state - { _lstate_comments = Map.adjust - (\ann -> ann - { ExactPrint.annFollowingComments = [] - , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case - (ExactPrint.Types.AnnComment{}, _) -> False - _ -> True - } - ) - annKey - (_lstate_comments state) - } - case mComments of - Nothing -> do - when shouldAddSemicolonNewlines $ do - [1 .. semiCount] `forM_` const layoutWriteNewline - Just comments -> do - comments - `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> - when (comment /= "(" && comment /= ")") $ do - let commentLines = Text.lines $ Text.pack comment - case comment of - ('#' : _) -> layoutMoveToCommentPos y (-999) 1 - -- ^ evil hack for CPP - ")" -> pure () - -- ^ fixes the formatting of parens - -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x (length commentLines) - -- fixedX <- fixMoveToLineByIsNewline x - -- replicateM_ fixedX layoutWriteNewline - -- layoutMoveToIndentCol y - layoutWriteAppendMultiline commentLines - -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do - mDP <- do - state <- mGet - let m = _lstate_comments state - let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m - let - relevant = - [ dp - | Just ann <- [mAnn] - , (ExactPrint.Types.G kw1, dp) <- ann - , keyword == kw1 - ] - -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] - case relevant of - [] -> pure Nothing - (ExactPrint.Types.DP (y, x) : _) -> do - mSet state { _lstate_commentNewlines = 0 } - pure $ Just (y - _lstate_commentNewlines state, x) - case mDP of - Nothing -> pure () - Just (y, x) -> - -- we abuse this, as we probably will print the KW next, which is - -- _not_ a comment.. - layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 - layoutBriDocM bd - BDNonBottomSpacing _ bd -> layoutBriDocM bd - BDSetParSpacing bd -> layoutBriDocM bd - BDForceParSpacing bd -> layoutBriDocM bd - BDDebug s bd -> do - mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" - layoutBriDocM bd - -briDocLineLength :: BriDoc -> Int -briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc - -- the state encodes whether a separator was already - -- appended at the current position. - where - rec = \case - BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds - BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line - BDAlt{} -> error "briDocLineLength BDAlt" - BDForceMultiline bd -> rec bd - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t -> return $ Text.length t - BDPlain t -> return $ Text.length t - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_ : _) -> do - x <- StateS.get - return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - -briDocIsMultiLine :: BriDoc -> Bool -briDocIsMultiLine briDoc = rec briDoc - where - rec :: BriDoc -> Bool - rec = \case - BDEmpty -> False - BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds - BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar{} -> True - BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceMultiline _ -> True - BDForceSingleline bd -> rec bd - BDForwardLineMode bd -> rec bd - BDExternal _ _ _ t | [_] <- Text.lines t -> False - BDExternal{} -> True - BDPlain t | [_] <- Text.lines t -> False - BDPlain _ -> True - BDAnnotationPrior _ bd -> rec bd - BDAnnotationKW _ _ bd -> rec bd - BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ _ bd -> rec bd - BDLines (_ : _ : _) -> True - BDLines [_] -> False - BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing _ bd -> rec bd - BDDebug _ bd -> rec bd - --- In theory --- ========= - --- .. this algorithm works roughly in these steps: --- --- 1. For each line, get the (nested) column info, descending as far as --- BDCols nodes go. The column info is a (rose) tree where the leafs --- are arbitrary (non-BDCols) BriDocs. --- 2. Walk through the lines and compare its column info with that of its --- predecessor. If both are non-leafs and the column "signatures" align --- (they don't align e.g. when they are totally different syntactical --- structures or the number of children differs), mark these parts of --- the two tree structures as connected and recurse to its children --- (i.e. again comparing the children in this line with the children in --- the previous line). --- 3. What we now have is one tree per line, and connections between "same" --- nodes between lines. These connection can span multiple lines. --- We next look at spacing information. This is available at the leafs, --- but in this step we aggregate _over connections_. At the top level, this --- gives us one piece of data: How long would each line be, if we fully --- aligned everything (kept all connections "active"). In contrast to --- just taking the sum of all leafs for each tree, this line length includes --- the spaces used for alignment. --- 4. Treat those lines where alignment would result in overflowing of the --- column limit. This "treatment" is currently configurable, and can e.g. --- mean: --- a) we stop alignment alltogether, --- b) we remove alignment just from the overflowing lines, --- c) we reduce the number of spaces inserted in overflowing lines using --- some technique to make them not overflow, but without reducing the --- space insertion to zero, --- d) don't do anything --- 5. Actually print the lines, walking over each tree and inserting spaces --- according to the info and decisions gathered in the previous steps. --- --- Possible improvements --- ===================== --- --- - If alignment is disabled for specific lines, the aggregated per-connection --- info of those lines is still retained and not recalculated. This can --- result in spaces being inserted to create alignment with a line that --- would overflow and thus gets disabled entirely. --- An better approach would be to repeat step 3 after marking overflowing --- lines as such, and not include the overflowing spacings as references --- for non-overflowing ones. In the simplest case one additional iteration --- would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine --- this and first remove alignment in the deepest parts of the tree for --- overflowing lines, repeating and moving upwards until no lines are --- anymore overflowing. --- Further, it may make sense to break up connections when overflowing would --- occur. --- - It may also make sense to not filter all overflowing lines, but remove --- them one-by-one and in each step recalculate the aggregated connection --- spacing info. Because removing one overflowing line from the calculation --- may very well cause another previously overflowing line to not overflow --- any longer. --- There is also a nasty optimization problem hiding in there (find the --- minimal amount of alignment disabling that results in no overflows) --- but that is overkill. --- --- (with both these improvements there would be quite some repetition between --- steps 3 and 4, but it should be possible to ensure termination. Still, --- performance might become an issue as such an approach is not necessarily --- linear in bridoc size any more.) --- --- In practice --- =========== --- --- .. the current implementation is somewhat sloppy. Steps 1 and 2 --- are executed in one step, step 3 already applies one strategy that disables --- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some --- of the calculations one might expect to occur in step 3. Steps 4 and 5 --- are executed in the same recursion, too. --- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue --- mentioned in the first "possible improvement". -alignColsLines :: LayoutConstraints m => [BriDoc] -> m () -alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do - -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) - curX <- do - state <- mGet - return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe - 0 - (_lstate_addSepSpace state) - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack - alignBreak <- - mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack - case () of - _ -> do - -- tellDebugMess ("processedMap: " ++ show processedMap) - sequence_ - $ List.intersperse layoutWriteEnsureNewlineBlock - $ colInfos - <&> processInfo colMax processedMap - where - (colInfos, finalState) = - StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) - -- maxZipper :: [Int] -> [Int] -> [Int] - -- maxZipper [] ys = ys - -- maxZipper xs [] = xs - -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr - colAggregation :: [Int] -> Int - colAggregation [] = 0 -- this probably cannot happen the way we call - -- this function, because _cbs_map only ever - -- contains nonempty Seqs. - colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ] - where alignMax' = max 0 alignMax - - processedMap :: ColMap2 - processedMap = fix $ \result -> - _cbs_map finalState <&> \(lastFlag, colSpacingss) -> - let - colss = colSpacingss <&> \spss -> case reverse spss of - [] -> [] - (xN : xR) -> - reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR - where - fLast (ColumnSpacingLeaf len) = len - fLast (ColumnSpacingRef len _) = len - fInit (ColumnSpacingLeaf len) = len - fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of - Nothing -> 0 - Just (_, maxs, _) -> sum maxs - maxCols = {-Foldable.foldl1 maxZipper-} - fmap colAggregation $ transpose $ Foldable.toList colss - (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ - mapAccumL (\acc x -> (acc + x, acc)) curX maxCols - counter count l = if List.last posXs + List.last l <= colMax - then count + 1 - else count - ratio = fromIntegral (foldl counter (0 :: Int) colss) - / fromIntegral (length colss) - in (ratio, maxCols, colss) - - mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocs bds = mergeBriDocsW ColInfoStart bds - - mergeBriDocsW - :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] - mergeBriDocsW _ [] = return [] - mergeBriDocsW lastInfo (bd : bdr) = do - info <- mergeInfoBriDoc True lastInfo bd - infor <- mergeBriDocsW - -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) - (if shouldBreakAfter bd then ColInfoStart else info) - bdr - return $ info : infor - - -- even with alignBreak config flag, we don't stop aligning for certain - -- ColSigs - the ones with "False" below. The main reason is that - -- there are uses of BDCols where they provide the alignment of several - -- consecutive full larger code segments, for example ColOpPrefix. - -- Motivating example is - -- > foo - -- > $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - -- > , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - -- > ] - -- > ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ] - -- If we break the alignment here, then all three lines for the first - -- list move left by one, which is horrible. We really don't want to - -- break whole-block alignments. - -- For list, listcomp, tuple and tuples the reasoning is much simpler: - -- alignment should not have much effect anyways, so i simply make the - -- choice here that enabling alignment is the safer route for preventing - -- potential glitches, and it should never have a negative effect. - -- For RecUpdate the argument is much less clear - it is mostly a - -- personal preference to not break alignment for those, even if - -- multiline. Really, this should be configurable.. (TODO) - shouldBreakAfter :: BriDoc -> Bool - shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of - (BDCols ColTyOpPrefix _) -> False - (BDCols ColPatternsFuncPrefix _) -> True - (BDCols ColPatternsFuncInfix _) -> True - (BDCols ColPatterns _) -> True - (BDCols ColCasePattern _) -> True - (BDCols ColBindingLine{} _) -> True - (BDCols ColGuard _) -> True - (BDCols ColGuardedBody _) -> True - (BDCols ColBindStmt _) -> True - (BDCols ColDoLet _) -> True - (BDCols ColRec _) -> False - (BDCols ColRecUpdate _) -> False - (BDCols ColRecDecl _) -> False - (BDCols ColListComp _) -> False - (BDCols ColList _) -> False - (BDCols ColApp{} _) -> True - (BDCols ColTuple _) -> False - (BDCols ColTuples _) -> False - (BDCols ColOpPrefix _) -> False - _ -> True - - mergeInfoBriDoc - :: Bool - -> ColInfo - -> BriDoc - -> StateS.StateT ColBuildState Identity ColInfo - mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag - mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = - \case - brdc@(BDCols colSig subDocs) - | infoSig == colSig && length subLengthsInfos == length subDocs -> do - let - isLastList = if lastFlag - then (== length subDocs) <$> [1 ..] - else repeat False - infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs - `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd - let curLengths = briDocLineLength <$> subDocs - let trueSpacings = getTrueSpacings (zip curLengths infos) - do -- update map - s <- StateS.get - let m = _cbs_map s - let (Just (_, spaces)) = IntMapS.lookup infoInd m - StateS.put s - { _cbs_map = IntMapS.insert - infoInd - (lastFlag, spaces Seq.|> trueSpacings) - m - } - return $ ColInfo infoInd colSig (zip curLengths infos) - | otherwise -> briDocToColInfo lastFlag brdc - brdc -> return $ ColInfoNo brdc - -briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo -briDocToColInfo lastFlag = \case - BDCols sig list -> withAlloc lastFlag $ \ind -> do - let - isLastList = - if lastFlag then (== length list) <$> [1 ..] else repeat False - subInfos <- zip isLastList list `forM` uncurry briDocToColInfo - let lengthInfos = zip (briDocLineLength <$> list) subInfos - let trueSpacings = getTrueSpacings lengthInfos - return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) - bd -> return $ ColInfoNo bd - -getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] -getTrueSpacings lengthInfos = lengthInfos <&> \case - (len, ColInfo i _ _) -> ColumnSpacingRef len i - (len, _) -> ColumnSpacingLeaf len - -withAlloc - :: Bool - -> ( ColIndex - -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) - ) - -> StateS.State ColBuildState ColInfo -withAlloc lastFlag f = do - cbs <- StateS.get - let ind = _cbs_index cbs - StateS.put $ cbs { _cbs_index = ind + 1 } - (space, info) <- f ind - StateS.get >>= \c -> StateS.put - $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } - return info - -processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () -processInfo maxSpace m = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ - do - colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack - alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack - curX <- do - state <- mGet - -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) - let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state - return $ case _lstate_curYOrAddNewline state of - Left i -> case _lstate_commentCol state of - Nothing -> spaceAdd + i - Just c -> c - Right{} -> spaceAdd - let colMax = min colMaxConf (curX + maxSpace) - -- tellDebugMess $ show curX - let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m - let - maxCols2 = list <&> \case - (_, ColInfo i _ _) -> - let Just (_, ms, _) = IntMapS.lookup i m in sum ms - (l, _) -> l - let maxCols = zipWith max maxCols1 maxCols2 - let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols - -- handle the cases that the vertical alignment leads to more than max - -- cols: - -- this is not a full fix, and we must correct individually in addition. - -- because: the (at least) line with the largest element in the last - -- column will always still overflow, because we just updated the column - -- sizes in such a way that it works _if_ we have sizes (*factor) - -- in each column. but in that line, in the last column, we will be - -- forced to occupy the full vertical space, not reduced by any factor. - let - fixedPosXs = case alignMode of - ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) - where - factor :: Float = - -- 0.0001 as an offering to the floating point gods. - min - 1.0001 - (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) - offsets = (subtract curX) <$> posXs - fixed = offsets <&> fromIntegral .> (* factor) .> truncate - _ -> posXs - let - spacings = - zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs - -- tellDebugMess $ "ind = " ++ show ind - -- tellDebugMess $ "maxCols = " ++ show maxCols - -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs - -- tellDebugMess $ "list = " ++ show list - -- tellDebugMess $ "maxSpace = " ++ show maxSpace - let - alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do - layoutWriteEnsureAbsoluteN destX - processInfo s m (snd x) - noAlignAct = list `forM_` (snd .> processInfoIgnore) - animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ - if List.last fixedPosXs + fst (List.last list) > colMax - -- per-item check if there is overflowing. - then noAlignAct - else alignAct - case alignMode of - ColumnAlignModeDisabled -> noAlignAct - ColumnAlignModeUnanimously | maxX <= colMax -> alignAct - ColumnAlignModeUnanimously -> noAlignAct - ColumnAlignModeMajority limit | ratio >= limit -> animousAct - ColumnAlignModeMajority{} -> noAlignAct - ColumnAlignModeAnimouslyScale{} -> animousAct - ColumnAlignModeAnimously -> animousAct - ColumnAlignModeAlways -> alignAct - -processInfoIgnore :: LayoutConstraints m => ColInfo -> m () -processInfoIgnore = \case - ColInfoStart -> error "should not happen (TM)" - ColInfoNo doc -> layoutBriDocM doc - ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) diff --git a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs b/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs deleted file mode 100644 index 310ea56..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ /dev/null @@ -1,487 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.BackendUtils where - -import qualified Data.Data -import qualified Data.Either -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (Located) -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint - - - -traceLocal :: (MonadMultiState LayoutState m) => a -> m () -traceLocal _ = return () - - -layoutWriteAppend - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => Text - -> m () -layoutWriteAppend t = do - traceLocal ("layoutWriteAppend", t) - state <- mGet - case _lstate_curYOrAddNewline state of - Right i -> do - replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" - Left{} -> do - return () - let spaces = fromMaybe 0 $ _lstate_addSepSpace state - mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') - mTell $ Text.Builder.fromText $ t - mModify $ \s -> s - { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces - Right{} -> Text.length t + spaces - , _lstate_addSepSpace = Nothing - } - -layoutWriteAppendSpaces - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => Int - -> m () -layoutWriteAppendSpaces i = do - traceLocal ("layoutWriteAppendSpaces", i) - unless (i == 0) $ do - state <- mGet - mSet $ state - { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state - } - -layoutWriteAppendMultiline - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => [Text] - -> m () -layoutWriteAppendMultiline ts = do - traceLocal ("layoutWriteAppendMultiline", ts) - case ts of - [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. - (l : lr) -> do - layoutWriteAppend l - lr `forM_` \x -> do - layoutWriteNewline - layoutWriteAppend x - --- adds a newline and adds spaces to reach the base column. -layoutWriteNewlineBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => m () -layoutWriteNewlineBlock = do - traceLocal ("layoutWriteNewlineBlock") - state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = Right 1 - , _lstate_addSepSpace = Just $ lstate_baseY state - } - --- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m --- , MonadMultiWriter (Seq String) m) => Int -> m () --- layoutMoveToIndentCol i = do --- #if INSERTTRACES --- tellDebugMessShow ("layoutMoveToIndentCol", i) --- #endif --- state <- mGet --- mSet $ state --- { _lstate_addSepSpace = Just --- $ if isJust $ _lstate_addNewline state --- then i --- else _lstate_indLevelLinger state + i - _lstate_curY state --- } - -layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () -layoutSetCommentCol = do - state <- mGet - let - col = case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state - traceLocal ("layoutSetCommentCol", col) - unless (Data.Maybe.isJust $ _lstate_commentCol state) - $ mSet state { _lstate_commentCol = Just col } - --- This is also used to move to non-comments in a couple of places. Seems --- to be harmless so far.. -layoutMoveToCommentPos - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => Int - -> Int - -> Int - -> m () -layoutMoveToCommentPos y x commentLines = do - traceLocal ("layoutMoveToCommentPos", y, x, commentLines) - state <- mGet - mSet state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right{} -> Right y - , _lstate_addSepSpace = - Just $ if Data.Maybe.isJust (_lstate_commentCol state) - then case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - else if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state - , _lstate_commentNewlines = - _lstate_commentNewlines state + y + commentLines - 1 - } - --- | does _not_ add spaces to again reach the current base column. -layoutWriteNewline - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => m () -layoutWriteNewline = do - traceLocal ("layoutWriteNewline") - state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right (i + 1) - , _lstate_addSepSpace = Nothing - } - -_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () -_layoutResetCommentNewlines = do - mModify $ \state -> state { _lstate_commentNewlines = 0 } - -layoutWriteEnsureNewlineBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => m () -layoutWriteEnsureNewlineBlock = do - traceLocal ("layoutWriteEnsureNewlineBlock") - state <- mGet - mSet $ state - { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of - Left{} -> Right 1 - Right i -> Right $ max 1 i - , _lstate_addSepSpace = Just $ lstate_baseY state - , _lstate_commentCol = Nothing - } - -layoutWriteEnsureAbsoluteN - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => Int - -> m () -layoutWriteEnsureAbsoluteN n = do - state <- mGet - let - diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of - (Just c, _) -> n - c - (Nothing, Left i) -> n - i - (Nothing, Right{}) -> n - traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) - when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to - -- at least (Just 1), so we won't - -- overwrite any old value in any - -- bad way. - -layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m () -layoutBaseYPushInternal i = do - traceLocal ("layoutBaseYPushInternal", i) - mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } - -layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m () -layoutBaseYPopInternal = do - traceLocal ("layoutBaseYPopInternal") - mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } - -layoutIndentLevelPushInternal :: (MonadMultiState LayoutState m) => Int -> m () -layoutIndentLevelPushInternal i = do - traceLocal ("layoutIndentLevelPushInternal", i) - mModify $ \s -> s - { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = i : _lstate_indLevels s - } - -layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () -layoutIndentLevelPopInternal = do - traceLocal ("layoutIndentLevelPopInternal") - mModify $ \s -> s - { _lstate_indLevelLinger = lstate_indLevel s - , _lstate_indLevels = List.tail $ _lstate_indLevels s - } - -layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () -layoutRemoveIndentLevelLinger = do - mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s } - -layoutWithAddBaseCol - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader Config m - ) - => m () - -> m () -layoutWithAddBaseCol m = do - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - m - layoutBaseYPopInternal - -layoutWithAddBaseColBlock - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader Config m - ) - => m () - -> m () -layoutWithAddBaseColBlock m = do - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - layoutWriteEnsureBlock - m - layoutBaseYPopInternal - -layoutWithAddBaseColNBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => Int - -> m () - -> m () -layoutWithAddBaseColNBlock amount m = do - traceLocal ("layoutWithAddBaseColNBlock", amount) - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - layoutWriteEnsureBlock - m - layoutBaseYPopInternal - -layoutWriteEnsureBlock - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => m () -layoutWriteEnsureBlock = do - traceLocal ("layoutWriteEnsureBlock") - state <- mGet - let - diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of - (Nothing, Left i) -> lstate_baseY state - i - (Nothing, Right{}) -> lstate_baseY state - (Just sp, Left i) -> max sp (lstate_baseY state - i) - (Just sp, Right{}) -> max sp (lstate_baseY state) - -- when (diff>0) $ layoutWriteNewlineBlock - when (diff > 0) $ do - mSet $ state { _lstate_addSepSpace = Just $ diff } - -layoutWithAddBaseColN - :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) - => Int - -> m () - -> m () -layoutWithAddBaseColN amount m = do - state <- mGet - layoutBaseYPushInternal $ lstate_baseY state + amount - m - layoutBaseYPopInternal - -layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () -layoutBaseYPushCur = do - traceLocal ("layoutBaseYPushCur") - state <- mGet - case _lstate_commentCol state of - Nothing -> - case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> layoutBaseYPushInternal (i + j) - (Left i, Nothing) -> layoutBaseYPushInternal i - (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state - Just cCol -> layoutBaseYPushInternal cCol - -layoutBaseYPop :: (MonadMultiState LayoutState m) => m () -layoutBaseYPop = do - traceLocal ("layoutBaseYPop") - layoutBaseYPopInternal - -layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () -layoutIndentLevelPushCur = do - traceLocal ("layoutIndentLevelPushCur") - state <- mGet - let - y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> i + j - (Left i, Nothing) -> i - (Right{}, Just j) -> j - (Right{}, Nothing) -> 0 - layoutIndentLevelPushInternal y - -layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () -layoutIndentLevelPop = do - traceLocal ("layoutIndentLevelPop") - layoutIndentLevelPopInternal - -- why are comment indentations relative to the previous indentation on - -- the first node of an additional indentation, and relative to the outer - -- indentation after the last node of some indented stuff? sure does not - -- make sense. - layoutRemoveIndentLevelLinger - -layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () -layoutAddSepSpace = do - state <- mGet - mSet $ state - { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state - } - --- TODO: when refactoring is complete, the other version of this method --- can probably be removed. -moveToExactAnn - :: ( MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => AnnKey - -> m () -moveToExactAnn annKey = do - traceLocal ("moveToExactAnn", annKey) - anns <- mAsk - case Map.lookup annKey anns of - Nothing -> return () - Just ann -> do - -- curY <- mGet <&> _lstate_curY - let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann - -- mModify $ \state -> state { _lstate_addNewline = Just x } - moveToY y - -moveToY :: MonadMultiState LayoutState m => Int -> m () -moveToY y = mModify $ \state -> - let - upd = case _lstate_curYOrAddNewline state of - Left i -> if y == 0 then Left i else Right y - Right i -> Right $ max y i - in - state - { _lstate_curYOrAddNewline = upd - , _lstate_addSepSpace = if Data.Either.isRight upd - then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just - (lstate_baseY state) - else Nothing - , _lstate_commentCol = Nothing - } --- fixMoveToLineByIsNewline :: MonadMultiState --- LayoutState m => Int -> m Int --- fixMoveToLineByIsNewline x = do --- newLineState <- mGet <&> _lstate_isNewline --- return $ if newLineState == NewLineStateYes --- then x-1 --- else x - -ppmMoveToExactLoc - :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () -ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do - replicateM_ x $ mTell $ Text.Builder.fromString "\n" - replicateM_ y $ mTell $ Text.Builder.fromString " " - --- TODO: update and use, or clean up. Currently dead code. -layoutWritePriorComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Located ast - -> m () -layoutWritePriorComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annPriorComments = [] }) - key - anns - } - return mAnn - case mAnn of - Nothing -> return () - Just priors -> do - unless (null priors) $ layoutSetCommentCol - priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> - do - replicateM_ x layoutWriteNewline - layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.lines $ Text.pack comment - --- TODO: update and use, or clean up. Currently dead code. --- this currently only extracs from the `annsDP` field of Annotations. --- per documentation, this seems sufficient, as the --- "..`annFollowingComments` are only added by AST transformations ..". -layoutWritePostComments - :: ( Data.Data.Data ast - , MonadMultiWriter Text.Builder.Builder m - , MonadMultiState LayoutState m - ) - => Located ast - -> m () -layoutWritePostComments ast = do - mAnn <- do - state <- mGet - let key = ExactPrint.mkAnnKey ast - let anns = _lstate_comments state - let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns - mSet $ state - { _lstate_comments = Map.adjust - (\ann -> ann { ExactPrint.annFollowingComments = [] }) - key - anns - } - return mAnn - case mAnn of - Nothing -> return () - Just posts -> do - unless (null posts) $ layoutSetCommentCol - posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> - do - replicateM_ x layoutWriteNewline - layoutWriteAppend $ Text.pack $ replicate y ' ' - mModify $ \s -> s { _lstate_addSepSpace = Nothing } - layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment - -layoutIndentRestorePostComment - :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m) - => m () -layoutIndentRestorePostComment = do - state <- mGet - let mCommentCol = _lstate_commentCol state - let eCurYAddNL = _lstate_curYOrAddNewline state - mModify - $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } - case (mCommentCol, eCurYAddNL) of - (Just commentCol, Left{}) -> do - layoutWriteEnsureNewlineBlock - layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe - 0 - (_lstate_addSepSpace state) - _ -> return () - --- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, --- MonadMultiWriter Text.Builder.Builder m, --- MonadMultiState LayoutState m --- , MonadMultiWriter (Seq String) m) --- => Located ast -> m () --- layoutWritePriorCommentsRestore x = do --- layoutWritePriorComments x --- layoutIndentRestorePostComment --- --- layoutWritePostCommentsRestore :: (Data.Data.Data ast, --- MonadMultiWriter Text.Builder.Builder m, --- MonadMultiState LayoutState m --- , MonadMultiWriter (Seq String) m) --- => Located ast -> m () --- layoutWritePostCommentsRestore x = do --- layoutWritePostComments x --- layoutIndentRestorePostComment diff --git a/source/library/Language/Haskell/Brittany/Internal/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config.hs deleted file mode 100644 index 040320b..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Config.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Config where - -import qualified Data.Bool as Bool -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 -import Data.CZipWith -import Data.Coerce (coerce) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Semigroup as Semigroup -import qualified Data.Yaml -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config.Types.Instances () -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Utils -import qualified System.Console.CmdArgs.Explicit as CmdArgs -import qualified System.Directory -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath -import qualified System.IO -import UI.Butcher.Monadic - --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } -staticDefaultConfig :: Config -staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig - { _dconf_dump_config = coerce False - , _dconf_dump_annotations = coerce False - , _dconf_dump_ast_unknown = coerce False - , _dconf_dump_ast_full = coerce False - , _dconf_dump_bridoc_raw = coerce False - , _dconf_dump_bridoc_simpl_alt = coerce False - , _dconf_dump_bridoc_simpl_floating = coerce False - , _dconf_dump_bridoc_simpl_par = coerce False - , _dconf_dump_bridoc_simpl_columns = coerce False - , _dconf_dump_bridoc_simpl_indent = coerce False - , _dconf_dump_bridoc_final = coerce False - , _dconf_roundtrip_exactprint_only = coerce False - } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) - , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True - , _lconfig_experimentalSemicolonNewlines = coerce False - -- , _lconfig_allowSinglelineRecord = coerce False - } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = coerce False - , _econf_Werror = coerce False - , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline - , _econf_omit_output_valid_check = coerce False - } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = coerce CPPModeAbort - , _ppconf_hackAroundIncludes = coerce False - } - , _conf_forward = ForwardOptions { _options_ghc = Identity [] } - , _conf_roundtrip_exactprint_only = coerce False - , _conf_disable_formatting = coerce False - , _conf_obfuscate = coerce False - } - -forwardOptionsSyntaxExtsEnabled :: ForwardOptions -forwardOptionsSyntaxExtsEnabled = ForwardOptions - { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] - } - --- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } -cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) -cmdlineConfigParser = do - -- TODO: why does the default not trigger; ind never should be []!! - ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") - cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") - importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") - importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") - - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") - dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") - dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") - dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") - dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") - dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") - dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") - dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") - dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") - wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") - - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - - optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") - - return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig - { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig - , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar - , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal - , _dconf_roundtrip_exactprint_only = mempty - } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ - , _lconfig_indentListSpecial = mempty -- falseToNothing _ - , _lconfig_importColumn = optionConcat importCol - , _lconfig_importAsColumn = optionConcat importAsCol - , _lconfig_altChooser = mempty - , _lconfig_columnAlignMode = mempty - , _lconfig_alignmentLimit = mempty - , _lconfig_alignmentBreakOnMultiline = mempty - , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty - , _lconfig_allowHangingQuasiQuotes = mempty - , _lconfig_experimentalSemicolonNewlines = mempty - -- , _lconfig_allowSinglelineRecord = mempty - } - , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors - , _econf_Werror = wrapLast $ falseToNothing wError - , _econf_ExactPrintFallback = mempty - , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck - } - , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } - , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } - , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate - } - where - falseToNothing = Bool.bool Nothing (Just True) - wrapLast :: Maybe a -> Maybe (Semigroup.Last a) - wrapLast = fmap Semigroup.Last - optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Maybe (f a) - optionConcat = mconcat . fmap (pure . pure) - --- configParser :: Parser Config --- configParser = Config --- <$> option (eitherReader $ maybe (Left "required <int>!") Right . readMaybe) --- (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level") --- <*> (Bar --- <$> switch (long "bara" <> help "bara help") --- <*> switch (long "barb") --- <*> flag 3 5 (long "barc") --- ) --- --- configParserInfo :: ParserInfo Config --- configParserInfo = ParserInfo --- { infoParser = configParser --- , infoFullDesc = True --- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" --- , infoHeader = return $ PP.text "brittany" --- , infoFooter = empty --- , infoFailureCode = (-55) --- , infoIntersperse = True --- } - - --- | Reads a config from a file. If the file does not exist, returns --- Nothing. If the file exists and parsing fails, prints to stderr and --- aborts the MaybeT. Otherwise succeed via Just. --- If the second parameter is True and the file does not exist, writes the --- staticDefaultConfig to the file. -readConfig - :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe)) -readConfig path = do - -- TODO: probably should catch IOErrors and then omit the existence check. - exists <- liftIO $ System.Directory.doesFileExist path - if exists - then do - contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. - fileConf <- case Data.Yaml.decodeEither' contents of - Left e -> do - liftIO - $ putStrErrLn - $ "error reading in brittany config from " - ++ path - ++ ":" - liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) - mzero - Right x -> return x - return $ Just fileConf - else return $ Nothing - --- | Looks for a user-global config file and return its path. --- If there is no global config in a system, one will be created. -userConfigPath :: IO System.IO.FilePath -userConfigPath = do - userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" - let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith - Directory.doesFileExist - searchDirs - "config.yaml" - maybe (writeUserConfig userBritPathXdg) pure globalConfig - where - writeUserConfig dir = do - let createConfPath = dir FilePath.</> "config.yaml" - liftIO $ Directory.createDirectoryIfMissing True dir - writeDefaultConfig $ createConfPath - pure createConfPath - --- | Searches for a local (per-project) brittany config starting from a given directory -findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) -findLocalConfigPath dir = do - let dirParts = FilePath.splitDirectories dir - -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] - let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) - Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" - --- | Reads specified configs. -readConfigs - :: CConfig Maybe -- ^ Explicit options, take highest priority - -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first - -> MaybeT IO Config -readConfigs cmdlineConfig configPaths = do - configs <- readConfig `mapM` configPaths - let - merged = - Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) - return $ cZipWith fromOptionIdentity staticDefaultConfig merged - --- | Reads provided configs --- but also applies the user default configuration (with lowest priority) -readConfigsWithUserConfig - :: CConfig Maybe -- ^ Explicit options, take highest priority - -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first - -> MaybeT IO Config -readConfigsWithUserConfig cmdlineConfig configPaths = do - defaultPath <- liftIO $ userConfigPath - readConfigs cmdlineConfig (configPaths ++ [defaultPath]) - -writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () -writeDefaultConfig path = - liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap - (Just . runIdentity) - staticDefaultConfig - -showConfigYaml :: Config -> String -showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap - (\(Identity x) -> Just x) diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs deleted file mode 100644 index c667038..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- These optimizations are disabled to improve compile times (and compilation --- memory usage). When we do not disable them, the CI servers take more than --- 10 minutes to compile this module alone. --- Having looked into aeson and how the instances are written, I still do --- not understand what makes GHC choke so much here. The size of the raw --- expressions below looks fairly negligible, so there must be some expansion --- due to inlining going on. But even disabling INLINE pragmas in aeson did --- not seem to change anything. --- Nonetheless, this solution works and has no downsides because the --- instances defined here are not in any way performance-critical. -{-# OPTIONS_GHC -fno-pre-inlining #-} -{-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fignore-interface-pragmas #-} - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Config.Types.Instances where - -import qualified Data.Aeson.Key as Key -import qualified Data.Aeson.Types as Aeson -import Data.Yaml -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude - - - -aesonDecodeOptionsBrittany :: Aeson.Options -aesonDecodeOptionsBrittany = Aeson.defaultOptions - { Aeson.omitNothingFields = True - , Aeson.fieldLabelModifier = dropWhile (== '_') - } - -instance FromJSON (CDebugConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CDebugConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON IndentPolicy where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON IndentPolicy where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON AltChooser where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON AltChooser where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON ColumnAlignMode where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON ColumnAlignMode where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON CPPMode where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON CPPMode where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON ExactPrintFallbackMode where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON ExactPrintFallbackMode where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany - -instance FromJSON (CLayoutConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CLayoutConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON (CErrorHandlingConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CErrorHandlingConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON (CForwardOptions Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CForwardOptions Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance FromJSON (CPreProcessorConfig Maybe) where - parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany - -instance ToJSON (CPreProcessorConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - -instance ToJSON (CConfig Maybe) where - toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany - --- This custom instance ensures the "omitNothingFields" behaviour not only for --- leafs, but for nodes of the config as well. This way e.g. "{}" is valid --- config file content. -instance FromJSON (CConfig Maybe) where - parseJSON (Object v) = - Config - <$> v - .:? Key.fromString "conf_version" - <*> v - .:?= Key.fromString "conf_debug" - <*> v - .:?= Key.fromString "conf_layout" - <*> v - .:?= Key.fromString "conf_errorHandling" - <*> v - .:?= Key.fromString "conf_forward" - <*> v - .:?= Key.fromString "conf_preprocessor" - <*> v - .:? Key.fromString "conf_roundtrip_exactprint_only" - <*> v - .:? Key.fromString "conf_disable_formatting" - <*> v - .:? Key.fromString "conf_obfuscate" - parseJSON invalid = Aeson.typeMismatch "Config" invalid - --- Pretends that the value is {} when the key is not present. -(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a -o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure diff --git a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs deleted file mode 100644 index 63d6b53..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.ExactPrintUtils where - -import qualified Control.Monad.State.Class as State.Class -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.Data -import qualified Data.Foldable as Foldable -import qualified Data.Generics as SYB -import Data.HList.HList -import qualified Data.Map as Map -import qualified Data.Maybe -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import GHC (GenLocated(L)) -import qualified GHC hiding (parseModule) -import qualified GHC.Driver.CmdLine as GHC -import GHC.Hs -import qualified GHC.Types.SrcLoc as GHC -import GHC.Types.SrcLoc (Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import qualified System.IO - - - -parseModule - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule args fp dynCheck = do - str <- System.IO.readFile fp - parseModuleFromString args fp dynCheck str - -parseModuleFromString - :: [String] - -> System.IO.FilePath - -> (GHC.DynFlags -> IO (Either String a)) - -> String - -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModuleFromString = ParseModule.parseModule - - -commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () -commentAnnFixTransformGlob ast = do - let - extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) - extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ - const Seq.empty - `SYB.ext1Q` (\l@(L span _) -> - Seq.singleton (span, ExactPrint.mkAnnKey l) - ) - let nodes = SYB.everything (<>) extract ast - let - annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey - annsMap = Map.fromListWith - (const id) - [ (GHC.realSrcSpanEnd span, annKey) - | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes - ] - nodes `forM_` (snd .> processComs annsMap) - where - processComs annsMap annKey1 = do - mAnn <- State.Class.gets fst <&> Map.lookup annKey1 - mAnn `forM_` \ann1 -> do - let - priors = ExactPrint.annPriorComments ann1 - follows = ExactPrint.annFollowingComments ann1 - assocs = ExactPrint.annsDP ann1 - let - processCom - :: (ExactPrint.Comment, ExactPrint.DeltaPos) - -> ExactPrint.TransformT Identity Bool - processCom comPair@(com, _) = - case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of - comLoc -> case Map.lookupLE comLoc annsMap of - Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of - (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> - move $> False - (x, y) | x == y -> move $> False - _ -> return True - where - ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 - ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 - loc1 = GHC.realSrcSpanStart annKeyLoc1 - loc2 = GHC.realSrcSpanStart annKeyLoc2 - move = ExactPrint.modifyAnnsT $ \anns -> - let - ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns - ann2' = ann2 - { ExactPrint.annFollowingComments = - ExactPrint.annFollowingComments ann2 ++ [comPair] - } - in Map.insert annKey2 ann2' anns - _ -> return True -- retain comment at current node. - priors' <- filterM processCom priors - follows' <- filterM processCom follows - assocs' <- flip filterM assocs $ \case - (ExactPrint.AnnComment com, dp) -> processCom (com, dp) - _ -> return True - let - ann1' = ann1 - { ExactPrint.annPriorComments = priors' - , ExactPrint.annFollowingComments = follows' - , ExactPrint.annsDP = assocs' - } - ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns - - --- TODO: this is unused by now, but it contains one detail that --- commentAnnFixTransformGlob does not include: Moving of comments for --- "RecordUpd"s. --- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () --- commentAnnFixTransform modul = SYB.everything (>>) genF modul --- where --- genF :: Data.Data.Data a => a -> ExactPrint.Transform () --- genF = (\_ -> return ()) `SYB.extQ` exprF --- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () --- exprF lexpr@(L _ expr) = case expr of --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> --- #else --- RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ --- RecordUpd _ _e fs@(_:_) -> --- #else --- RecordUpd _e fs@(_:_) _cons _ _ _ -> --- #endif --- moveTrailingComments lexpr (List.last fs) --- _ -> return () - --- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () --- commentAnnFixTransform modul = SYB.everything (>>) genF modul --- where --- genF :: Data.Data.Data a => a -> ExactPrint.Transform () --- genF = (\_ -> return ()) `SYB.extQ` exprF --- exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform () --- exprF lexpr@(L _ expr) = case expr of --- RecordCon _ _ (HsRecFields fs@(_:_) Nothing) -> --- moveTrailingComments lexpr (List.last fs) --- RecordUpd _ _e fs@(_:_) -> --- moveTrailingComments lexpr (List.last fs) --- _ -> return () - --- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) --- => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () --- moveTrailingComments astFrom astTo = do --- let --- k1 = ExactPrint.mkAnnKey astFrom --- k2 = ExactPrint.mkAnnKey astTo --- moveComments ans = ans' --- where --- an1 = Data.Maybe.fromJust $ Map.lookup k1 ans --- an2 = Data.Maybe.fromJust $ Map.lookup k2 ans --- cs1f = ExactPrint.annFollowingComments an1 --- cs2f = ExactPrint.annFollowingComments an2 --- (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) --- $ \case --- (ExactPrint.AnnComment com, dp) -> Left (com, dp) --- x -> Right x --- an1' = an1 --- { ExactPrint.annsDP = nonComments --- , ExactPrint.annFollowingComments = [] --- } --- an2' = an2 --- { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments --- } --- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - --- ExactPrint.modifyAnnsT moveComments - --- | split a set of annotations in a module into a map from top-level module --- elements to the relevant annotations. Avoids quadratic behaviour a trivial --- implementation would have. -extractToplevelAnns - :: Located HsModule - -> ExactPrint.Anns - -> Map ExactPrint.AnnKey ExactPrint.Anns -extractToplevelAnns lmod anns = output - where - (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod - declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap1 = Map.unions $ ldecls <&> \ldecl -> - Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) - declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey - declMap2 = - Map.fromList - $ [ (captured, declMap1 Map.! k) - | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns - ] - declMap = declMap1 `Map.union` declMap2 - modKey = ExactPrint.mkAnnKey lmod - output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns - -groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) -groupMap f = Map.foldlWithKey' - (\m k a -> Map.alter (insert k a) (f k a) m) - Map.empty - where - insert k a Nothing = Just (Map.singleton k a) - insert k a (Just m) = Just (Map.insert k a m) - -foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey -foldedAnnKeys ast = SYB.everything - Set.union - (\x -> maybe - Set.empty - Set.singleton - [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x - | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) - , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x - ] - -- for some reason, ghc-8.8 has forgotten how to infer the type of l, - -- even though it is passed to mkAnnKey above, which only accepts - -- SrcSpan. - ) - ast - where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) - - -withTransformedAnns - :: Data ast - => ast - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a - -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a -withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case - readers@(conf :+: anns :+: HNil) -> do - -- TODO: implement `local` for MultiReader/MultiRWS - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - x <- m - MultiRWSS.mPutRawR readers - pure x - where - f anns = - let - ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced - - -warnExtractorCompat :: GHC.Warn -> String -warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs deleted file mode 100644 index 37f648e..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ /dev/null @@ -1,434 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.DataDecl where - -import qualified Data.Data -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L), Located) -import qualified GHC -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - -layoutDataDecl - :: Located (TyClDecl GhcPs) - -> Located RdrName - -> LHsQTyVars GhcPs - -> HsDataDefn GhcPs - -> ToBriDocM BriDocNumbered -layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of - -- newtype MyType a b = MyType .. - HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> - case cons of - (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) - -> docWrapNode ltycl $ do - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLitS "newtype") - -- , appSep $ docLit nameStr - -- , appSep tyVarLine - -- ] - rhsDoc <- return <$> createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "newtype" - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLitS "=" - , docSeparator - , rhsDoc - ] - _ -> briDocByExactNoComment ltycl - - - -- data MyData a b - -- (zero constructors) - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> - docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - tyVarLine <- return <$> createBndrDoc bndrs - createDerivingPar mDerivs $ docSeq - [ appSep $ docLitS "data" - , lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - ] - - -- data MyData = MyData .. - -- data MyData = MyData { .. } - HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> - case cons of - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) - -> docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name - consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- return <$> createBndrDoc bndrs - forallDocMay <- case createForallDoc qvars of - Nothing -> pure Nothing - Just x -> Just . pure <$> x - rhsContextDocMay <- case mRhsContext of - Nothing -> pure Nothing - Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt - rhsDoc <- return <$> createDetailsDoc consNameStr details - consDoc <- - fmap pure - $ docNonBottomSpacing - $ case (forallDocMay, rhsContextDocMay) of - (Just forallDoc, Just rhsContextDoc) -> docLines - [ docSeq - [docLitS "=", docSeparator, docForceSingleline forallDoc] - , docSeq - [ docLitS "." - , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] - ] - ] - (Just forallDoc, Nothing) -> docLines - [ docSeq - [docLitS "=", docSeparator, docForceSingleline forallDoc] - , docSeq [docLitS ".", docSeparator, rhsDoc] - ] - (Nothing, Just rhsContextDoc) -> docSeq - [ docLitS "=" - , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] - ] - (Nothing, Nothing) -> - docSeq [docLitS "=", docSeparator, rhsDoc] - createDerivingPar mDerivs $ docAlt - [ -- data D = forall a . Show a => D a - docSeq - [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline $ lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - ] - , docLitS "=" - , docSeparator - , docSetIndentLevel $ docSeq - [ case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> - docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc - ] - ] - , -- data D - -- = forall a . Show a => D a - docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline lhsContextDoc - , appSep $ docLit nameStr - , tyVarLine - ] - ) - (docSeq - [ docLitS "=" - , docSeparator - , docSetIndentLevel $ docSeq - [ case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> - docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc - ] - ] - ) - , -- data D - -- = forall a - -- . Show a => - -- D a - docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline lhsContextDoc - , appSep $ docLit nameStr - , tyVarLine - ] - ) - consDoc - , -- data - -- Show a => - -- D - -- = forall a - -- . Show a => - -- D a - -- This alternative is only for -XDatatypeContexts. - -- But I think it is rather unlikely this will trigger without - -- -XDataTypeContexts, especially with the `docNonBottomSpacing` - -- above, so while not strictly necessary, this should not - -- hurt. - docAddBaseY BrIndentRegular $ docPar - (docLitS "data") - (docLines - [ lhsContextDoc - , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq [appSep $ docLit nameStr, tyVarLine] - , consDoc - ] - ) - ] - _ -> briDocByExactNoComment ltycl - - _ -> briDocByExactNoComment ltycl - -createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered -createContextDoc [] = docEmpty -createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] -createContextDoc (t1 : tR) = do - t1Doc <- docSharedWrapper layoutType t1 - tRDocs <- tR `forM` docSharedWrapper layoutType - docAlt - [ docSeq - [ docLitS "(" - , docForceSingleline $ docSeq $ List.intersperse - docCommaSep - (t1Doc : tRDocs) - , docLitS ") =>" - , docSeparator - ] - , docLines $ join - [ [docSeq [docLitS "(", docSeparator, t1Doc]] - , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] - , [docLitS ") =>", docSeparator] - ] - ] - -createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered -createBndrDoc bs = do - tyVarDocs <- bs `forM` \case - (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar _ _ext lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> - case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLitS "(" - , docLit vname - , docSeparator - , docLitS "::" - , docSeparator - , kind - , docLitS ")" - ] - -createDerivingPar - :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -createDerivingPar derivs mainDoc = do - case derivs of - (L _ []) -> mainDoc - (L _ types) -> - docPar mainDoc - $ docEnsureIndent BrIndentRegular - $ docLines - $ docWrapNode derivs - $ derivingClauseDoc - <$> types - -derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered -derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of - (L _ []) -> docSeq [] - (L _ ts) -> - let - tsLength = length ts - whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS "" - (lhsStrategy, rhsStrategy) = - maybe (docEmpty, docEmpty) strategyLeftRight mStrategy - in docSeq - [ docDeriving - , docWrapNodePrior types $ lhsStrategy - , docSeparator - , whenMoreThan1Type "(" - , docWrapNodeRest types - $ docSeq - $ List.intersperse docCommaSep - $ ts - <&> \case - HsIB _ t -> layoutType t - , whenMoreThan1Type ")" - , rhsStrategy - ] - where - strategyLeftRight = \case - (L _ StockStrategy) -> (docLitS " stock", docEmpty) - (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty) - (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty) - lVia@(L _ (ViaStrategy viaTypes)) -> - ( docEmpty - , case viaTypes of - HsIB _ext t -> - docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] - ) - -docDeriving :: ToBriDocM BriDocNumbered -docDeriving = docLitS "deriving" - -createDetailsDoc - :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) -createDetailsDoc consNameStr details = case details of - PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let - singleLine = docSeq - [ docLit consNameStr - , docSeparator - , docForceSingleline - $ docSeq - $ List.intersperse docSeparator - $ fmap hsScaledThing args - <&> layoutType - ] - leftIndented = - docSetParSpacing - . docAddBaseY BrIndentRegular - . docPar (docLit consNameStr) - . docLines - $ layoutType - <$> fmap hsScaledThing args - multiAppended = docSeq - [ docLit consNameStr - , docSeparator - , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args - ] - multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - (docLit consNameStr) - (docLines $ layoutType <$> fmap hsScaledThing args) - case indentPolicy of - IndentPolicyLeft -> docAlt [singleLine, leftIndented] - IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] - IndentPolicyFree -> - docAlt [singleLine, multiAppended, multiIndented, leftIndented] - RecCon (L _ []) -> - docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] - RecCon lRec@(L _ fields@(_ : _)) -> do - let ((fName1, fType1) : fDocR) = mkFieldDocs fields - -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack - let allowSingleline = False - docAddBaseY BrIndentRegular $ runFilteredAlternative $ do - -- single-line: { i :: Int, b :: Bool } - addAlternativeCond allowSingleline $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLitS "{" - , docSeparator - , docWrapNodeRest lRec - $ docForceSingleline - $ docSeq - $ join - $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] - : [ [ docLitS "," - , docSeparator - , fName - , docSeparator - , docLitS "::" - , docSeparator - , fType - ] - | (fName, fType) <- fDocR - ] - , docSeparator - , docLitS "}" - ] - addAlternative $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines - [ docAlt - [ docCols - ColRecDecl - [ appSep (docLitS "{") - , appSep $ docForceSingleline fName1 - , docSeq [docLitS "::", docSeparator] - , docForceSingleline $ fType1 - ] - , docSeq - [ docLitS "{" - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName1 - (docSeq [docLitS "::", docSeparator, fType1]) - ] - ] - , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> - docAlt - [ docCols - ColRecDecl - [ docCommaSep - , appSep $ docForceSingleline fName - , docSeq [docLitS "::", docSeparator] - , docForceSingleline fType - ] - , docSeq - [ docLitS "," - , docSeparator - , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar - fName - (docSeq [docLitS "::", docSeparator, fType]) - ] - ] - , docLitS "}" - ] - ) - InfixCon arg1 arg2 -> docSeq - [ layoutType $ hsScaledThing arg1 - , docSeparator - , docLit consNameStr - , docSeparator - , layoutType $ hsScaledThing arg2 - ] - where - mkFieldDocs - :: [LConDeclField GhcPs] - -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] - mkFieldDocs = fmap $ \lField -> case lField of - L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t - -createForallDoc - :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) -createForallDoc [] = Nothing -createForallDoc lhsTyVarBndrs = - Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] - -createNamesAndTypeDoc - :: Data.Data.Data ast - => Located ast - -> [GenLocated t (FieldOcc GhcPs)] - -> Located (HsType GhcPs) - -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -createNamesAndTypeDoc lField names t = - ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq - [ docSeq $ List.intersperse docCommaSep $ names <&> \case - L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName - ] - , docWrapNodeRest lField $ layoutType t - ) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs deleted file mode 100644 index 9e22b6e..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ /dev/null @@ -1,998 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.Layouters.Decl where - -import qualified Data.Data -import qualified Data.Foldable -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Data.Bag (bagToList, emptyBag) -import qualified GHC.Data.FastString as FastString -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic - ( Activation(..) - , InlinePragma(..) - , InlineSpec(..) - , LexicalFixity(..) - , RuleMatchInfo(..) - ) -import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.DataDecl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey) -import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint - - - -layoutDecl :: ToBriDoc HsDecl -layoutDecl d@(L loc decl) = case decl of - SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig) - ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case - Left ns -> docLines $ return <$> ns - Right n -> return n - TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) - InstD _ (TyFamInstD _ tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False d tfid - InstD _ (ClsInstD _ inst) -> - withTransformedAnns d $ layoutClsInst (L loc inst) - _ -> briDocByExactNoComment d - --------------------------------------------------------------------------------- --- Sig --------------------------------------------------------------------------------- - -layoutSig :: ToBriDoc Sig -layoutSig lsig@(L _loc sig) = case sig of - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ - InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> - docWrapNode lsig $ do - nameStr <- lrdrNameToTextAnn name - specStr <- specStringCompat lsig spec - let - phaseStr = case phaseAct of - NeverActive -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default - AlwaysActive -> "" - ActiveBefore _ i -> "[~" ++ show i ++ "] " - ActiveAfter _ i -> "[" ++ show i ++ "] " - FinalActive -> error "brittany internal error: FinalActive" - let - conlikeStr = case conlike of - FunLike -> "" - ConLike -> "CONLIKE " - docLit - $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) - <> nameStr - <> Text.pack " #-}" - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ - PatSynSig _ names (HsIB _ typ) -> - layoutNamesAndType (Just "pattern") names typ - _ -> briDocByExactNoComment lsig -- TODO - where - layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do - let - keyDoc = case mKeyword of - Just key -> [appSep . docLit $ Text.pack key] - Nothing -> [] - nameStrs <- names `forM` lrdrNameToTextAnn - let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsBelow lsig - shouldBeHanging <- - mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack - if shouldBeHanging - then - docSeq - $ [ appSep - $ docWrapNodeRest lsig - $ docSeq - $ keyDoc - <> [docLit nameStr] - , docSetBaseY $ docLines - [ docCols - ColTyOpPrefix - [ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) $ typeDoc - ] - ] - ] - else layoutLhsAndType - hasComments - (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) - "::" - typeDoc - -specStringCompat - :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String -specStringCompat ast = \case - NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> "" - Inline -> pure "INLINE " - Inlinable -> pure "INLINABLE " - NoInline -> pure "NOINLINE " - -layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs)) -layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of - BodyStmt _ body _ _ -> layoutExpr body - BindStmt _ lPat expr -> do - patDoc <- docSharedWrapper layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docCols - ColBindStmt - [ appSep $ colsWrapPat =<< patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] - ] - _ -> unknownNodeError "" lgstmt -- TODO - - --------------------------------------------------------------------------------- --- HsBind --------------------------------------------------------------------------------- - -layoutBind - :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) -layoutBind lbind@(L _ bind) = case bind of - FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do - idStr <- lrdrNameToTextAnn fId - binderDoc <- docLit $ Text.pack "=" - funcPatDocs <- - docWrapNode lbind - $ docWrapNode lmatches - $ layoutPatternBind (Just idStr) binderDoc - `mapM` matches - return $ Left $ funcPatDocs - PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do - patDocs <- colsWrapPat =<< layoutPat pat - clauseDocs <- layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? - binderDoc <- docLit $ Text.pack "=" - hasComments <- hasAnyCommentsBelow lbind - fmap Right $ docWrapNode lbind $ layoutPatternBindFinal - Nothing - binderDoc - (Just patDocs) - clauseDocs - mWhereArg - hasComments - PatSynBind _ (PSB _ patID lpat rpat dir) -> do - fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat - _ -> Right <$> unknownNodeError "" lbind -layoutIPBind :: ToBriDoc IPBind -layoutIPBind lipbind@(L _ bind) = case bind of - IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right" - IPBind _ (Left (L _ (HsIPName name))) expr -> do - ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name - binderDoc <- docLit $ Text.pack "=" - exprDoc <- layoutExpr expr - hasComments <- hasAnyCommentsBelow lipbind - layoutPatternBindFinal - Nothing - binderDoc - (Just ipName) - [([], exprDoc, expr)] - Nothing - hasComments - - -data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) - | BagSig (LSig GhcPs) - -bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan -bindOrSigtoSrcSpan (BagBind (L l _)) = l -bindOrSigtoSrcSpan (BagSig (L l _)) = l - -layoutLocalBinds - :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered]) -layoutLocalBinds lbinds@(L _ binds) = case binds of - -- HsValBinds (ValBindsIn lhsBindsLR []) -> - -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering - -- x@(HsValBinds (ValBindsIn{})) -> - -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x - HsValBinds _ (ValBinds _ bindlrs sigs) -> do - let - unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered - docs <- docWrapNode lbinds $ join <$> ordered `forM` \case - BagBind b -> either id return <$> layoutBind b - BagSig s -> return <$> layoutSig s - return $ Just $ docs --- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> - HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" - HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb - EmptyLocalBinds{} -> return $ Nothing - --- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is --- parSpacing stuff.B -layoutGrhs - :: LGRHS GhcPs (LHsExpr GhcPs) - -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs) -layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do - guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards - bodyDoc <- layoutExpr body - return (guardDocs, bodyDoc, body) - -layoutPatternBind - :: Maybe Text - -> BriDocNumbered - -> LMatch GhcPs (LHsExpr GhcPs) - -> ToBriDocM BriDocNumbered -layoutPatternBind funId binderDoc lmatch@(L _ match) = do - let pats = m_pats match - let (GRHSs _ grhss whereBinds) = m_grhss match - patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p - let isInfix = isInfixMatch match - mIdStr <- case match of - Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId - _ -> pure Nothing - let mIdStr' = fixPatternBindIdentifier match <$> mIdStr - patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1 : p2 : pr) | isInfix -> if null pr - then docCols - ColPatternsFuncInfix - [ appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - ] - else docCols - ColPatternsFuncInfix - ([ docCols - ColPatterns - [ docParenL - , appSep $ docForceSingleline p1 - , appSep $ docLit $ idStr - , docForceSingleline p2 - , appSep $ docParenR - ] - ] - ++ (spacifyDocs $ docForceSingleline <$> pr) - ) - (Just idStr, []) -> docLit idStr - (Just idStr, ps) -> - docCols ColPatternsFuncPrefix - $ appSep (docLit $ idStr) - : (spacifyDocs $ docForceSingleline <$> ps) - (Nothing, ps) -> - docCols ColPatterns - $ (List.intersperse docSeparator $ docForceSingleline <$> ps) - clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss - mWhereDocs <- layoutLocalBinds whereBinds - let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) - let alignmentToken = if null pats then Nothing else funId - hasComments <- hasAnyCommentsBelow lmatch - layoutPatternBindFinal - alignmentToken - binderDoc - (Just patDoc) - clauseDocs - mWhereArg - hasComments - -fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text -fixPatternBindIdentifier match idStr = go $ m_ctxt match - where - go = \case - (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr - (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr - (FunRhs _ _ NoSrcStrict) -> idStr - (StmtCtxt ctx1) -> goInner ctx1 - _ -> idStr - -- I have really no idea if this path ever occurs, but better safe than - -- risking another "drop bangpatterns" bugs. - goInner = \case - (PatGuard ctx1) -> go ctx1 - (ParStmtCtxt ctx1) -> goInner ctx1 - (TransStmtCtxt ctx1) -> goInner ctx1 - _ -> idStr - -layoutPatternBindFinal - :: Maybe Text - -> BriDocNumbered - -> Maybe BriDocNumbered - -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) - -- ^ AnnKey for the node that contains the AnnWhere position annotation - -> Bool - -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments - = do - let - patPartInline = case mPatDoc of - Nothing -> [] - Just patDoc -> [appSep $ docForceSingleline $ return patDoc] - patPartParWrap = case mPatDoc of - Nothing -> id - Just patDoc -> docPar (return patDoc) - whereIndent <- do - shouldSpecial <- - mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack - regularIndentAmount <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - pure $ if shouldSpecial - then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) - else BrIndentRegular - -- TODO: apart from this, there probably are more nodes below which could - -- be shared between alternatives. - wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of - Nothing -> return $ [] - Just (annKeyWhere, [w]) -> pure . pure <$> docAlt - [ docEnsureIndent BrIndentRegular - $ docSeq - [ docLit $ Text.pack "where" - , docSeparator - , docForceSingleline $ return w - ] - , docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ return w - ] - ] - Just (annKeyWhere, ws) -> - fmap (pure . pure) - $ docMoveToKWDP annKeyWhere AnnWhere False - $ docEnsureIndent whereIndent - $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws - ] - let - singleLineGuardsDoc guards = appSep $ case guards of - [] -> docEmpty - [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] - gs -> - docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse - docCommaSep - (docForceSingleline . return <$> gs) - ) - wherePart = case mWhereDocs of - Nothing -> Just docEmpty - Just (_, [w]) -> Just $ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - _ -> Nothing - - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - - runFilteredAlternative $ do - - case clauseDocs of - [(guards, body, _bodyRaw)] -> do - let guardPart = singleLineGuardsDoc guards - forM_ wherePart $ \wherePart' -> - -- one-line solution - addAlternativeCond (not hasComments) $ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return body - , wherePart' - ] - ] - -- one-line solution + where in next line(s) - addAlternativeCond (Data.Maybe.isJust mWhereDocs) - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body - ] - ] - ] - ++ wherePartMultiLine - -- two-line solution + where in next line(s) - addAlternative - $ docLines - $ [ docForceSingleline - $ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docEnsureIndent BrIndentRegular $ docForceSingleline $ return - body - ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body as par; - -- where in following lines - addAlternative - $ docLines - $ [ docCols - (ColBindingLine alignmentToken) - [ docSeq (patPartInline ++ [guardPart]) - , docSeq - [ appSep $ return binderDoc - , docForceParSpacing $ docAddBaseY BrIndentRegular $ return - body - ] - ] - ] - -- , lineMod $ docAlt - -- [ docSetBaseY $ return body - -- , docAddBaseY BrIndentRegular $ return body - -- ] - ++ wherePartMultiLine - -- pattern and exactly one clause in single line, body in new line. - addAlternative - $ docLines - $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) - , docNonBottomSpacing - $ docEnsureIndent BrIndentRegular - $ docAddBaseY BrIndentRegular - $ return body - ] - ++ wherePartMultiLine - - _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1` - - case mPatDoc of - Nothing -> return () - Just patDoc -> - -- multiple clauses added in-paragraph, each in a single line - -- example: foo | bar = baz - -- | lll = asd - addAlternativeCond (indentPolicy == IndentPolicyFree) - $ docLines - $ [ docSeq - [ appSep $ docForceSingleline $ return patDoc - , docSetBaseY - $ docLines - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each in a separate, single line - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> do - let guardPart = singleLineGuardsDoc guardDocs - -- the docForceSingleline might seems superflous, but it - -- helps the alternative resolving impl. - docForceSingleline $ docCols - ColGuardedBody - [ guardPart - , docSeq - [ appSep $ return binderDoc - , docForceSingleline $ return bodyDoc - -- i am not sure if there is a benefit to using - -- docForceParSpacing additionally here: - -- , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - <&> \(guardDocs, bodyDoc, _) -> - docSeq - $ (case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline $ docSeq - [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docSeparator - , docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- multiple clauses, each with the guard(s) in a single line, body - -- in a new line as a paragraph - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - (case guardDocs of - [] -> [] - [g] -> - [ docForceSingleline - $ docSeq [appSep $ docLit $ Text.pack "|", return g] - ] - gs -> - [ docForceSingleline - $ docSeq - $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) - ] - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular - $ docForceParSpacing - $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - -- conservative approach: everything starts on the left. - addAlternative - $ docLines - $ [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines - $ map docSetBaseY - $ clauseDocs - >>= \(guardDocs, bodyDoc, _) -> - (case guardDocs of - [] -> [] - [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] - (g1 : gr) -> - (docSeq [appSep $ docLit $ Text.pack "|", return g1] - : (gr <&> \g -> - docSeq [appSep $ docLit $ Text.pack ",", return g] - ) - ) - ) - ++ [ docCols - ColOpPrefix - [ appSep $ return binderDoc - , docAddBaseY BrIndentRegular $ return bodyDoc - ] - ] - ] - ++ wherePartMultiLine - --- | Layout a pattern synonym binding -layoutPatSynBind - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) - -> HsPatSynDir GhcPs - -> LPat GhcPs - -> ToBriDocM BriDocNumbered -layoutPatSynBind name patSynDetails patDir rpat = do - let - patDoc = docLit $ Text.pack "pattern" - binderDoc = case patDir of - ImplicitBidirectional -> docLit $ Text.pack "=" - _ -> docLit $ Text.pack "<-" - body = colsWrapPat =<< layoutPat rpat - whereDoc = docLit $ Text.pack "where" - mWhereDocs <- layoutPatSynWhere patDir - headDoc <- - fmap pure - $ docSeq - $ [ patDoc - , docSeparator - , layoutLPatSyn name patSynDetails - , docSeparator - , binderDoc - ] - runFilteredAlternative $ do - addAlternative - $ - -- pattern .. where - -- .. - -- .. - docAddBaseY BrIndentRegular - $ docSeq - ([headDoc, docSeparator, body] ++ case mWhereDocs of - Just ds -> [docSeparator, docPar whereDoc (docLines ds)] - Nothing -> [] - ) - addAlternative - $ - -- pattern .. = - -- .. - -- pattern .. <- - -- .. where - -- .. - -- .. - docAddBaseY BrIndentRegular - $ docPar - headDoc - (case mWhereDocs of - Nothing -> body - Just ds -> docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds) - ) - --- | Helper method for the left hand side of a pattern synonym -layoutLPatSyn - :: Located (IdP GhcPs) - -> HsPatSynDetails (Located (IdP GhcPs)) - -> ToBriDocM BriDocNumbered -layoutLPatSyn name (PrefixCon vars) = do - docName <- lrdrNameToTextAnn name - names <- mapM lrdrNameToTextAnn vars - docSeq . fmap appSep $ docLit docName : (docLit <$> names) -layoutLPatSyn name (InfixCon left right) = do - leftDoc <- lrdrNameToTextAnn left - docName <- lrdrNameToTextAnn name - rightDoc <- lrdrNameToTextAnn right - docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] -layoutLPatSyn name (RecCon recArgs) = do - docName <- lrdrNameToTextAnn name - args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs - docSeq - . fmap docLit - $ [docName, Text.pack " { "] - <> intersperse (Text.pack ", ") args - <> [Text.pack " }"] - --- | Helper method to get the where clause from of explicitly bidirectional --- pattern synonyms -layoutPatSynWhere - :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) -layoutPatSynWhere hs = case hs of - ExplicitBidirectional (MG _ (L _ lbinds) _) -> do - binderDoc <- docLit $ Text.pack "=" - Just - <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds - _ -> pure Nothing - --------------------------------------------------------------------------------- --- TyClDecl --------------------------------------------------------------------------------- - -layoutTyCl :: ToBriDoc TyClDecl -layoutTyCl ltycl@(L _loc tycl) = case tycl of - SynDecl _ name vars fixity typ -> do - let - isInfix = case fixity of - Prefix -> False - Infix -> True - -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP - -- let parenWrapper = if hasTrailingParen - -- then appSep . docWrapNodeRest ltycl - -- else id - let wrapNodeRest = docWrapNodeRest ltycl - docWrapNodePrior ltycl - $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ - DataDecl _ext name tyVars _ dataDefn -> - layoutDataDecl ltycl name tyVars dataDefn - _ -> briDocByExactNoComment ltycl - -layoutSynDecl - :: Bool - -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) - -> Located (IdP GhcPs) - -> [LHsTyVarBndr () GhcPs] - -> LHsType GhcPs - -> ToBriDocM BriDocNumbered -layoutSynDecl isInfix wrapNodeRest name vars typ = do - nameStr <- lrdrNameToTextAnn name - let - lhs = appSep . wrapNodeRest $ if isInfix - then do - let (a : b : rest) = vars - hasOwnParens <- hasAnnKeywordComment a AnnOpenP - -- This isn't quite right, but does give syntactically valid results - let needsParens = not (null rest) || hasOwnParens - docSeq - $ [docLit $ Text.pack "type", docSeparator] - ++ [ docParenL | needsParens ] - ++ [ layoutTyVarBndr False a - , docSeparator - , docLit nameStr - , docSeparator - , layoutTyVarBndr False b - ] - ++ [ docParenR | needsParens ] - ++ fmap (layoutTyVarBndr True) rest - else - docSeq - $ [ docLit $ Text.pack "type" - , docSeparator - , docWrapNode name $ docLit nameStr - ] - ++ fmap (layoutTyVarBndr True) vars - sharedLhs <- docSharedWrapper id lhs - typeDoc <- docSharedWrapper layoutType typ - hasComments <- hasAnyCommentsConnected typ - layoutLhsAndType hasComments sharedLhs "=" typeDoc - -layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ()) -layoutTyVarBndr needsSep lbndr@(L _ bndr) = do - docWrapNodePrior lbndr $ case bndr of - UserTyVar _ _ name -> do - nameStr <- lrdrNameToTextAnn name - docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] - KindedTyVar _ _ name kind -> do - nameStr <- lrdrNameToTextAnn name - docSeq - $ [ docSeparator | needsSep ] - ++ [ docLit $ Text.pack "(" - , appSep $ docLit nameStr - , appSep . docLit $ Text.pack "::" - , docForceSingleline $ layoutType kind - , docLit $ Text.pack ")" - ] - - --------------------------------------------------------------------------------- --- TyFamInstDecl --------------------------------------------------------------------------------- - - - -layoutTyFamInstDecl - :: Data.Data.Data a - => Bool - -> Located a - -> TyFamInstDecl GhcPs - -> ToBriDocM BriDocNumbered -layoutTyFamInstDecl inClass outerNode tfid = do - let - FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid - -- bndrsMay isJust e.g. with - -- type instance forall a . MyType (Maybe a) = Either () a - innerNode = outerNode - docWrapNodePrior outerNode $ do - nameStr <- lrdrNameToTextAnn name - needsParens <- hasAnnKeyword outerNode AnnOpenP - let - instanceDoc = if inClass - then docLit $ Text.pack "type" - else docSeq - [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"] - makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered - makeForallDoc bndrs = do - bndrDocs <- layoutTyVarBndrs bndrs - docSeq - ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs - ) - lhs = - docWrapNode innerNode - . docSeq - $ [appSep instanceDoc] - ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] - ++ [ docParenL | needsParens ] - ++ [appSep $ docWrapNode name $ docLit nameStr] - ++ intersperse docSeparator (layoutHsTyPats pats) - ++ [ docParenR | needsParens ] - hasComments <- - (||) - <$> hasAnyRegularCommentsConnected outerNode - <*> hasAnyRegularCommentsRest innerNode - typeDoc <- docSharedWrapper layoutType typ - layoutLhsAndType hasComments lhs "=" typeDoc - - -layoutHsTyPats - :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] -layoutHsTyPats pats = pats <&> \case - HsValArg tm -> layoutType tm - HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] - -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change - -- is a bit strange. Hopefully this does not ignore any important - -- annotations. - HsArgPar _l -> error "brittany internal error: HsArgPar{}" - --------------------------------------------------------------------------------- --- ClsInstDecl --------------------------------------------------------------------------------- - --- | Layout an @instance@ declaration --- --- Layout signatures and bindings using the corresponding layouters from the --- top-level. Layout the instance head, type family instances, and data family --- instances using ExactPrint. -layoutClsInst :: ToBriDoc ClsInstDecl -layoutClsInst lcid@(L _ cid) = docLines - [ layoutInstanceHead - , docEnsureIndent BrIndentRegular - $ docSetIndentLevel - $ docSortedLines - $ fmap layoutAndLocateSig (cid_sigs cid) - ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid) - ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid) - ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid) - ] - where - layoutInstanceHead :: ToBriDocM BriDocNumbered - layoutInstanceHead = - briDocByExactNoComment - $ InstD NoExtField - . ClsInstD NoExtField - . removeChildren - <$> lcid - - removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs - removeChildren c = c - { cid_binds = emptyBag - , cid_sigs = [] - , cid_tyfam_insts = [] - , cid_datafam_insts = [] - } - - -- | Like 'docLines', but sorts the lines based on location - docSortedLines - :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered - docSortedLines l = - allocateNode - . BDFLines - . fmap unLoc - . List.sortOn (ExactPrint.rs . getLoc) - =<< sequence l - - layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) - layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig - - layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered) - layoutAndLocateBind lbind@(L loc _) = - L loc <$> (joinBinds =<< layoutBind lbind) - - joinBinds - :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered - joinBinds = \case - Left ns -> docLines $ return <$> ns - Right n -> return n - - layoutAndLocateTyFamInsts - :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateTyFamInsts ltfid@(L loc tfid) = - L loc <$> layoutTyFamInstDecl True ltfid tfid - - layoutAndLocateDataFamInsts - :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateDataFamInsts ldfid@(L loc _) = - L loc <$> layoutDataFamInstDecl ldfid - - -- | Send to ExactPrint then remove unecessary whitespace - layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl - layoutDataFamInstDecl ldfid = - fmap stripWhitespace <$> briDocByExactNoComment ldfid - - -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations - stripWhitespace :: BriDocF f -> BriDocF f - stripWhitespace (BDFExternal ann anns b t) = - BDFExternal ann anns b $ stripWhitespace' t - stripWhitespace b = b - - -- | This fixes two issues of output coming from Exactprinting - -- associated (data) type decls. Firstly we place the output into docLines, - -- so one newline coming from Exactprint is superfluous, so we drop the - -- first (empty) line. The second issue is Exactprint indents the first - -- member in a strange fashion: - -- - -- input: - -- - -- > instance MyClass Int where - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- output of just exactprinting the associated data type syntax node - -- - -- > - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- To fix this, we strip whitespace from the start of the comments and the - -- first line of the declaration, stopping when we see "data" or "type" at - -- the start of a line. I.e., this function yields - -- - -- > -- | This data is very important - -- > data MyData = IntData - -- > { intData :: String - -- > , intData2 :: Int - -- > } - -- - -- Downside apart from being a hacky and brittle fix is that this removes - -- possible additional indentation from comments before the first member. - -- - -- But the whole thing is just a temporary measure until brittany learns - -- to layout data/type decls. - stripWhitespace' :: Text -> Text - stripWhitespace' t = - Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t - where - go [] = [] - go (line1 : lineR) = case Text.stripStart line1 of - st - | isTypeOrData st -> st : lineR - | otherwise -> st : go lineR - isTypeOrData t' = - (Text.pack "type" `Text.isPrefixOf` t') - || (Text.pack "newtype" `Text.isPrefixOf` t') - || (Text.pack "data" `Text.isPrefixOf` t') - - --------------------------------------------------------------------------------- --- Common Helpers --------------------------------------------------------------------------------- - -layoutLhsAndType - :: Bool - -> ToBriDocM BriDocNumbered - -> String - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -layoutLhsAndType hasComments lhs sep typeDoc = do - runFilteredAlternative $ do - -- (separators probably are "=" or "::") - -- lhs = type - -- lhs :: type - addAlternativeCond (not hasComments) $ docSeq - [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] - -- lhs - -- :: typeA - -- -> typeB - -- lhs - -- = typeA - -- -> typeB - addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols - ColTyOpPrefix - [ appSep $ docLitS sep - , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc - ] diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs deleted file mode 100644 index 138a748..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ /dev/null @@ -1,1086 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Expr where - -import qualified Data.Data -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan) -import qualified GHC.Data.FastString as FastString -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Types.Name -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Layouters.Stmt -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -layoutExpr :: ToBriDoc HsExpr -layoutExpr lexpr@(L _ expr) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let allowFreeIndent = indentPolicy == IndentPolicyFree - docWrapNode lexpr $ case expr of - HsVar _ vname -> do - docLit =<< lrdrNameToTextAnn vname - HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname - HsRecFld{} -> do - -- TODO - briDocByExactInlineOnly "HsRecFld" lexpr - HsOverLabel _ext _reboundFromLabel name -> - let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label - HsIPVar _ext (HsIPName name) -> - let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label - HsOverLit _ olit -> do - allocateNode $ overLitValBriDoc $ ol_val olit - HsLit _ lit -> do - allocateNode $ litBriDoc lit - HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _) - | pats <- m_pats match - , GRHSs _ [lgrhs] llocals <- m_grhss match - , L _ EmptyLocalBinds{} <- llocals - , L _ (GRHS _ [] body) <- lgrhs - -> do - patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) -> - fmap return $ do - -- this code could be as simple as `colsWrapPat =<< layoutPat p` - -- if it was not for the following two cases: - -- \ !x -> x - -- \ ~x -> x - -- These make it necessary to special-case an additional separator. - -- (TODO: we create a BDCols here, but then make it ineffective - -- by wrapping it in docSeq below. We _could_ add alignments for - -- stuff like lists-of-lambdas. Nothing terribly important..) - let - shouldPrefixSeparator = case p of - L _ LazyPat{} -> isFirst - L _ BangPat{} -> isFirst - _ -> False - patDocSeq <- layoutPat p - fixed <- case Seq.viewl patDocSeq of - p1 Seq.:< pr | shouldPrefixSeparator -> do - p1' <- docSeq [docSeparator, pure p1] - pure (p1' Seq.<| pr) - _ -> pure patDocSeq - colsWrapPat fixed - bodyDoc <- - docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body - let - funcPatternPartLine = docCols - ColCasePattern - (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) - docAlt - [ -- single line - docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceSingleline bodyDoc - ] - -- double line - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docForceSingleline bodyDoc) - -- wrapped par spacing - , docSetParSpacing $ docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ docForceSingleline funcPatternPartLine - , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ docForceParSpacing bodyDoc - ] - -- conservative - , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ appSep $ docForceSingleline - funcPatternPartLine - , docLit $ Text.pack "->" - ] - ) - (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) - ] - HsLam{} -> unknownNodeError "HsLam too complex" lexpr - HsLamCase _ (MG _ (L _ []) _) -> do - docSetParSpacing - $ docAddBaseY BrIndentRegular - $ (docLit $ Text.pack "\\case {}") - HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "\\case") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) - HsApp _ exp1@(L _ HsApp{}) exp2 -> do - let - gather - :: [LHsExpr GhcPs] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [LHsExpr GhcPs]) - gather list = \case - L _ (HsApp _ l r) -> gather (r : list) l - x -> (x, list) - let (headE, paramEs) = gather [exp2] exp1 - let - colsOrSequence = case headE of - L _ (HsVar _ (L _ (Unqual occname))) -> - docCols (ColApp $ Text.pack $ occNameString occname) - _ -> docSeq - headDoc <- docSharedWrapper layoutExpr headE - paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs - hasComments <- hasAnyCommentsConnected exp2 - runFilteredAlternative $ do - -- foo x y - addAlternativeCond (not hasComments) - $ colsOrSequence - $ appSep (docForceSingleline headDoc) - : spacifyDocs (docForceSingleline <$> paramDocs) - -- foo x - -- y - addAlternativeCond allowFreeIndent $ docSeq - [ appSep (docForceSingleline headDoc) - , docSetBaseY - $ docAddBaseY BrIndentRegular - $ docLines - $ docForceSingleline - <$> paramDocs - ] - -- foo - -- x - -- y - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docForceSingleline headDoc) - (docNonBottomSpacing $ docLines paramDocs) - -- ( multi - -- line - -- function - -- ) - -- x - -- y - addAlternative $ docAddBaseY BrIndentRegular $ docPar - headDoc - (docNonBottomSpacing $ docLines paramDocs) - HsApp _ exp1 exp2 -> do - -- TODO: if expDoc1 is some literal, we may want to create a docCols here. - expDoc1 <- docSharedWrapper layoutExpr exp1 - expDoc2 <- docSharedWrapper layoutExpr exp2 - docAlt - [ -- func arg - docSeq - [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] - , -- func argline1 - -- arglines - -- e.g. - -- func Abc - -- { member1 = True - -- , member2 = 13 - -- } - docSetParSpacing -- this is most likely superfluous because - -- this is a sequence of a one-line and a par-space - -- anyways, so it is _always_ par-spaced. - $ docAddBaseY BrIndentRegular - $ docSeq - [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2] - , -- func - -- arg - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docForceSingleline expDoc1) - (docNonBottomSpacing expDoc2) - , -- fu - -- nc - -- ar - -- gument - docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2 - ] - HsAppType _ exp1 (HsWC _ ty1) -> do - t <- docSharedWrapper layoutType ty1 - e <- docSharedWrapper layoutExpr exp1 - docAlt - [ docSeq - [ docForceSingleline e - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline t - ] - , docPar e (docSeq [docLit $ Text.pack "@", t]) - ] - OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do - let - gather - :: [(LHsExpr GhcPs, LHsExpr GhcPs)] - -> LHsExpr GhcPs - -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)]) - gather opExprList = \case - (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1 - final -> (final, opExprList) - (leftOperand, appList) = gather [] expLeft - leftOperandDoc <- docSharedWrapper layoutExpr leftOperand - appListDocs <- appList `forM` \(x, y) -> - [ (xD, yD) - | xD <- docSharedWrapper layoutExpr x - , yD <- docSharedWrapper layoutExpr y - ] - opLastDoc <- docSharedWrapper layoutExpr expOp - expLastDoc <- docSharedWrapper layoutExpr expRight - allowSinglelinePar <- do - hasComLeft <- hasAnyCommentsConnected expLeft - hasComOp <- hasAnyCommentsConnected expOp - pure $ not hasComLeft && not hasComOp - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - runFilteredAlternative $ do - -- > one + two + three - -- or - -- > one + two + case x of - -- > _ -> three - addAlternativeCond allowSinglelinePar $ docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq $ appListDocs <&> \(od, ed) -> docSeq - [appSep $ docForceSingleline od, appSep $ docForceSingleline ed] - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - -- this case rather leads to some unfortunate layouting than to anything - -- useful; disabling for now. (it interfers with cols stuff.) - -- addAlternative - -- $ docSetBaseY - -- $ docPar - -- leftOperandDoc - -- ( docLines - -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) - -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - -- ) - -- > one - -- > + two - -- > + three - addAlternative $ docPar - leftOperandDoc - (docLines - $ (appListDocs <&> \(od, ed) -> - docCols ColOpPrefix [appSep od, docSetBaseY ed] - ) - ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] - ) - OpApp _ expLeft expOp expRight -> do - expDocLeft <- docSharedWrapper layoutExpr expLeft - expDocOp <- docSharedWrapper layoutExpr expOp - expDocRight <- docSharedWrapper layoutExpr expRight - let - allowPar = case (expOp, expRight) of - (L _ (HsVar _ (L _ (Unqual occname))), _) - | occNameString occname == "$" -> True - (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False - _ -> True - let - leftIsDoBlock = case expLeft of - L _ HsDo{} -> True - _ -> False - runFilteredAlternative $ do - -- one-line - addAlternative $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceSingleline expDocRight - ] - -- -- line + freely indented block for right expression - -- addAlternative - -- $ docSeq - -- [ appSep $ docForceSingleline expDocLeft - -- , appSep $ docForceSingleline expDocOp - -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight - -- ] - -- two-line - addAlternative $ do - let - expDocOpAndRight = docForceSingleline $ docCols - ColOpPrefix - [appSep $ expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight - -- TODO: in both cases, we don't force expDocLeft to be - -- single-line, which has certain.. interesting consequences. - -- At least, the "two-line" label is not entirely - -- accurate. - -- one-line + par - addAlternativeCond allowPar $ docSeq - [ appSep $ docForceSingleline expDocLeft - , appSep $ docForceSingleline expDocOp - , docForceParSpacing expDocRight - ] - -- more lines - addAlternative $ do - let - expDocOpAndRight = - docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] - if leftIsDoBlock - then docLines [expDocLeft, expDocOpAndRight] - else docAddBaseY BrIndentRegular - $ docPar expDocLeft expDocOpAndRight - NegApp _ op _ -> do - opDoc <- docSharedWrapper layoutExpr op - docSeq [docLit $ Text.pack "-", opDoc] - HsPar _ innerExp -> do - innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp - docAlt - [ docSeq - [ docLit $ Text.pack "(" - , docForceSingleline innerExpDoc - , docLit $ Text.pack ")" - ] - , docSetBaseY $ docLines - [ docCols - ColOpPrefix - [ docLit $ Text.pack "(" - , docAddBaseY (BrIndentSpecial 2) innerExpDoc - ] - , docLit $ Text.pack ")" - ] - ] - SectionL _ left op -> do -- TODO: add to testsuite - leftDoc <- docSharedWrapper layoutExpr left - opDoc <- docSharedWrapper layoutExpr op - docSeq [leftDoc, docSeparator, opDoc] - SectionR _ op right -> do -- TODO: add to testsuite - opDoc <- docSharedWrapper layoutExpr op - rightDoc <- docSharedWrapper layoutExpr right - docSeq [opDoc, docSeparator, rightDoc] - ExplicitTuple _ args boxity -> do - let - argExprs = args <&> \arg -> case arg of - (L _ (Present _ e)) -> (arg, Just e) - (L _ (Missing NoExtField)) -> (arg, Nothing) - argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> - docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- - orM - (hasCommentsBetween lexpr AnnOpenP AnnCloseP - : map hasAnyCommentsBelow args - ) - let - (openLit, closeLit) = case boxity of - Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") - Unboxed -> (docParenHashLSep, docParenHashRSep) - case splitFirstLast argDocs of - FirstLastEmpty -> - docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit] - FirstLastSingleton e -> docAlt - [ docCols - ColTuple - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - , closeLit - ] - , docSetBaseY $ docLines - [ docSeq - [ openLit - , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e - ] - , closeLit - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docCols ColTuple - $ [docSeq [openLit, docForceSingleline e1]] - ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) - ++ [ docSeq - [ docCommaSep - , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN) - , closeLit - ] - ] - addAlternative - $ let - start = docCols ColTuples [appSep openLit, e1] - linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d] - lineN = docCols - ColTuples - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] - end = closeLit - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end] - HsCase _ cExp (MG _ (L _ []) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - docAlt - [ docAddBaseY BrIndentRegular $ docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of {}" - ] - , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docLit $ Text.pack "of {}") - ] - HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do - cExpDoc <- docSharedWrapper layoutExpr cExp - binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- - docWrapNode lmatches - $ layoutPatternBind Nothing binderDoc - `mapM` matches - docAlt - [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ appSep $ docLit $ Text.pack "case" - , appSep $ docForceSingleline cExpDoc - , docLit $ Text.pack "of" - ] - ) - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) - , docPar - (docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "case") cExpDoc - ) - (docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "of") - (docSetBaseAndIndent - $ docNonBottomSpacing - $ docLines - $ return - <$> funcPatDocs - ) - ) - ] - HsIf _ ifExpr thenExpr elseExpr -> do - ifExprDoc <- docSharedWrapper layoutExpr ifExpr - thenExprDoc <- docSharedWrapper layoutExpr thenExpr - elseExprDoc <- docSharedWrapper layoutExpr elseExpr - hasComments <- hasAnyCommentsBelow lexpr - let - maySpecialIndent = case indentPolicy of - IndentPolicyLeft -> BrIndentRegular - IndentPolicyMultiple -> BrIndentRegular - IndentPolicyFree -> BrIndentSpecial 3 - -- TODO: some of the alternatives (especially last and last-but-one) - -- overlap. - docSetIndentLevel $ runFilteredAlternative $ do - -- if _ then _ else _ - addAlternativeCond (not hasComments) $ docSeq - [ appSep $ docLit $ Text.pack "if" - , appSep $ docForceSingleline ifExprDoc - , appSep $ docLit $ Text.pack "then" - , appSep $ docForceSingleline thenExprDoc - , appSep $ docLit $ Text.pack "else" - , docForceSingleline elseExprDoc - ] - -- either - -- if expr - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if expr - -- then - -- stuff - -- else - -- stuff - -- note that this has par-spacing - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc - ] - ) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docNonBottomSpacing - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ] - ) - -- either - -- if multi - -- line - -- condition - -- then foo - -- bar - -- else foo - -- bar - -- or - -- if multi - -- line - -- condition - -- then - -- stuff - -- else - -- stuff - -- note that this does _not_ have par-spacing - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - ) - (docLines - [ docAddBaseY BrIndentRegular - $ docNodeAnnKW lexpr (Just AnnThen) - $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "then" - , docForceParSpacing thenExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - ] - , docAddBaseY BrIndentRegular $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "else" - , docForceParSpacing elseExprDoc - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - ] - ) - addAlternative $ docSetBaseY $ docLines - [ docAddBaseY maySpecialIndent $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" - , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc - ] - , docNodeAnnKW lexpr (Just AnnThen) - $ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "then") thenExprDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "else") elseExprDoc - ] - HsMultiIf _ cases -> do - clauseDocs <- cases `forM` layoutGrhs - binderDoc <- docLit $ Text.pack "->" - hasComments <- hasAnyCommentsBelow lexpr - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "if") - (layoutPatternBindFinal - Nothing - binderDoc - Nothing - clauseDocs - Nothing - hasComments - ) - HsLet _ binds exp1 -> do - expDoc1 <- docSharedWrapper layoutExpr exp1 - -- We jump through some ugly hoops here to ensure proper sharing. - hasComments <- hasAnyCommentsBelow lexpr - mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds - let - ifIndentFreeElse :: a -> a -> a - ifIndentFreeElse x y = case indentPolicy of - IndentPolicyLeft -> y - IndentPolicyMultiple -> y - IndentPolicyFree -> x - -- this `docSetBaseAndIndent` might seem out of place (especially the - -- Indent part; setBase is necessary due to the use of docLines below), - -- but is here due to ghc-exactprint's DP handling of "let" in - -- particular. - -- Just pushing another indentation level is a straightforward approach - -- to making brittany idempotent, even though the result is non-optimal - -- if "let" is moved horizontally as part of the transformation, as the - -- comments before the first let item are moved horizontally with it. - docSetBaseAndIndent $ case mBindDocs of - Just [bindDoc] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline - bindDoc - , appSep $ docLit $ Text.pack "in" - , docForceSingleline expDoc1 - ] - addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt - [ docSeq - [ appSep $ docLit $ Text.pack "let" - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline - $ bindDoc - ] - , docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent bindDoc) - ] - , docAlt - [ docSeq - [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in" - , ifIndentFreeElse - docSetBaseAndIndent - docForceSingleline - expDoc1 - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1) - ] - ] - Just bindDocs@(_ : _) -> runFilteredAlternative $ do - --either - -- let - -- a = b - -- c = d - -- in foo - -- bar - -- baz - --or - -- let - -- a = b - -- c = d - -- in - -- fooooooooooooooooooo - let - noHangingBinds = - [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines bindDocs) - , docSeq - [ docLit $ Text.pack "in " - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 - ] - ] - addAlternative $ case indentPolicy of - IndentPolicyLeft -> docLines noHangingBinds - IndentPolicyMultiple -> docLines noHangingBinds - IndentPolicyFree -> docLines - [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines bindDocs - ] - , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1] - ] - addAlternative $ docLines - [ docNodeAnnKW lexpr (Just AnnLet) - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1) - ] - _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] - -- docSeq [appSep $ docLit "let in", expDoc1] - HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of - DoExpr _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "do") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - MDoExpr _ -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "mdo") - (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) - x - | case x of - ListComp -> True - MonadComp -> True - _ -> False - -> do - stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts - hasComments <- hasAnyCommentsBelow lexpr - runFilteredAlternative $ do - addAlternativeCond (not hasComments) $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) - $ appSep - $ docForceSingleline - $ List.last stmtDocs - , appSep $ docLit $ Text.pack "|" - , docSeq - $ List.intersperse docCommaSep - $ docForceSingleline - <$> List.init stmtDocs - , docLit $ Text.pack " ]" - ] - addAlternative - $ let - start = docCols - ColListComp - [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack - "[" - , docSetBaseY - $ docNodeAnnKW lexpr (Just AnnOpenS) - $ List.last stmtDocs - ] - (s1 : sM) = List.init stmtDocs - line1 = - docCols ColListComp [appSep $ docLit $ Text.pack "|", s1] - lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] - _ -> do - -- TODO - unknownNodeError "HsDo{} unknown stmtCtx" lexpr - ExplicitList _ _ elems@(_ : _) -> do - elemDocs <- elems `forM` docSharedWrapper layoutExpr - hasComments <- hasAnyCommentsBelow lexpr - case splitFirstLast elemDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "[" - , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "[" - , docSeparator - , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e - ] - , docLit $ Text.pack "]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "["] - ++ List.intersperse - docCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]) - ) - ++ [docLit $ Text.pack "]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "[", e1] - linesM = ems <&> \d -> docCols ColList [docCommaSep, d] - lineN = docCols - ColList - [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] - end = docLit $ Text.pack "]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ExplicitList _ _ [] -> docLit $ Text.pack "[]" - RecordCon _ lname fields -> case fields of - HsRecFields fs Nothing -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - rFs <- - fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ (lfield, lrdrNameToText lnameF, rFExpDoc) - recordExpression False indentPolicy lexpr nameDoc rFs - HsRecFields [] (Just (L _ 0)) -> do - let t = lrdrNameToText lname - docWrapNode lname $ docLit $ t <> Text.pack " { .. }" - HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do - let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname - fieldDocs <- - fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr fExpr - return (fieldl, lrdrNameToText lnameF, fExpDoc) - recordExpression True indentPolicy lexpr nameDoc fieldDocs - _ -> unknownNodeError "RecordCon with puns" lexpr - RecordUpd _ rExpr fields -> do - rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs <- - fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do - rFExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutExpr rFExpr - return $ case ambName of - Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc) - recordExpression False indentPolicy lexpr rExprDoc rFs - ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do - expDoc <- docSharedWrapper layoutExpr exp1 - typDoc <- docSharedWrapper layoutType typ1 - docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc] - ArithSeq _ Nothing info -> case info of - From e1 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , docLit $ Text.pack "..]" - ] - FromThen e1 e2 -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , docLit $ Text.pack "..]" - ] - FromTo e1 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , appSep $ docForceSingleline e1Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - FromThenTo e1 e2 eN -> do - e1Doc <- docSharedWrapper layoutExpr e1 - e2Doc <- docSharedWrapper layoutExpr e2 - eNDoc <- docSharedWrapper layoutExpr eN - docSeq - [ docLit $ Text.pack "[" - , docForceSingleline e1Doc - , appSep $ docLit $ Text.pack "," - , appSep $ docForceSingleline e2Doc - , appSep $ docLit $ Text.pack ".." - , docForceSingleline eNDoc - , docLit $ Text.pack "]" - ] - ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr - HsBracket{} -> do - -- TODO - briDocByExactInlineOnly "HsBracket{}" lexpr - HsRnBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsRnBracketOut{}" lexpr - HsTcBracketOut{} -> do - -- TODO - briDocByExactInlineOnly "HsTcBracketOut{}" lexpr - HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do - allocateNode $ BDFPlain - (Text.pack - $ "[" - ++ showOutputable quoter - ++ "|" - ++ showOutputable content - ++ "|]" - ) - HsSpliceE{} -> do - -- TODO - briDocByExactInlineOnly "HsSpliceE{}" lexpr - HsProc{} -> do - -- TODO - briDocByExactInlineOnly "HsProc{}" lexpr - HsStatic{} -> do - -- TODO - briDocByExactInlineOnly "HsStatic{}" lexpr - HsTick{} -> do - -- TODO - briDocByExactInlineOnly "HsTick{}" lexpr - HsBinTick{} -> do - -- TODO - briDocByExactInlineOnly "HsBinTick{}" lexpr - HsConLikeOut{} -> do - -- TODO - briDocByExactInlineOnly "HsWrap{}" lexpr - ExplicitSum{} -> do - -- TODO - briDocByExactInlineOnly "ExplicitSum{}" lexpr - HsPragE{} -> do - -- TODO - briDocByExactInlineOnly "HsPragE{}" lexpr - -recordExpression - :: (Data.Data.Data lExpr, Data.Data.Data name) - => Bool - -> IndentPolicy - -> GenLocated SrcSpan lExpr - -> ToBriDocM BriDocNumbered - -> [ ( GenLocated SrcSpan name - , Text - , Maybe (ToBriDocM BriDocNumbered) - ) - ] - -> ToBriDocM BriDocNumbered -recordExpression False _ lexpr nameDoc [] = docSeq - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack "}" - ] -recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used - -- atm anyway. - [ docNodeAnnKW lexpr (Just AnnOpenC) - $ docSeq [nameDoc, docLit $ Text.pack "{"] - , docLit $ Text.pack " .. }" - ] -recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do - let (rF1f, rF1n, rF1e) = rF1 - runFilteredAlternative $ do - -- container { fieldA = blub, fieldB = blub } - addAlternative $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc - , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep $ rFs <&> \case - (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq - [ appSep $ docLit fieldStr - , appSep $ docLit $ Text.pack "=" - , docForceSingleline fieldDoc - ] - (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr - , if dotdot - then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator] - else docSeparator - , docLit $ Text.pack "}" - ] - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc - , docSetBaseY - $ docLines - $ let - line1 = docCols - ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , case rF1e of - Just x -> docWrapNodeRest rF1f $ docSeq - [appSep $ docLit $ Text.pack "=", docForceSingleline x] - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> - docSeq [appSep $ docLit $ Text.pack "=", docForceSingleline x] - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ] - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } - addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar - (docNodeAnnKW lexpr Nothing nameDoc) - (docNonBottomSpacing - $ docLines - $ let - line1 = docCols - ColRec - [ appSep $ docLit $ Text.pack "{" - , docWrapNodePrior rF1f $ appSep $ docLit rF1n - , docWrapNodeRest rF1f $ case rF1e of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - lineR = rFr <&> \(lfield, fText, fDoc) -> - docWrapNode lfield $ docCols - ColRec - [ docCommaSep - , appSep $ docLit fText - , case fDoc of - Just x -> runFilteredAlternative $ do - addAlternativeCond (indentPolicy == IndentPolicyFree) $ do - docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x] - addAlternative $ do - docSeq - [appSep $ docLit $ Text.pack "=", docForceParSpacing x] - addAlternative $ do - docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - Nothing -> docEmpty - ] - dotdotLine = if dotdot - then docCols - ColRec - [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep - , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".." - ] - else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty - lineN = docLit $ Text.pack "}" - in [line1] ++ lineR ++ [dotdotLine, lineN] - ) - -litBriDoc :: HsLit GhcPs -> BriDocFInt -litBriDoc = \case - HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] - HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString - HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString - HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i - HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t - HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - _ -> error "litBriDoc: literal with no SourceText" - -overLitValBriDoc :: OverLitVal -> BriDocFInt -overLitValBriDoc = \case - HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t - HsIsString (SourceText t) _ -> BDFLit $ Text.pack t - _ -> error "overLitValBriDoc: literal with no SourceText" diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot deleted file mode 100644 index 4f913c3..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Expr where - -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types - - - -layoutExpr :: ToBriDoc HsExpr - --- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) - -litBriDoc :: HsLit GhcPs -> BriDocFInt - -overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs deleted file mode 100644 index 8684842..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.IE where - -import qualified Data.List.Extra -import qualified Data.Text as Text -import GHC - ( AnnKeywordId(..) - , GenLocated(L) - , Located - , ModuleName - , moduleNameString - , unLoc - ) -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -prepareName :: LIEWrappedName name -> Located name -prepareName = ieLWrappedName - -layoutIE :: ToBriDoc IE -layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of - IEVar _ x -> layoutWrapped lie x - IEThingAbs _ x -> layoutWrapped lie x - IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x (IEWildcard _) _ _ -> - docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] - IEThingWith _ x _ ns _ -> do - hasComments <- orM - (hasCommentsBetween lie AnnOpenP AnnCloseP - : hasAnyCommentsBelow x - : map hasAnyCommentsBelow ns - ) - let sortedNs = List.sortOn wrappedNameToText ns - runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [layoutWrapped lie x, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc sortedNs) - ++ [docParenR] - addAlternative - $ docWrapNodeRest lie - $ docAddBaseY BrIndentRegular - $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) - where - nameDoc = docLit <=< lrdrNameToTextAnn . prepareName - layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] - layoutItems FirstLastEmpty = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty] - , docParenR - ] - layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] - , docParenR - ] - layoutItems (FirstLast n1 nMs nN) = - docSetBaseY - $ docLines - $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] - ++ map layoutItem nMs - ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN] - , docParenR - ] - IEModuleContents _ n -> docSeq - [ docLit $ Text.pack "module" - , docSeparator - , docLit . Text.pack . moduleNameString $ unLoc n - ] - _ -> docEmpty - where - layoutWrapped _ = \case - L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n - L _ (IEPattern n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "pattern " <> name - L _ (IEType n) -> do - name <- lrdrNameToTextAnn n - docLit $ Text.pack "type " <> name - -data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted --- Helper function to deal with Located lists of LIEs. --- In particular this will also associate documentation --- from the located list that actually belongs to the last IE. --- It also adds docCommaSep to all but the first element --- This configuration allows both vertical and horizontal --- handling of the resulting list. Adding parens is --- left to the caller since that is context sensitive -layoutAnnAndSepLLIEs - :: SortItemsFlag - -> Located [LIE GhcPs] - -> ToBriDocM [ToBriDocM BriDocNumbered] -layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do - let makeIENode ie = docSeq [docCommaSep, ie] - let - sortedLies = - [ items - | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies - , items <- mergeGroup group - ] - let - ieDocs = fmap layoutIE $ case shouldSort of - ShouldSortItems -> sortedLies - KeepItemsUnsorted -> lies - ieCommaDocs <- - docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of - FirstLastEmpty -> [] - FirstLastSingleton ie -> [ie] - FirstLast ie1 ieMs ieN -> - [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] - pure $ fmap pure ieCommaDocs -- returned shared nodes - where - mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] - mergeGroup [] = [] - mergeGroup items@[_] = items - mergeGroup items = if - | all isProperIEThing items -> [List.foldl1' thingFolder items] - | all isIEVar items -> [List.foldl1' thingFolder items] - | otherwise -> items - -- proper means that if it is a ThingWith, it does not contain a wildcard - -- (because I don't know what a wildcard means if it is not already a - -- IEThingAll). - isProperIEThing :: LIE GhcPs -> Bool - isProperIEThing = \case - L _ (IEThingAbs _ _wn) -> True - L _ (IEThingAll _ _wn) -> True - L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True - _ -> False - isIEVar :: LIE GhcPs -> Bool - isIEVar = \case - L _ IEVar{} -> True - _ -> False - thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs - thingFolder l1@(L _ IEVar{}) _ = l1 - thingFolder l1@(L _ IEThingAll{}) _ = l1 - thingFolder _ l2@(L _ IEThingAll{}) = l2 - thingFolder l1 (L _ IEThingAbs{}) = l1 - thingFolder (L _ IEThingAbs{}) l2 = l2 - thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) - = L - l - (IEThingWith - x - wn - NoIEWildcard - (consItems1 ++ consItems2) - (fieldLbls1 ++ fieldLbls2) - ) - thingFolder _ _ = - error "thingFolder should be exhaustive because we have a guard above" - - --- Builds a complete layout for the given located --- list of LIEs. The layout provides two alternatives: --- (item, item, ..., item) --- ( item --- , item --- ... --- , item --- ) --- If the llies contains comments the list will --- always expand over multiple lines, even when empty: --- () -- no comments --- ( -- a comment --- ) -layoutLLIEs - :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered -layoutLLIEs enableSingleline shouldSort llies = do - ieDs <- layoutAnnAndSepLLIEs shouldSort llies - hasComments <- hasAnyCommentsBelow llies - runFilteredAlternative $ case ieDs of - [] -> do - addAlternativeCond (not hasComments) $ docLit $ Text.pack "()" - addAlternativeCond hasComments $ docPar - (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - (ieDsH : ieDsT) -> do - addAlternativeCond (not hasComments && enableSingleline) - $ docSeq - $ [docLit (Text.pack "(")] - ++ (docForceSingleline <$> ieDs) - ++ [docParenR] - addAlternative - $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) - $ docLines - $ ieDsT - ++ [docParenR] - --- | Returns a "fingerprint string", not a full text representation, nor even --- a source code representation of this syntax node. --- Used for sorting, not for printing the formatter's output source code. -wrappedNameToText :: LIEWrappedName RdrName -> Text -wrappedNameToText = \case - L _ (IEName n) -> lrdrNameToText n - L _ (IEPattern n) -> lrdrNameToText n - L _ (IEType n) -> lrdrNameToText n - --- | Returns a "fingerprint string", not a full text representation, nor even --- a source code representation of this syntax node. --- Used for sorting, not for printing the formatter's output source code. -lieToText :: LIE GhcPs -> Text -lieToText = \case - L _ (IEVar _ wn) -> wrappedNameToText wn - L _ (IEThingAbs _ wn) -> wrappedNameToText wn - L _ (IEThingAll _ wn) -> wrappedNameToText wn - L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn - -- TODO: These _may_ appear in exports! - -- Need to check, and either put them at the top (for module) or do some - -- other clever thing. - L _ (IEModuleContents _ n) -> moduleNameToText n - L _ IEGroup{} -> Text.pack "@IEGroup" - L _ IEDoc{} -> Text.pack "@IEDoc" - L _ IEDocNamed{} -> Text.pack "@IEDocNamed" - where - moduleNameToText :: Located ModuleName -> Text - moduleNameToText (L _ name) = - Text.pack ("@IEModuleContents" ++ moduleNameString name) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs deleted file mode 100644 index fc17cde..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Import where - -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L), Located, moduleNameString, unLoc) -import GHC.Hs -import GHC.Types.Basic -import GHC.Unit.Types (IsBootInterface(..)) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - -prepPkg :: SourceText -> String -prepPkg rawN = case rawN of - SourceText n -> n - -- This would be odd to encounter and the - -- result will most certainly be wrong - NoSourceText -> "" -prepModName :: Located e -> e -prepModName = unLoc - -layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered -layoutImport importD = case importD of - ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do - importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack - importAsCol <- - mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - let - compact = indentPolicy /= IndentPolicyFree - modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - masT = Text.pack . moduleNameString . prepModName <$> mas - hiding = maybe False fst mllies - minQLength = length "import qualified " - qLengthReal = - let - qualifiedPart = if q /= NotQualified then length "qualified " else 0 - safePart = if safe then length "safe " else 0 - pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT - srcPart = case src of - IsBoot -> length "{-# SOURCE #-} " - NotBoot -> 0 - in length "import " + srcPart + safePart + qualifiedPart + pkgPart - qLength = max minQLength qLengthReal - -- Cost in columns of importColumn - asCost = length "as " - hidingParenCost = if hiding then length "hiding ( " else length "( " - nameCost = Text.length modNameT + qLength - importQualifiers = docSeq - [ appSep $ docLit $ Text.pack "import" - , case src of - IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}" - NotBoot -> docEmpty - , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty - , if q /= NotQualified - then appSep $ docLit $ Text.pack "qualified" - else docEmpty - , maybe docEmpty (appSep . docLit) pkgNameT - ] - indentName = - if compact then id else docEnsureIndent (BrIndentSpecial qLength) - modNameD = indentName $ appSep $ docLit modNameT - hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 - hidDocColDiff = importCol - 2 - hidDocCol - hidDoc = - if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty - importHead = docSeq [importQualifiers, modNameD] - bindingsD = case mllies of - Nothing -> docEmpty - Just (_, llies) -> do - hasComments <- hasAnyCommentsBelow llies - if compact - then docAlt - [ docSeq - [ hidDoc - , docForceSingleline $ layoutLLIEs True ShouldSortItems llies - ] - , let - makeParIfHiding = if hiding - then docAddBaseY BrIndentRegular . docPar hidDoc - else id - in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) - ] - else do - ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies - docWrapNodeRest llies - $ docEnsureIndent (BrIndentSpecial hidDocCol) - $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq - [hidDoc, docParenLSep, docWrapNode llies docEmpty] - ) - (docEnsureIndent - (BrIndentSpecial hidDocColDiff) - docParenR - ) - else docSeq - [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - [ hidDoc - , docParenLSep - , docForceSingleline ieD - , docSeparator - , docParenR - ] - addAlternative $ docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - (docEnsureIndent - (BrIndentSpecial hidDocColDiff) - docParenR - ) - -- ..[hiding].( b - -- , b' - -- ) - (ieD : ieDs') -> docPar - (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] - ) - (docEnsureIndent (BrIndentSpecial hidDocColDiff) - $ docLines - $ ieDs' - ++ [docParenR] - ) - makeAsDoc asT = - docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] - if compact - then - let asDoc = maybe docEmpty makeAsDoc masT - in - docAlt - [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] - , docAddBaseY BrIndentRegular - $ docPar (docSeq [importHead, asDoc]) bindingsD - ] - else case masT of - Just n -> if enoughRoom - then docLines [docSeq [importHead, asDoc], bindingsD] - else docLines [importHead, asDoc, bindingsD] - where - enoughRoom = nameCost < importAsCol - asCost - asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) - $ makeAsDoc n - Nothing -> if enoughRoom - then docSeq [importHead, bindingsD] - else docLines [importHead, bindingsD] - where enoughRoom = nameCost < importCol - hidingParenCost - _ -> docEmpty diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs deleted file mode 100644 index 8de45d7..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Module where - -import qualified Data.Maybe -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc) -import GHC.Hs -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.IE -import Language.Haskell.Brittany.Internal.Layouters.Import -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types - (DeltaPos(..), commentContents, deltaRow) - - - -layoutModule :: ToBriDoc' HsModule -layoutModule lmod@(L _ mod') = case mod' of - -- Implicit module Main - HsModule _ Nothing _ imports _ _ _ -> do - commentedImports <- transformToCommentedImport imports - -- groupify commentedImports `forM_` tellDebugMessShow - docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) - -- sortedImports <- sortImports imports - -- docLines $ [layoutImport y i | (y, i) <- sortedImports] - HsModule _ (Just n) les imports _ _ _ -> do - commentedImports <- transformToCommentedImport imports - -- groupify commentedImports `forM_` tellDebugMessShow - -- sortedImports <- sortImports imports - let tn = Text.pack $ moduleNameString $ unLoc n - allowSingleLineExportList <- - mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack - -- the config should not prevent single-line layout when there is no - -- export list - let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les - docLines - $ docSeq - [ docNodeAnnKW lmod Nothing docEmpty - -- A pseudo node that serves merely to force documentation - -- before the node - , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do - addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , docWrapNode lmod $ appSep $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs True KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - addAlternative $ docLines - [ docAddBaseY BrIndentRegular $ docPar - (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]) - (docSeq - [ docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False KeepItemsUnsorted x - , docSeparator - , docLit $ Text.pack "where" - ] - ) - ] - ] - : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] - -data CommentedImport - = EmptyLine - | IndependentComment (Comment, DeltaPos) - | ImportStatement ImportStatementRecord - -instance Show CommentedImport where - show = \case - EmptyLine -> "EmptyLine" - IndependentComment _ -> "IndependentComment" - ImportStatement r -> - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -data ImportStatementRecord = ImportStatementRecord - { commentsBefore :: [(Comment, DeltaPos)] - , commentsAfter :: [(Comment, DeltaPos)] - , importStatement :: ImportDecl GhcPs - } - -instance Show ImportStatementRecord where - show r = - "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show - (length $ commentsAfter r) - -transformToCommentedImport - :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] -transformToCommentedImport is = do - nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do - annotionMay <- astAnn i - pure (annotionMay, rawImport) - let - convertComment (c, DP (y, x)) = - replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))] - accumF - :: [(Comment, DeltaPos)] - -> (Maybe Annotation, ImportDecl GhcPs) - -> ([(Comment, DeltaPos)], [CommentedImport]) - accumF accConnectedComm (annMay, decl) = case annMay of - Nothing -> - ( [] - , [ ImportStatement ImportStatementRecord - { commentsBefore = [] - , commentsAfter = [] - , importStatement = decl - } - ] - ) - Just ann -> - let - blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1 - (newAccumulator, priorComments') = - List.span ((== 0) . deltaRow . snd) (annPriorComments ann) - go - :: [(Comment, DeltaPos)] - -> [(Comment, DeltaPos)] - -> ([CommentedImport], [(Comment, DeltaPos)], Int) - go acc [] = ([], acc, 0) - go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) - go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs - go acc ((c1, DP (y, x)) : xs) = - ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine - , (c1, DP (1, x)) : acc - , 0 - ) - (convertedIndependentComments, beforeComments, initialBlanks) = - if blanksBeforeImportDecl /= 0 - then (convertComment =<< priorComments', [], 0) - else go [] (reverse priorComments') - in - ( newAccumulator - , convertedIndependentComments - ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine - ++ [ ImportStatement ImportStatementRecord - { commentsBefore = beforeComments - , commentsAfter = accConnectedComm - , importStatement = decl - } - ] - ) - let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations - pure $ join $ (convertComment =<< finalAcc) : finalList - -sortCommentedImports :: [CommentedImport] -> [CommentedImport] -sortCommentedImports = - unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify - where - unpackImports :: [CommentedImport] -> [CommentedImport] - unpackImports xs = xs >>= \case - l@EmptyLine -> [l] - l@IndependentComment{} -> [l] - ImportStatement r -> - map IndependentComment (commentsBefore r) ++ [ImportStatement r] - mergeGroups - :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] - mergeGroups xs = xs >>= \case - Left x -> [x] - Right y -> ImportStatement <$> y - sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] - sortGroups = - List.sortOn (moduleNameString . unLoc . ideclName . importStatement) - groupify - :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]] - groupify cs = go [] cs - where - go [] = \case - (l@EmptyLine : rest) -> Left l : go [] rest - (l@IndependentComment{} : rest) -> Left l : go [] rest - (ImportStatement r : rest) -> go [r] rest - [] -> [] - go acc = \case - (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest - (l@IndependentComment{} : rest) -> - Left l : Right (reverse acc) : go [] rest - (ImportStatement r : rest) -> go (r : acc) rest - [] -> [Right (reverse acc)] - -commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered -commentedImportsToDoc = \case - EmptyLine -> docLitS "" - IndependentComment c -> commentToDoc c - ImportStatement r -> docSeq - (layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) - where - commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs deleted file mode 100644 index 773d993..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Pattern where - -import qualified Data.Foldable as Foldable -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import GHC (GenLocated(L), ol_val) -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import Language.Haskell.Brittany.Internal.LayouterBasics -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Type -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - --- | layouts patterns (inside function bindings, case alternatives, let --- bindings or do notation). E.g. for input --- > case computation of --- > (warnings, Success a b) -> .. --- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by --- 'layoutPat'. Similarly for --- > func abc True 0 = [] --- ^^^^^^^^^^ this part --- We will use `case .. of` as the imagined prefix to the examples used in --- the different cases below. -layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) -layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of - WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" - -- _ -> expr - VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n - -- abc -> expr - LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit - -- 0 -> expr - ParPat _ inner -> do - -- (nestedpat) -> expr - left <- docLit $ Text.pack "(" - right <- docLit $ Text.pack ")" - innerDocs <- colsWrapPat =<< layoutPat inner - return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right - -- return $ (left Seq.<| innerDocs) Seq.|> right - -- case Seq.viewl innerDocs of - -- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur.. - -- x1 Seq.:< rest -> case Seq.viewr rest of - -- Seq.EmptyR -> - -- fmap return $ docSeq - -- [ docLit $ Text.pack "(" - -- , return x1 - -- , docLit $ Text.pack ")" - -- ] - -- middle Seq.:> xN -> do - -- x1' <- docSeq [docLit $ Text.pack "(", return x1] - -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] - -- return $ (x1' Seq.<| middle) Seq.|> xN' - ConPat _ lname (PrefixCon args) -> do - -- Abc a b c -> expr - nameDoc <- lrdrNameToTextAnn lname - argDocs <- layoutPat `mapM` args - if null argDocs - then return <$> docLit nameDoc - else do - x1 <- appSep (docLit nameDoc) - xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap - colsWrapPat - argDocs - return $ x1 Seq.<| xR - ConPat _ lname (InfixCon left right) -> do - -- a :< b -> expr - nameDoc <- lrdrNameToTextAnn lname - leftDoc <- appSep . colsWrapPat =<< layoutPat left - rightDoc <- colsWrapPat =<< layoutPat right - middle <- appSep $ docLit nameDoc - return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc - ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do - -- Abc{} -> expr - let t = lrdrNameToText lname - fmap Seq.singleton $ docLit $ t <> Text.pack "{}" - ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do - -- Abc { a = locA, b = locB, c = locC } -> expr1 - -- Abc { a, b, c } -> expr2 - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ List.intersperse docCommaSep $ fds <&> \case - (fieldName, Just fieldDoc) -> docSeq - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - ] - (fieldName, Nothing) -> docLit fieldName - , docSeparator - , docLit $ Text.pack "}" - ] - ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do - -- Abc { .. } -> expr - let t = lrdrNameToText lname - Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"] - ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) - | dotdoti == length fs -> do - -- Abc { a = locA, .. } - let t = lrdrNameToText lname - fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do - let FieldOcc _ lnameF = fieldOcc - fExpDoc <- if pun - then return Nothing - else Just <$> docSharedWrapper layoutPat fPat - return (lrdrNameToText lnameF, fExpDoc) - Seq.singleton <$> docSeq - [ appSep $ docLit t - , appSep $ docLit $ Text.pack "{" - , docSeq $ fds >>= \case - (fieldName, Just fieldDoc) -> - [ appSep $ docLit fieldName - , appSep $ docLit $ Text.pack "=" - , fieldDoc >>= colsWrapPat - , docCommaSep - ] - (fieldName, Nothing) -> [docLit fieldName, docCommaSep] - , docLit $ Text.pack "..}" - ] - TuplePat _ args boxity -> do - -- (nestedpat1, nestedpat2, nestedpat3) -> expr - -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr - case boxity of - Boxed -> wrapPatListy args "()" docParenL docParenR - Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep - AsPat _ asName asPat -> do - -- bind@nestedpat -> expr - wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") - SigPat _ pat1 (HsPS _ ty1) -> do - -- i :: Int -> expr - patDocs <- layoutPat pat1 - tyDoc <- docSharedWrapper layoutType ty1 - case Seq.viewr patDocs of - Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" - xR Seq.:> xN -> do - xN' <- -- at the moment, we don't support splitting patterns into - -- multiple lines. but we cannot enforce pasting everything - -- into one line either, because the type signature will ignore - -- this if we overflow sufficiently. - -- In order to prevent syntactically invalid results in such - -- cases, we need the AddBaseY here. - -- This can all change when patterns get multiline support. - docAddBaseY BrIndentRegular $ docSeq - [ appSep $ return xN - , appSep $ docLit $ Text.pack "::" - , docForceSingleline tyDoc - ] - return $ xR Seq.|> xN' - ListPat _ elems -> - -- [] -> expr1 - -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 - wrapPatListy elems "[]" docBracketL docBracketR - BangPat _ pat1 -> do - -- !nestedpat -> expr - wrapPatPrepend pat1 (docLit $ Text.pack "!") - LazyPat _ pat1 -> do - -- ~nestedpat -> expr - wrapPatPrepend pat1 (docLit $ Text.pack "~") - NPat _ llit@(L _ ol) mNegative _ -> do - -- -13 -> expr - litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol - negDoc <- docLit $ Text.pack "-" - pure $ case mNegative of - Just{} -> Seq.fromList [negDoc, litDoc] - Nothing -> Seq.singleton litDoc - - _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat - -colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered -colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList - -wrapPatPrepend - :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) -wrapPatPrepend pat prepElem = do - patDocs <- layoutPat pat - case Seq.viewl patDocs of - Seq.EmptyL -> return Seq.empty - x1 Seq.:< xR -> do - x1' <- docSeq [prepElem, return x1] - return $ x1' Seq.<| xR - -wrapPatListy - :: [LPat GhcPs] - -> String - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - -> ToBriDocM (Seq BriDocNumbered) -wrapPatListy elems both start end = do - elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat) - case Seq.viewl elemDocs of - Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both - x1 Seq.:< rest -> do - sDoc <- start - eDoc <- end - rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd] - return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs deleted file mode 100644 index 5ef19c7..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Brittany.Internal.Layouters.Stmt where - -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import GHC (GenLocated(L)) -import GHC.Hs -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Layouters.Decl -import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr -import Language.Haskell.Brittany.Internal.Layouters.Pattern -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types - - - -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) -layoutStmt lstmt@(L _ stmt) = do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - indentAmount :: Int <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - docWrapNode lstmt $ case stmt of - LastStmt _ body Nothing _ -> do - layoutExpr body - BindStmt _ lPat expr -> do - patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat - expDoc <- docSharedWrapper layoutExpr expr - docAlt - [ docCols - ColBindStmt - [ appSep patDoc - , docSeq - [ appSep $ docLit $ Text.pack "<-" - , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc - ] - ] - , docCols - ColBindStmt - [ appSep patDoc - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "<-") (expDoc) - ] - ] - LetStmt _ binds -> do - let isFree = indentPolicy == IndentPolicyFree - let indentFourPlus = indentAmount >= 4 - layoutLocalBinds binds >>= \case - Nothing -> docLit $ Text.pack "let" - -- i just tested the above, and it is indeed allowed. heh. - Just [] -> docLit $ Text.pack "let" -- this probably never happens - Just [bindDoc] -> docAlt - [ -- let bind = expr - docCols - ColDoLet - [ appSep $ docLit $ Text.pack "let" - , let - f = case indentPolicy of - IndentPolicyFree -> docSetBaseAndIndent - IndentPolicyLeft -> docForceSingleline - IndentPolicyMultiple - | indentFourPlus -> docSetBaseAndIndent - | otherwise -> docForceSingleline - in f $ return bindDoc - ] - , -- let - -- bind = expr - docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) - ] - Just bindDocs -> runFilteredAlternative $ do - -- let aaa = expra - -- bbb = exprb - -- ccc = exprc - addAlternativeCond (isFree || indentFourPlus) $ docSeq - [ appSep $ docLit $ Text.pack "let" - , let - f = if indentFourPlus - then docEnsureIndent BrIndentRegular - else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs - ] - -- let - -- aaa = expra - -- bbb = exprb - -- ccc = exprc - addAlternativeCond (not indentFourPlus) - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) - RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do - -- rec stmt1 - -- stmt2 - -- stmt3 - addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docLit (Text.pack "rec") - , docSeparator - , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts - ] - -- rec - -- stmt1 - -- stmt2 - -- stmt3 - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (docLit (Text.pack "rec")) - (docLines $ layoutStmt <$> stmts) - BodyStmt _ expr _ _ -> do - expDoc <- docSharedWrapper layoutExpr expr - docAddBaseY BrIndentRegular $ expDoc - _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot deleted file mode 100644 index 6cfd5c8..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Stmt where - -import GHC.Hs -import Language.Haskell.Brittany.Internal.Types - - - -layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) diff --git a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs deleted file mode 100644 index 1662ffb..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ /dev/null @@ -1,635 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Layouters.Type where - -import qualified Data.Text as Text -import GHC (AnnKeywordId(..), GenLocated(L)) -import GHC.Hs -import qualified GHC.OldList as List -import GHC.Types.Basic -import GHC.Utils.Outputable (ftext, showSDocUnsafe) -import Language.Haskell.Brittany.Internal.LayouterBasics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - (FirstLastView(..), splitFirstLast) - - - -layoutType :: ToBriDoc HsType -layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of - -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" - HsTyVar _ promoted name -> do - t <- lrdrNameToTextAnnTypeEqualityIsSpecial name - case promoted of - IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] - NotPromoted -> docWrapNode name $ docLit t - HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do - let bndrs = getBinders hsf - typeDoc <- docSharedWrapper layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let - tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - forallDoc = docAlt - [ let open = docLit $ Text.pack "forall" - in docSeq ([open] ++ tyVarDocLineList) - , docPar - (docLit (Text.pack "forall")) - (docLines $ tyVarDocs <&> \case - (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" - ] - ) - ] - contextDoc = case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) - , let - open = docCols - ColTyOpPrefix - [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] - in docPar open $ docLines $ list ++ [close] - ] - docAlt - -- :: forall a b c . (Foo a b c) => a b -> c - [ docSeq - [ if null bndrs - then docEmpty - else - let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) - , docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- :: forall a b c - -- . (Foo a b c) - -- => a b - -- -> c - , docPar - forallDoc - (docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , docAddBaseY (BrIndentSpecial 3) $ contextDoc - ] - , docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc - ] - ] - ) - ] - HsForAllTy _ hsf typ2 -> do - let bndrs = getBinders hsf - typeDoc <- layoutType typ2 - tyVarDocs <- layoutTyVarBndrs bndrs - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs - docAlt - -- forall x . x - [ docSeq - [ if null bndrs - then docEmpty - else - let - open = docLit $ Text.pack "forall" - close = docLit $ Text.pack " . " - in docSeq ([open] ++ tyVarDocLineList ++ [close]) - , docForceSingleline $ return $ typeDoc - ] - -- :: forall x - -- . x - , docPar - (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ) - -- :: forall - -- (x :: *) - -- . x - , docPar - (docLit (Text.pack "forall")) - (docLines - $ (tyVarDocs <&> \case - (tname, Nothing) -> - docEnsureIndent BrIndentRegular $ docLit tname - (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines - [ docCols ColTyOpPrefix [docParenLSep, docLit tname] - , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] - , docLit $ Text.pack ")" - ] - ) - ++ [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack " . " - , maybeForceML $ return typeDoc - ] - ] - ) - ] - HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do - typeDoc <- docSharedWrapper layoutType typ1 - cntxtDocs <- cntxts `forM` docSharedWrapper layoutType - let - contextDoc = docWrapNode lcntxts $ case cntxtDocs of - [] -> docLit $ Text.pack "()" - [x] -> x - _ -> docAlt - [ let - open = docLit $ Text.pack "(" - close = docLit $ Text.pack ")" - list = - List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs - in docSeq ([open] ++ list ++ [close]) - , let - open = docCols - ColTyOpPrefix - [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs] - close = docLit $ Text.pack ")" - list = List.tail cntxtDocs <&> \cntxtDoc -> docCols - ColTyOpPrefix - [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] - in docPar open $ docLines $ list ++ [close] - ] - let - maybeForceML = case typ1 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - docAlt - -- (Foo a b c) => a b -> c - [ docSeq - [ docForceSingleline contextDoc - , docLit $ Text.pack " => " - , docForceSingleline typeDoc - ] - -- (Foo a b c) - -- => a b - -- -> c - , docPar - (docForceSingleline contextDoc) - (docCols - ColTyOpPrefix - [ docLit $ Text.pack "=> " - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc - ] - ) - ] - HsFunTy _ _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - let - maybeForceML = case typ2 of - (L _ HsFunTy{}) -> docForceMultiline - _ -> id - hasComments <- hasAnyCommentsBelow ltype - docAlt - $ [ docSeq - [ appSep $ docForceSingleline typeDoc1 - , appSep $ docLit $ Text.pack "->" - , docForceSingleline typeDoc2 - ] - | not hasComments - ] - ++ [ docPar - (docNodeAnnKW ltype Nothing typeDoc1) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" - , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 - ] - ) - ] - HsParTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docLit $ Text.pack ")" - ] - , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack ")") - ] - HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do - let - gather - :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) - gather list = \case - L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 - final -> (final, list) - let (typHead, typRest) = gather [typ2] typ1 - docHead <- docSharedWrapper layoutType typHead - docRest <- docSharedWrapper layoutType `mapM` typRest - docAlt - [ docSeq - $ docForceSingleline docHead - : (docRest >>= \d -> [docSeparator, docForceSingleline d]) - , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) - ] - HsAppTy _ typ1 typ2 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - typeDoc2 <- docSharedWrapper layoutType typ2 - docAlt - [ docSeq - [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2] - , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) - ] - HsListTy _ typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack "[" - , docForceSingleline typeDoc1 - , docLit $ Text.pack "]" - ] - , docPar - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " - , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 - ] - ) - (docLit $ Text.pack "]") - ] - HsTupleTy _ tupleSort typs -> case tupleSort of - HsUnboxedTuple -> unboxed - HsBoxedTuple -> simple - HsConstraintTuple -> simple - HsBoxedOrConstraintTuple -> simple - where - unboxed = if null typs - then error "brittany internal error: unboxed unit" - else unboxedL - simple = if null typs then unitL else simpleL - unitL = docLit $ Text.pack "()" - simpleL = do - docs <- docSharedWrapper layoutType `mapM` typs - let - end = docLit $ Text.pack ")" - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) - docAlt - [ docSeq - $ [docLit $ Text.pack "("] - ++ docWrapNodeRest ltype commaDocs - ++ [end] - , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] - in - docPar - (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ docWrapNodeRest ltype lines ++ [end]) - ] - unboxedL = do - docs <- docSharedWrapper layoutType `mapM` typs - let - start = docParenHashLSep - end = docParenHashRSep - docAlt - [ docSeq - $ [start] - ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) - ++ [end] - , let - line1 = docCols ColTyOpPrefix [start, head docs] - lines = - List.tail docs - <&> \d -> docAddBaseY (BrIndentSpecial 2) - $ docCols ColTyOpPrefix [docCommaSep, d] - in docPar - (docAddBaseY (BrIndentSpecial 2) line1) - (docLines $ lines ++ [end]) - ] - HsOpTy{} -> -- TODO - briDocByExactInlineOnly "HsOpTy{}" ltype - -- HsOpTy typ1 opName typ2 -> do - -- -- TODO: these need some proper fixing. precedences don't add up. - -- -- maybe the parser just returns some trivial right recursion - -- -- parse result for any type level operators. - -- -- need to check how things are handled on the expression level. - -- let opStr = lrdrNameToText opName - -- let opLen = Text.length opStr - -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 - -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 - -- let line = do -- Maybe - -- l1 <- _ldesc_line desc1 - -- l2 <- _ldesc_line desc2 - -- let len1 = _lColumns_min l1 - -- let len2 = _lColumns_min l2 - -- let len = 2 + opLen + len1 + len2 - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol1 <- descToBlockStart desc1 - -- (min2, max2) <- descToMinMax (1+opLen) desc2 - -- let (minR, maxR) = case descToBlockMinMax desc1 of - -- Nothing -> (min2, max2) - -- Just (min1, max1) -> (max min1 min2, max max1 max2) - -- return $ BlockDesc - -- { _bdesc_blockStart = rol1 - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Just (1+opLen) - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \params -> do - -- remaining <- getCurRemaining - -- let allowSameLine = _params_sepLines params /= SepLineTypeOp - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do - -- applyLayouterRestore layouter1 defaultParams - -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " - -- applyLayouterRestore layouter2 defaultParams - -- _ -> do - -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params - -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 - -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams - -- layoutWriteNewline - -- layoutWriteAppend $ opStr <> Text.pack " " - -- layoutWriteEnsureBlockPlusN downIndent - -- applyLayouterRestore layouter2 defaultParams - -- { _params_sepLines = SepLineTypeOp - -- , _params_opIndent = Just downIndent - -- } - -- , _layouter_ast = ltype - -- } - HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - docAlt - [ docSeq - [ docWrapNodeRest ltype $ docLit $ Text.pack - ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") - , docForceSingleline typeDoc1 - ] - , docPar - (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 2) typeDoc1 - ] - ) - ] - -- TODO: test KindSig - HsKindSig _ typ1 kind1 -> do - typeDoc1 <- docSharedWrapper layoutType typ1 - kindDoc1 <- docSharedWrapper layoutType kind1 - hasParens <- hasAnnKeyword ltype AnnOpenP - docAlt - [ if hasParens - then docSeq - [ docLit $ Text.pack "(" - , docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - , docLit $ Text.pack ")" - ] - else docSeq - [ docForceSingleline typeDoc1 - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , docForceSingleline kindDoc1 - ] - , if hasParens - then docLines - [ docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docParenLSep - , docAddBaseY (BrIndentSpecial 3) $ typeDoc1 - ] - , docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - , (docLit $ Text.pack ")") - ] - else docPar - typeDoc1 - (docCols - ColTyOpPrefix - [ docWrapNodeRest ltype $ docLit $ Text.pack ":: " - , docAddBaseY (BrIndentSpecial 3) kindDoc1 - ] - ) - ] - HsBangTy{} -> -- TODO - briDocByExactInlineOnly "HsBangTy{}" ltype - -- HsBangTy bang typ1 -> do - -- let bangStr = case bang of - -- HsSrcBang _ unpackness strictness -> - -- (++) - -- (case unpackness of - -- SrcUnpack -> "{-# UNPACK -#} " - -- SrcNoUnpack -> "{-# NOUNPACK -#} " - -- NoSrcUnpack -> "" - -- ) - -- (case strictness of - -- SrcLazy -> "~" - -- SrcStrict -> "!" - -- NoSrcStrict -> "" - -- ) - -- let bangLen = length bangStr - -- layouter@(Layouter desc _ _) <- layoutType typ1 - -- let line = do -- Maybe - -- l <- _ldesc_line desc - -- let len = bangLen + _lColumns_min l - -- return $ LayoutColumns - -- { _lColumns_key = ColumnKeyUnique - -- , _lColumns_lengths = [len] - -- , _lColumns_min = len - -- } - -- let block = do -- Maybe - -- rol <- descToBlockStart desc - -- (minR,maxR) <- descToBlockMinMax desc - -- return $ BlockDesc - -- { _bdesc_blockStart = rol - -- , _bdesc_min = minR - -- , _bdesc_max = maxR - -- , _bdesc_opIndentFloatUp = Nothing - -- } - -- return $ Layouter - -- { _layouter_desc = LayoutDesc - -- { _ldesc_line = line - -- , _ldesc_block = block - -- } - -- , _layouter_func = \_params -> do - -- remaining <- getCurRemaining - -- case line of - -- Just (LayoutColumns _ _ m) | m <= remaining -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- applyLayouterRestore layouter defaultParams - -- _ -> do - -- layoutWriteAppend $ Text.pack $ bangStr - -- layoutWritePostCommentsRestore ltype - -- applyLayouterRestore layouter defaultParams - -- , _layouter_ast = ltype - -- } - HsSpliceTy{} -> -- TODO - briDocByExactInlineOnly "HsSpliceTy{}" ltype - HsDocTy{} -> -- TODO - briDocByExactInlineOnly "HsDocTy{}" ltype - HsRecTy{} -> -- TODO - briDocByExactInlineOnly "HsRecTy{}" ltype - HsExplicitListTy _ _ typs -> do - typDocs <- docSharedWrapper layoutType `mapM` typs - hasComments <- hasAnyCommentsBelow ltype - let specialCommaSep = appSep $ docLit $ Text.pack " ," - docAlt - [ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) - ++ [docLit $ Text.pack "]"] - , case splitFirstLast typDocs of - FirstLastEmpty -> docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" - ] - FirstLastSingleton e -> docAlt - [ docSeq - [ docLit $ Text.pack "'[" - , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e - , docLit $ Text.pack "]" - ] - , docSetBaseY $ docLines - [ docSeq - [ docLit $ Text.pack "'[" - , docSeparator - , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e - ] - , docLit $ Text.pack " ]" - ] - ] - FirstLast e1 ems eN -> runFilteredAlternative $ do - addAlternativeCond (not hasComments) - $ docSeq - $ [docLit $ Text.pack "'["] - ++ List.intersperse - specialCommaSep - (docForceSingleline - <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]) - ) - ++ [docLit $ Text.pack " ]"] - addAlternative - $ let - start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] - linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] - lineN = docCols - ColList - [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] - end = docLit $ Text.pack " ]" - in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] - ] - HsExplicitTupleTy{} -> -- TODO - briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype - HsTyLit _ lit -> case lit of - HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsNumTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext - HsStrTy NoSourceText _ -> - error "overLitValBriDoc: literal with no SourceText" - HsWildCardTy _ -> docLit $ Text.pack "_" - HsSumTy{} -> -- TODO - briDocByExactInlineOnly "HsSumTy{}" ltype - HsStarTy _ isUnicode -> do - if isUnicode - then docLit $ Text.pack "\x2605" -- Unicode star - else docLit $ Text.pack "*" - XHsType{} -> error "brittany internal error: XHsType" - HsAppKindTy _ ty kind -> do - t <- docSharedWrapper layoutType ty - k <- docSharedWrapper layoutType kind - docAlt - [ docSeq - [ docForceSingleline t - , docSeparator - , docLit $ Text.pack "@" - , docForceSingleline k - ] - , docPar t (docSeq [docLit $ Text.pack "@", k]) - ] - -layoutTyVarBndrs - :: [LHsTyVarBndr () GhcPs] - -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))] -layoutTyVarBndrs = mapM $ \case - (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing) - (L _ (KindedTyVar _ _ lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - --- there is no specific reason this returns a list instead of a single --- BriDoc node. -processTyVarBndrsSingleline - :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered] -processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case - (tname, Nothing) -> [docSeparator, docLit tname] - (tname, Just doc) -> - [ docSeparator - , docLit $ Text.pack "(" <> tname <> Text.pack " :: " - , docForceSingleline $ doc - , docLit $ Text.pack ")" - ] - -getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] -getBinders x = case x of - HsForAllVis _ b -> b - HsForAllInvis _ b -> fmap withoutSpecificity b - XHsForAllTelescope _ -> [] - -withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass -withoutSpecificity = fmap $ \case - UserTyVar a _ c -> UserTyVar a () c - KindedTyVar a _ c d -> KindedTyVar a () c d - XTyVarBndr a -> XTyVarBndr a diff --git a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs b/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs deleted file mode 100644 index c1bd60a..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Obfuscation where - -import Data.Char -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import System.Random - - - -obfuscate :: Text -> IO Text -obfuscate input = do - let predi x = isAlphaNum x || x `elem` "_'" - let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) - let idents = Set.toList $ Set.fromList $ filter (all predi) groups - let - exceptionFilter x | x `elem` keywords = False - exceptionFilter x | x `elem` extraKWs = False - exceptionFilter x = not $ null $ drop 1 x - let filtered = filter exceptionFilter idents - mappings <- fmap Map.fromList $ filtered `forM` \x -> do - r <- createAlias x - pure (x, r) - let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings) - pure $ Text.concat $ fmap Text.pack groups' - -keywords :: [String] -keywords = - [ "case" - , "class" - , "data" - , "default" - , "deriving" - , "do" - , "mdo" - , "else" - , "forall" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "qualified" - , "then" - , "type" - , "where" - , "_" - , "foreign" - , "ccall" - , "as" - , "safe" - , "unsafe" - , "hiding" - , "proc" - , "rec" - , "family" - ] - -extraKWs :: [String] -extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] - -createAlias :: String -> IO String -createAlias xs = go NoHint xs - where - go _hint "" = pure "" - go hint (c : cr) = do - c' <- case hint of - VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] - _ | isUpper c -> randomFrom ['A' .. 'Z'] - VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] - _ | isLower c -> randomFrom ['a' .. 'z'] - _ -> pure c - cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr - pure (c' : cr') - -data Hint = NoHint | VocalHint | NoVocalHint - -_randomRange :: Random a => a -> a -> IO a -_randomRange lo hi = do - gen <- getStdGen - let (x, gen') = randomR (lo, hi) gen - setStdGen gen' - pure x - -randomFrom :: [a] -> IO a -randomFrom l = do - let hi = length l - 1 - gen <- getStdGen - let (x, gen') = randomR (0, hi) gen - setStdGen gen' - pure $ l List.!! x diff --git a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs b/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs deleted file mode 100644 index 03f83a5..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# OPTIONS_GHC -Wno-implicit-prelude #-} - -module Language.Haskell.Brittany.Internal.ParseModule where - -import qualified Control.Monad as Monad -import qualified Control.Monad.IO.Class as IO -import qualified Control.Monad.Trans.Except as Except -import qualified GHC -import qualified GHC.ByteOrder -import qualified GHC.Data.Bag -import qualified GHC.Data.StringBuffer -import qualified GHC.Driver.Session -import qualified GHC.Parser.Header -import qualified GHC.Platform -import qualified GHC.Settings -import qualified GHC.Types.SrcLoc -import qualified GHC.Utils.Error -import qualified GHC.Utils.Fingerprint -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint - --- | Parses a Haskell module. Although this nominally requires IO, it is --- morally pure. It should have no observable effects. -parseModule - :: IO.MonadIO io - => [String] - -> FilePath - -> (GHC.Driver.Session.DynFlags -> io (Either String a)) - -> String - -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) -parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do - let - dynFlags1 = GHC.Driver.Session.gopt_set - -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both - -- of those modes have trouble parsing safe imports (@import safe ...@). - -- Neither passing in @"-XUnsafe"@ as a command line argument nor having - -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. - initialDynFlags - { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe - } - GHC.Driver.Session.Opt_KeepRawTokenStream - (dynFlags2, leftovers1, _) <- - GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 - $ fmap GHC.Types.SrcLoc.noLoc arguments1 - handleLeftovers leftovers1 - let - stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string - arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath - (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma - dynFlags2 - arguments2 - handleLeftovers leftovers2 - dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 - let - parseResult = - ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string - case parseResult of - Left errorMessages -> handleErrorMessages errorMessages - Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult) - -handleLeftovers - :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () -handleLeftovers leftovers = - Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show - (fmap GHC.Types.SrcLoc.unLoc leftovers) - -handleErrorMessages - :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a -handleErrorMessages = - Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList - -initialDynFlags :: GHC.Driver.Session.DynFlags -initialDynFlags = GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig - -initialSettings :: GHC.Driver.Session.Settings -initialSettings = GHC.Driver.Session.Settings - { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion - , GHC.Driver.Session.sFileSettings = initialFileSettings - , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform - , GHC.Driver.Session.sToolSettings = initialToolSettings - , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc - , GHC.Driver.Session.sPlatformConstants = initialPlatformConstants - , GHC.Driver.Session.sRawSettings = [] - } - -initialFileSettings :: GHC.Driver.Session.FileSettings -initialFileSettings = GHC.Driver.Session.FileSettings - { GHC.Driver.Session.fileSettings_ghciUsagePath = "" - , GHC.Driver.Session.fileSettings_ghcUsagePath = "" - , GHC.Driver.Session.fileSettings_globalPackageDatabase = "" - , GHC.Driver.Session.fileSettings_tmpDir = "" - , GHC.Driver.Session.fileSettings_toolDir = Nothing - , GHC.Driver.Session.fileSettings_topDir = "" - } - -initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion -initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion - { GHC.Driver.Session.ghcNameVersion_programName = "" - , GHC.Driver.Session.ghcNameVersion_projectVersion = "" - } - -initialPlatformMisc :: GHC.Driver.Session.PlatformMisc -initialPlatformMisc = GHC.Driver.Session.PlatformMisc - { GHC.Driver.Session.platformMisc_ghcDebugged = False - , GHC.Driver.Session.platformMisc_ghcRTSWays = "" - , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False - , GHC.Driver.Session.platformMisc_ghcThreaded = False - , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False - , GHC.Driver.Session.platformMisc_ghcWithSMP = False - , GHC.Driver.Session.platformMisc_libFFI = False - , GHC.Driver.Session.platformMisc_llvmTarget = "" - , GHC.Driver.Session.platformMisc_targetPlatformString = "" - } - -initialLlvmConfig :: GHC.Driver.Session.LlvmConfig -initialLlvmConfig = GHC.Driver.Session.LlvmConfig - { GHC.Driver.Session.llvmPasses = [] - , GHC.Driver.Session.llvmTargets = [] - } - -initialPlatformConstants :: GHC.Settings.PlatformConstants -initialPlatformConstants = GHC.Settings.PlatformConstants - { GHC.Settings.pc_AP_STACK_SPLIM = 0 - , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0 - , GHC.Settings.pc_BLOCK_SIZE = 0 - , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0 - , GHC.Settings.pc_CINT_SIZE = 0 - , GHC.Settings.pc_CLONG_LONG_SIZE = 0 - , GHC.Settings.pc_CLONG_SIZE = 0 - , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0 - , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False - , GHC.Settings.pc_ILDV_CREATE_MASK = 0 - , GHC.Settings.pc_ILDV_STATE_CREATE = 0 - , GHC.Settings.pc_ILDV_STATE_USE = 0 - , GHC.Settings.pc_LDV_SHIFT = 0 - , GHC.Settings.pc_MAX_CHARLIKE = 0 - , GHC.Settings.pc_MAX_Double_REG = 0 - , GHC.Settings.pc_MAX_Float_REG = 0 - , GHC.Settings.pc_MAX_INTLIKE = 0 - , GHC.Settings.pc_MAX_Long_REG = 0 - , GHC.Settings.pc_MAX_Real_Double_REG = 0 - , GHC.Settings.pc_MAX_Real_Float_REG = 0 - , GHC.Settings.pc_MAX_Real_Long_REG = 0 - , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0 - , GHC.Settings.pc_MAX_Real_XMM_REG = 0 - , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0 - , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0 - , GHC.Settings.pc_MAX_Vanilla_REG = 0 - , GHC.Settings.pc_MAX_XMM_REG = 0 - , GHC.Settings.pc_MIN_CHARLIKE = 0 - , GHC.Settings.pc_MIN_INTLIKE = 0 - , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0 - , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0 - , GHC.Settings.pc_OFFSET_bdescr_blocks = 0 - , GHC.Settings.pc_OFFSET_bdescr_flags = 0 - , GHC.Settings.pc_OFFSET_bdescr_free = 0 - , GHC.Settings.pc_OFFSET_bdescr_start = 0 - , GHC.Settings.pc_OFFSET_Capability_r = 0 - , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0 - , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0 - , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0 - , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0 - , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0 - , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 - , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0 - , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0 - , GHC.Settings.pc_OFFSET_stgGCFun = 0 - , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0 - , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0 - , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0 - , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0 - , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0 - , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 - , GHC.Settings.pc_OFFSET_StgStack_sp = 0 - , GHC.Settings.pc_OFFSET_StgStack_stack = 0 - , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0 - , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0 - , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0 - , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0 - , GHC.Settings.pc_PROF_HDR_SIZE = 0 - , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0 - , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0 - , GHC.Settings.pc_REP_StgEntCounter_allocd = 0 - , GHC.Settings.pc_REP_StgEntCounter_allocs = 0 - , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0 - , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0 - , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0 - , GHC.Settings.pc_RESERVED_STACK_WORDS = 0 - , GHC.Settings.pc_SIZEOF_CostCentreStack = 0 - , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0 - , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 - , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0 - , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 - , GHC.Settings.pc_STD_HDR_SIZE = 0 - , GHC.Settings.pc_TAG_BITS = 0 - , GHC.Settings.pc_TICKY_BIN_COUNT = 0 - , GHC.Settings.pc_WORD_SIZE = 0 - } - -initialPlatformMini :: GHC.Settings.PlatformMini -initialPlatformMini = GHC.Settings.PlatformMini - { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 - , GHC.Settings.platformMini_os = GHC.Platform.OSLinux - } - -initialTargetPlatform :: GHC.Settings.Platform -initialTargetPlatform = GHC.Settings.Platform - { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian - , GHC.Settings.platformHasGnuNonexecStack = False - , GHC.Settings.platformHasIdentDirective = False - , GHC.Settings.platformHasSubsectionsViaSymbols = False - , GHC.Settings.platformIsCrossCompiling = False - , GHC.Settings.platformLeadingUnderscore = False - , GHC.Settings.platformMini = initialPlatformMini - , GHC.Settings.platformTablesNextToCode = False - , GHC.Settings.platformUnregisterised = False - , GHC.Settings.platformWordSize = GHC.Platform.PW8 - } - -initialToolSettings :: GHC.Settings.ToolSettings -initialToolSettings = GHC.Settings.ToolSettings - { GHC.Settings.toolSettings_ccSupportsNoPie = False - , GHC.Settings.toolSettings_extraGccViaCFlags = [] - , GHC.Settings.toolSettings_ldIsGnuLd = False - , GHC.Settings.toolSettings_ldSupportsBuildId = False - , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False - , GHC.Settings.toolSettings_ldSupportsFilelist = False - , GHC.Settings.toolSettings_opt_a = [] - , GHC.Settings.toolSettings_opt_c = [] - , GHC.Settings.toolSettings_opt_cxx = [] - , GHC.Settings.toolSettings_opt_F = [] - , GHC.Settings.toolSettings_opt_i = [] - , GHC.Settings.toolSettings_opt_l = [] - , GHC.Settings.toolSettings_opt_L = [] - , GHC.Settings.toolSettings_opt_lc = [] - , GHC.Settings.toolSettings_opt_lcc = [] - , GHC.Settings.toolSettings_opt_lm = [] - , GHC.Settings.toolSettings_opt_lo = [] - , GHC.Settings.toolSettings_opt_P = [] - , GHC.Settings.toolSettings_opt_P_fingerprint = - GHC.Utils.Fingerprint.fingerprint0 - , GHC.Settings.toolSettings_opt_windres = [] - , GHC.Settings.toolSettings_pgm_a = ("", []) - , GHC.Settings.toolSettings_pgm_ar = "" - , GHC.Settings.toolSettings_pgm_c = "" - , GHC.Settings.toolSettings_pgm_dll = ("", []) - , GHC.Settings.toolSettings_pgm_F = "" - , GHC.Settings.toolSettings_pgm_i = "" - , GHC.Settings.toolSettings_pgm_install_name_tool = "" - , GHC.Settings.toolSettings_pgm_l = ("", []) - , GHC.Settings.toolSettings_pgm_L = "" - , GHC.Settings.toolSettings_pgm_lc = ("", []) - , GHC.Settings.toolSettings_pgm_lcc = ("", []) - , GHC.Settings.toolSettings_pgm_libtool = "" - , GHC.Settings.toolSettings_pgm_lm = ("", []) - , GHC.Settings.toolSettings_pgm_lo = ("", []) - , GHC.Settings.toolSettings_pgm_otool = "" - , GHC.Settings.toolSettings_pgm_P = ("", []) - , GHC.Settings.toolSettings_pgm_ranlib = "" - , GHC.Settings.toolSettings_pgm_T = "" - , GHC.Settings.toolSettings_pgm_windres = "" - } diff --git a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs b/source/library/Language/Haskell/Brittany/Internal/Prelude.hs deleted file mode 100644 index 8198533..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Prelude.hs +++ /dev/null @@ -1,194 +0,0 @@ -module Language.Haskell.Brittany.Internal.Prelude - ( module E - ) where - -import Control.Applicative as E (Alternative(..), Applicative(..)) -import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) -import Control.Concurrent as E (forkIO, forkOS, threadDelay) -import Control.Concurrent.Chan as E (Chan) -import Control.Concurrent.MVar as E - (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) -import Control.Exception as E (assert, bracket, evaluate) -import Control.Monad as E - ( (<$!>) - , (<=<) - , (=<<) - , (>=>) - , Functor(..) - , Monad(..) - , MonadPlus(..) - , filterM - , forM - , forM_ - , forever - , guard - , join - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , mapM - , mapM_ - , replicateM - , replicateM_ - , sequence - , sequence_ - , unless - , void - , when - ) -import Control.Monad.Extra as E - (allM, andM, anyM, ifM, notM, orM, unlessM, whenM) -import Control.Monad.IO.Class as E (MonadIO(..)) -import Control.Monad.ST as E (ST) -import Control.Monad.Trans.Class as E (lift) -import Control.Monad.Trans.Maybe as E (MaybeT(..)) -import Control.Monad.Trans.MultiRWS as E - (MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet) -import Data.Bifunctor as E (bimap) -import Data.Bool as E (Bool(..)) -import Data.Char as E (Char, chr, ord) -import Data.Data as E (toConstr) -import Data.Either as E (Either(..), either) -import Data.Foldable as E (asum, fold, foldl', foldr') -import Data.Function as E ((&), fix) -import Data.Functor as E (($>)) -import Data.Functor.Identity as E (Identity(..)) -import Data.IORef as E (IORef) -import Data.Int as E (Int) -import Data.List as E - ( all - , break - , drop - , dropWhile - , elem - , filter - , find - , intercalate - , intersperse - , isPrefixOf - , isSuffixOf - , iterate - , length - , mapAccumL - , mapAccumR - , maximum - , minimum - , notElem - , nub - , null - , partition - , repeat - , replicate - , sortBy - , sum - , take - , takeWhile - , transpose - , uncons - , unzip - , zip - , zip3 - , zipWith - ) -import Data.List.Extra as E (nubOrd, stripSuffix) -import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) -import Data.Map as E (Map) -import Data.Maybe as E - (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) -import Data.Monoid as E - ( All(..) - , Alt(..) - , Any(..) - , Endo(..) - , Monoid(..) - , Product(..) - , Sum(..) - , mconcat - ) -import Data.Ord as E (Down(..), Ordering(..), comparing) -import Data.Proxy as E (Proxy(..)) -import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) -import Data.Semigroup as E ((<>), Semigroup(..)) -import Data.Sequence as E (Seq) -import Data.Set as E (Set) -import Data.String as E (String) -import Data.Text as E (Text) -import Data.Tree as E (Tree(..)) -import Data.Tuple as E (swap) -import Data.Typeable as E (Typeable) -import Data.Version as E (showVersion) -import Data.Void as E (Void) -import Data.Word as E (Word, Word32) -import Debug.Trace as E - ( trace - , traceIO - , traceId - , traceM - , traceShow - , traceShowId - , traceShowM - , traceStack - ) -import Foreign.ForeignPtr as E (ForeignPtr) -import Foreign.Storable as E (Storable) -import GHC.Exts as E (Constraint) -import GHC.Hs.Extension as E (GhcPs) -import GHC.Types.Name.Reader as E (RdrName) -import Prelude as E - ( ($) - , ($!) - , (&&) - , (++) - , (.) - , (<$>) - , Bounded(..) - , Double - , Enum(..) - , Eq(..) - , Float - , Floating(..) - , Foldable - , Fractional(..) - , Integer - , Integral(..) - , Num(..) - , Ord(..) - , RealFloat(..) - , RealFrac(..) - , Show(..) - , Traversable - , (^) - , and - , any - , const - , curry - , error - , flip - , foldl - , foldr - , foldr1 - , fromIntegral - , fst - , head - , id - , map - , not - , or - , otherwise - , print - , putStr - , putStrLn - , realToFrac - , reverse - , seq - , snd - , subtract - , traverse - , uncurry - , undefined - , (||) - ) -import System.IO as E (IO, hFlush, stdout) -import Text.Read as E (readMaybe) diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs deleted file mode 100644 index 5cca1ca..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ /dev/null @@ -1,961 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Language.Haskell.Brittany.Internal.Transformations.Alt where - -import qualified Control.Monad.Memo as Memo -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import Data.HList.ContainsType -import qualified Data.List.Extra -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - -data AltCurPos = AltCurPos - { _acp_line :: Int -- chars in the current line - , _acp_indent :: Int -- current indentation level - , _acp_indentPrep :: Int -- indentChange affecting the next Par - , _acp_forceMLFlag :: AltLineModeState - } - deriving Show - -data AltLineModeState - = AltLineModeStateNone - | AltLineModeStateForceML Bool -- true ~ decays on next wrap - | AltLineModeStateForceSL - | AltLineModeStateContradiction - -- i.e. ForceX False -> ForceX True -> None - deriving (Show) - -altLineModeRefresh :: AltLineModeState -> AltLineModeState -altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone -altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False -altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeRefresh AltLineModeStateContradiction = - AltLineModeStateContradiction - -altLineModeDecay :: AltLineModeState -> AltLineModeState -altLineModeDecay AltLineModeStateNone = AltLineModeStateNone -altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True -altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone -altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL -altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction - -mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos -mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of - (AltLineModeStateContradiction, _) -> acp - (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } - (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp - (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> - acp { _acp_forceMLFlag = s } - _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } - - --- removes any BDAlt's from the BriDoc -transformAlts - :: forall r w s - . ( Data.HList.ContainsType.ContainsType Config r - , Data.HList.ContainsType.ContainsType (Seq String) w - ) - => BriDocNumbered - -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts = - MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) - . Memo.startEvalMemoT - . fmap unwrapBriDocNumbered - . rec - where - -- this function is exponential by nature and cannot be improved in any - -- way i can think of, and i've tried. (stupid StableNames.) - -- transWrap :: BriDoc -> BriDocNumbered - -- transWrap brDc = flip StateS.evalState (1::Int) - -- $ Memo.startEvalMemoT - -- $ go brDc - -- where - -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i - -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered - -- go = Memo.memo $ \bdX -> do - -- i <- lift $ incGet - -- fmap (\bd' -> (i,bd')) $ case bdX of - -- BDEmpty -> return $ BDFEmpty - -- BDLit t -> return $ BDFLit t - -- BDSeq list -> BDFSeq <$> go `mapM` list - -- BDCols sig list -> BDFCols sig <$> go `mapM` list - -- BDSeparator -> return $ BDFSeparator - -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd - -- BDSetBaseY bd -> BDFSetBaseY <$> go bd - -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd - -- BDPar ind line indented -> [ BDFPar ind line' indented' - -- | line' <- go line - -- , indented' <- go indented - -- ] - -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen - -- BDForceMultiline bd -> BDFForceMultiline <$> go bd - -- BDForceSingleline bd -> BDFForceSingleline <$> go bd - -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd - -- BDExternal k ks c t -> return $ BDFExternal k ks c t - -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd - -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd - -- BDLines lines -> BDFLines <$> go `mapM` lines - -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd - -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd - - - - rec - :: BriDocNumbered - -> Memo.MemoT - Int - [VerticalSpacing] - (MultiRWSS.MultiRWS r w (AltCurPos ': s)) - BriDocNumbered - rec bdX@(brDcId, brDc) = do - let reWrap = (,) brDcId - -- debugAcp :: AltCurPos <- mGet - case brDc of - -- BDWrapAnnKey annKey bd -> do - -- acp <- mGet - -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - -- BDWrapAnnKey annKey <$> rec bd - BDFEmpty{} -> processSpacingSimple bdX $> bdX - BDFLit{} -> processSpacingSimple bdX $> bdX - BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec - BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec - BDFSeparator -> processSpacingSimple bdX $> bdX - BDFAddBaseY indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r - BDFBaseYPushCur bd -> do - acp <- mGet - mSet $ acp { _acp_indent = _acp_line acp } - r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r - BDFIndentLevelPushCur bd -> do - reWrap . BDFIndentLevelPushCur <$> rec bd - BDFIndentLevelPop bd -> do - reWrap . BDFIndentLevelPop <$> rec bd - BDFPar indent sameLine indented -> do - indAmount <- - mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let - indAdd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - acp <- mGet - let ind = _acp_indent acp + _acp_indentPrep acp + indAdd - mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } - sameLine' <- rec sameLine - mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } - indented' <- rec indented - return $ reWrap $ BDFPar indent sameLine' indented' - BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a - -- possibility, but i will prefer a - -- fail-early approach; BDEmpty does not - -- make sense semantically for Alt[]. - BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack - case altChooser of - AltChooserSimpleQuick -> do - rec $ head alts - AltChooserShallowBest -> do - spacings <- alts `forM` getSpacing - acp <- mGet - let - lineCheck LineModeInvalid = False - lineCheck (LineModeValid (VerticalSpacing _ p _)) = - case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - -- TODO: use COMPLETE pragma instead? - lineCheck _ = error "ghc exhaustive check is insufficient" - lconf <- _conf_layout <$> mAsk - let - options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - (hasSpace1 lconf acp vs && lineCheck vs, bd) - ) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust - (\(_i :: Int, (b, x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ] - ) - $ zip [1 ..] options - AltChooserBoundedSearch limit -> do - spacings <- alts `forM` getSpacings limit - acp <- mGet - let - lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of - AltLineModeStateNone -> True - AltLineModeStateForceSL{} -> p == VerticalSpacingParNone - AltLineModeStateForceML{} -> p /= VerticalSpacingParNone - AltLineModeStateContradiction -> False - lconf <- _conf_layout <$> mAsk - let - options = -- trace ("considering options:" ++ show (length alts, acp)) $ - (zip spacings alts - <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) - (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) - ) - let - checkedOptions :: [Maybe (Int, BriDocNumbered)] = - zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) - rec - $ fromMaybe (-- trace ("choosing last") $ - List.last alts) - $ Data.List.Extra.firstJust (fmap snd) checkedOptions - BDFForceMultiline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp (AltLineModeStateForceML False) - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForceSingleline bd -> do - acp <- mGet - x <- do - mSet $ mergeLineMode acp AltLineModeStateForceSL - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFForwardLineMode bd -> do - acp <- mGet - x <- do - mSet $ acp - { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp - } - rec bd - acp' <- mGet - mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } - return $ x - BDFExternal{} -> processSpacingSimple bdX $> bdX - BDFPlain{} -> processSpacingSimple bdX $> bdX - BDFAnnotationPrior annKey bd -> do - acp <- mGet - mSet - $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } - bd' <- rec bd - return $ reWrap $ BDFAnnotationPrior annKey bd' - BDFAnnotationRest annKey bd -> - reWrap . BDFAnnotationRest annKey <$> rec bd - BDFAnnotationKW annKey kw bd -> - reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw b bd -> - reWrap . BDFMoveToKWDP annKey kw b <$> rec bd - BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. - BDFLines (l : lr) -> do - ind <- _acp_indent <$> mGet - l' <- rec l - lr' <- lr `forM` \x -> do - mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } - rec x - return $ reWrap $ BDFLines (l' : lr') - BDFEnsureIndent indent bd -> do - acp <- mGet - indAdd <- fixIndentationForMultiple acp indent - mSet $ acp - { _acp_indentPrep = 0 - -- TODO: i am not sure this is valid, in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) - -- we cannot use just _acp_line acp + indAdd because of the case - -- where there are multiple BDFEnsureIndents in the same line. - -- Then, the actual indentation is relative to the current - -- indentation, not the current cursor position. - } - r <- rec bd - acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indent acp } - return $ case indent of - BrIndentNone -> r - BrIndentRegular -> - reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r - BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing _ bd -> rec bd - BDFSetParSpacing bd -> rec bd - BDFForceParSpacing bd -> rec bd - BDFDebug s bd -> do - acp :: AltCurPos <- mGet - tellDebugMess - $ "transformAlts: BDFDEBUG " - ++ s - ++ " (node-id=" - ++ show brDcId - ++ "): acp=" - ++ show acp - reWrap . BDFDebug s <$> rec bd - processSpacingSimple - :: ( MonadMultiReader Config m - , MonadMultiState AltCurPos m - , MonadMultiWriter (Seq String) m - ) - => BriDocNumbered - -> m () - processSpacingSimple bd = getSpacing bd >>= \case - LineModeInvalid -> error "processSpacingSimple inv" - LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do - acp <- mGet - mSet $ acp { _acp_line = _acp_line acp + i } - LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" - _ -> error "ghc exhaustive check is insufficient" - hasSpace1 - :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool - hasSpace1 _ _ LineModeInvalid = False - hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs - hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" - hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line - + sameLine - <= confUnpack (_lconfig_cols lconf) - && indent - + indentPrep - + par - <= confUnpack (_lconfig_cols lconf) - hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) - = line + sameLine <= confUnpack (_lconfig_cols lconf) - -getSpacing - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => BriDocNumbered - -> m (LineModeValidity VerticalSpacing) -getSpacing !bridoc = rec bridoc - where - rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) - rec (brDcId, brDc) = do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - result <- case brDc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLit t -> return $ LineModeValid $ VerticalSpacing - (Text.length t) - VerticalSpacingParNone - False - BDFSeq list -> sumVs <$> rec `mapM` list - BDFCols _sig list -> sumVs <$> rec `mapM` list - BDFSeparator -> - return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> - VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max - (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i - ) - , _vs_paragraph = VerticalSpacingParSome 0 - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVs <- rec sameLine - mIndSp <- rec indented - return - $ [ VerticalSpacing lsp pspResult parFlagResult - | VerticalSpacing lsp mPsp _ <- mVs - , indSp <- mIndSp - , lineMax <- getMaxVS $ mIndSp - , let - pspResult = case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp lineMax - VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp lineMax - , let - parFlagResult = - mPsp - == VerticalSpacingParNone - && _vs_paragraph indSp - == VerticalSpacingParNone - && _vs_parFlag indSp - ] - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - BDFAlt (alt : _) -> rec alt - BDFForceMultiline bd -> do - mVs <- rec bd - return $ mVs >>= _vs_paragraph .> \case - VerticalSpacingParNone -> LineModeInvalid - _ -> mVs - BDFForceSingleline bd -> do - mVs <- rec bd - return $ mVs >>= _vs_paragraph .> \case - VerticalSpacingParNone -> mVs - _ -> LineModeInvalid - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False - BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of - [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False - _ -> VerticalSpacing 999 VerticalSpacingParNone False - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> - return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False - BDFLines ls@(_ : _) -> do - lSps <- rec `mapM` ls - let (mVs : _) = lSps -- separated into let to avoid MonadFail - return - $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False - | VerticalSpacing lsp _ _ <- mVs - , lineMax <- getMaxVS $ maxVs $ lSps - ] - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let - addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp pf) -> - VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing b bd -> do - mVs <- rec bd - return $ mVs <|> LineModeValid - (VerticalSpacing - 0 - (if b - then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ) - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- rec bd - return - $ [ vs - | vs <- mVs - , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone - ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess - $ "getSpacing: BDFDebug " - ++ show s - ++ " (node-id=" - ++ show brDcId - ++ "): mVs=" - ++ show r - return r - return result - maxVs - :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - maxVs = foldl' - (liftM2 - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y - ) - False - ) - ) - (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) - sumVs - :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing - sumVs sps = foldl' (liftM2 go) initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) - x3 - singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone - singleline _ = False - isPar (LineModeValid x) = _vs_parFlag x - isPar _ = False - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int - getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - -data SpecialCompare = Unequal | Smaller | Bigger - -getSpacings - :: forall m - . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) - => Int - -> BriDocNumbered - -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] -getSpacings limit bridoc = preFilterLimit <$> rec bridoc - where - -- when we do `take K . filter someCondition` on a list of spacings, we - -- need to first (also) limit the size of the input list, otherwise a - -- _large_ input with a similarly _large_ prefix not passing our filtering - -- process could lead to exponential runtime behaviour. - -- TODO: 3 is arbitrary. - preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] - preFilterLimit = take (3 * limit) - memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v - memoWithKey k v = Memo.memo (const v) k - rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] - rec (brDcId, brdc) = memoWithKey brDcId $ do - config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & confUnpack - let - hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of - VerticalSpacingParNone -> True - VerticalSpacingParSome i -> i <= colMax - VerticalSpacingParAlways{} -> True - let - specialCompare vs1 vs2 = - if ((_vs_sameLine vs1 == _vs_sameLine vs2) - && (_vs_parFlag vs1 == _vs_parFlag vs2) - ) - then case (_vs_paragraph vs1, _vs_paragraph vs2) of - (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) -> - if i1 < i2 then Smaller else Bigger - (p1, p2) -> if p1 == p2 then Smaller else Unequal - else Unequal - let - allowHangingQuasiQuotes = - config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack - let -- this is like List.nub, with one difference: if two elements - -- are unequal only in _vs_paragraph, with both ParAlways, we - -- treat them like equals and replace the first occurence with the - -- smallest member of this "equal group". - specialNub :: [VerticalSpacing] -> [VerticalSpacing] - specialNub [] = [] - specialNub (x1 : xr) = case go x1 xr of - (r, xs') -> r : specialNub xs' - where - go y1 [] = (y1, []) - go y1 (y2 : yr) = case specialCompare y1 y2 of - Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr') - Smaller -> go y1 yr - Bigger -> go y2 yr - let -- the standard function used to enforce a constant upper bound - -- on the number of elements returned for each node. Should be - -- applied whenever in a parent the combination of spacings from - -- its children might cause excess of the upper bound. - filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] - filterAndLimit = - take limit - -- prune so we always consider a constant - -- amount of spacings per node of the BriDoc. - . specialNub - -- In the end we want to know if there is at least - -- one valid spacing for any alternative. - -- If there are duplicates in the list, then these - -- will either all be valid (so having more than the - -- first is pointless) or all invalid (in which - -- case having any of them is pointless). - -- Nonetheless I think the order of spacings should - -- be preserved as it provides a deterministic - -- choice for which spacings to prune (which is - -- an argument against simply using a Set). - -- I have also considered `fmap head . group` which - -- seems to work similarly well for common cases - -- and which might behave even better when it comes - -- to determinism of the algorithm. But determinism - -- should not be overrated here either - in the end - -- this is about deterministic behaviour of the - -- pruning we do that potentially results in - -- non-optimal layouts, and we'd rather take optimal - -- layouts when we can than take non-optimal layouts - -- just to be consistent with other cases where - -- we'd choose non-optimal layouts. - . filter hasOkColCount - -- throw out any spacings (i.e. children) that - -- already use more columns than available in - -- total. - . preFilterLimit - result <- case brdc of - -- BDWrapAnnKey _annKey bd -> rec bd - BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLit t -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list - BDFSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False] - BDFAddBaseY indent bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - { _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> - VerticalSpacingParAlways $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i - + (confUnpack - $ _lconfig_indentAmount - $ _conf_layout - $ config - ) - BrIndentSpecial j -> i + j - VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of - BrIndentNone -> i - BrIndentRegular -> - i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config) - BrIndentSpecial j -> i + j - } - BDFBaseYPushCur bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs - -- We leave par as-is, even though it technically is not - -- accurate (in general). - -- the reason is that we really want to _keep_ it Just if it is - -- just so we properly communicate the is-multiline fact. - -- An alternative would be setting to (Just 0). - { _vs_sameLine = max - (_vs_sameLine vs) - (case _vs_paragraph vs of - VerticalSpacingParNone -> 0 - VerticalSpacingParSome i -> i - VerticalSpacingParAlways i -> min colMax i - ) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParSome i -> VerticalSpacingParSome i - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - } - BDFBaseYPop bd -> rec bd - BDFIndentLevelPushCur bd -> rec bd - BDFIndentLevelPop bd -> rec bd - BDFPar BrIndentNone sameLine indented -> do - mVss <- filterAndLimit <$> rec sameLine - indSps <- filterAndLimit <$> rec indented - let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] - return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> - VerticalSpacing - lsp - (case mPsp of - VerticalSpacingParSome psp -> - VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO - VerticalSpacingParNone -> spMakePar indSp - VerticalSpacingParAlways psp -> - VerticalSpacingParAlways $ max psp $ getMaxVS indSp - ) - (mPsp - == VerticalSpacingParNone - && _vs_paragraph indSp - == VerticalSpacingParNone - && _vs_parFlag indSp - ) - - BDFPar{} -> error "BDPar with indent in getSpacing" - BDFAlt [] -> error "empty BDAlt" - -- BDAlt (alt:_) -> rec alt - BDFAlt alts -> do - r <- rec `mapM` alts - return $ filterAndLimit =<< r - BDFForceMultiline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForceSingleline bd -> do - mVs <- filterAndLimit <$> rec bd - return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs - BDFForwardLineMode bd -> rec bd - BDFExternal _ _ _ txt | [t] <- Text.lines txt -> - return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] - BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout - -- this. - BDFPlain t -> return - [ case Text.lines t of - [] -> VerticalSpacing 0 VerticalSpacingParNone False - [t1] -> - VerticalSpacing (Text.length t1) VerticalSpacingParNone False - (t1 : _) -> - VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True - | allowHangingQuasiQuotes - ] - BDFAnnotationPrior _annKey bd -> rec bd - BDFAnnotationKW _annKey _kw bd -> rec bd - BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw _b bd -> rec bd - BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] - BDFLines ls@(_ : _) -> do - -- we simply assume that lines is only used "properly", i.e. in - -- such a way that the first line can be treated "as a part of the - -- paragraph". That most importantly means that Lines should never - -- be inserted anywhere but at the start of the line. A - -- counterexample would be anything like Seq[Lit "foo", Lines]. - lSpss <- map filterAndLimit <$> rec `mapM` ls - let - worbled = fmap reverse $ sequence $ reverse $ lSpss - sumF lSps@(lSp1 : _) = - VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False - sumF [] = - error - $ "should not happen. if my logic does not fail" - ++ "me, this follows from not (null ls)." - return $ sumF <$> worbled - -- lSpss@(mVs:_) <- rec `mapM` ls - -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only - -- -- consider the first alternative for the - -- -- line's spacings. - -- -- also i am not sure if always including - -- -- the first line length in the paragraph - -- -- length gives the desired results. - -- -- it is the safe path though, for now. - -- [] -> [] - -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> - -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps - BDFEnsureIndent indent bd -> do - mVs <- rec bd - let - addInd = case indent of - BrIndentNone -> 0 - BrIndentRegular -> - confUnpack $ _lconfig_indentAmount $ _conf_layout $ config - BrIndentSpecial i -> i - return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> - VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing b bd -> do - -- TODO: the `b` flag is an ugly hack, but I was not able to make - -- all tests work without it. It should be possible to have - -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this - -- problem but breaks certain other cases. - mVs <- rec bd - return $ if null mVs - then - [ VerticalSpacing - 0 - (if b - then VerticalSpacingParSome 0 - else VerticalSpacingParAlways colMax - ) - False - ] - else mVs <&> \vs -> vs - { _vs_sameLine = min colMax (_vs_sameLine vs) - , _vs_paragraph = case _vs_paragraph vs of - VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - VerticalSpacingParSome i - | b -> VerticalSpacingParSome 0 - | otherwise -> VerticalSpacingParAlways i - } - -- the version below is an alternative idea: fold the input - -- spacings into a single spacing. This was hoped to improve in - -- certain cases where non-bottom alternatives took up "too much - -- explored search space"; the downside is that it also cuts - -- the search-space short in other cases where it is not necessary, - -- leading to unnecessary new-lines. Disabled for now. A better - -- solution would require conditionally folding the search-space - -- only in appropriate locations (i.e. a new BriDoc node type - -- for this purpose, perhaps "BDFNonBottomSpacing1"). - -- else - -- [ Foldable.foldl1 - -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> - -- VerticalSpacing - -- (min x1 y1) - -- (case (x2, y2) of - -- (x, VerticalSpacingParNone) -> x - -- (VerticalSpacingParNone, x) -> x - -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - -- VerticalSpacingParAlways $ min i j - -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - -- VerticalSpacingParSome $ min x y) - -- False) - -- mVs - -- ] - BDFSetParSpacing bd -> do - mVs <- rec bd - return $ mVs <&> \vs -> vs { _vs_parFlag = True } - BDFForceParSpacing bd -> do - mVs <- preFilterLimit <$> rec bd - return - $ [ vs - | vs <- mVs - , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone - ] - BDFDebug s bd -> do - r <- rec bd - tellDebugMess - $ "getSpacings: BDFDebug " - ++ show s - ++ " (node-id=" - ++ show brDcId - ++ "): vs=" - ++ show (take 9 r) - return r - return result - maxVs :: [VerticalSpacing] -> VerticalSpacing - maxVs = foldl' - (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing - (max x1 y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ max i j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ max x y - ) - False - ) - (VerticalSpacing 0 VerticalSpacingParNone False) - sumVs :: [VerticalSpacing] -> VerticalSpacing - sumVs sps = foldl' go initial sps - where - go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing - (x1 + y1) - (case (x2, y2) of - (x, VerticalSpacingParNone) -> x - (VerticalSpacingParNone, x) -> x - (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> - VerticalSpacingParAlways $ i + j - (VerticalSpacingParSome x, VerticalSpacingParSome y) -> - VerticalSpacingParSome $ x + y - ) - x3 - singleline x = _vs_paragraph x == VerticalSpacingParNone - isPar x = _vs_parFlag x - parFlag = case sps of - [] -> True - _ -> all singleline (List.init sps) && isPar (List.last sps) - initial = VerticalSpacing 0 VerticalSpacingParNone parFlag - getMaxVS :: VerticalSpacing -> Int - getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of - VerticalSpacingParSome i -> i - VerticalSpacingParNone -> 0 - VerticalSpacingParAlways i -> i - spMakePar :: VerticalSpacing -> VerticalSpacingPar - spMakePar (VerticalSpacing x1 x2 _) = case x2 of - VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i - VerticalSpacingParNone -> VerticalSpacingParSome $ x1 - VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i - -fixIndentationForMultiple - :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int -fixIndentationForMultiple acp indent = do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - let - indAddRaw = case indent of - BrIndentNone -> 0 - BrIndentRegular -> indAmount - BrIndentSpecial i -> i - -- for IndentPolicyMultiple, we restrict the amount of added - -- indentation in such a manner that we end up on a multiple of the - -- base indentation. - indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - pure $ if indPolicy == IndentPolicyMultiple - then - let - indAddMultiple1 = - indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) - indAddMultiple2 = if indAddMultiple1 <= 0 - then indAddMultiple1 + indAmount - else indAddMultiple1 - in indAddMultiple2 - else indAddRaw diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs deleted file mode 100644 index 0d2231e..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Transformations.Columns where - -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types - - - -transformSimplifyColumns :: BriDoc -> BriDoc -transformSimplifyColumns = Uniplate.rewrite $ \case - -- BDWrapAnnKey annKey bd -> - -- BDWrapAnnKey annKey $ transformSimplify bd - BDEmpty -> Nothing - BDLit{} -> Nothing - BDSeq list - | any - (\case - BDSeq{} -> True - BDEmpty{} -> True - _ -> False - ) - list - -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_ : _) : rest) - | all - (\case - BDSeparator -> True - _ -> False - ) - rest - -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)]) - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case - BDLines l -> l - x -> [x] - -- prior floating in - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) - -- post floating in - BDAnnotationRest annKey1 (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] - -- ensureIndent float-in - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- matching col special transformation - BDCols sig1 cols1@(_ : _) - | BDLines lines@(_ : _ : _) <- List.last cols1 - , BDCols sig2 cols2 <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDCols sig1 cols1@(_ : _) - | BDLines lines@(_ : _ : _) <- List.last cols1 - , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] - , BDCols sig2 cols2 - ] - BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> - Just $ BDAddBaseY ind (BDLines [col1, col2]) - BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) - | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) - BDPar ind (BDLines lines1) col2@(BDCols sig2 _) - | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just - $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) - BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) - | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just - $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) - -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) - -- | sig1==sig2 -> - -- Just $ BDPar - -- ind1 - -- (BDLines [BDCols sig1 cols1, BDCols sig]) - BDCols sig1 cols - | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 - -> Just - $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] - BDCols sig1 cols - | BDPar ind line (BDLines lines) <- List.last cols - , BDCols sig2 cols2 <- List.last lines - , sig1 == sig2 - -> Just $ BDLines - [ BDCols sig1 - $ List.init cols - ++ [BDPar ind line (BDLines $ List.init lines)] - , BDCols sig2 cols2 - ] - BDLines [x] -> Just $ x - BDLines [] -> Just $ BDEmpty - BDSeq{} -> Nothing - BDCols{} -> Nothing - BDSeparator -> Nothing - BDAddBaseY{} -> Nothing - BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing - BDIndentLevelPushCur{} -> Nothing - BDIndentLevelPop{} -> Nothing - BDPar{} -> Nothing - BDAlt{} -> Nothing - BDForceMultiline{} -> Nothing - BDForceSingleline{} -> Nothing - BDForwardLineMode{} -> Nothing - BDExternal{} -> Nothing - BDPlain{} -> Nothing - BDLines{} -> Nothing - BDAnnotationPrior{} -> Nothing - BDAnnotationKW{} -> Nothing - BDAnnotationRest{} -> Nothing - BDMoveToKWDP{} -> Nothing - BDEnsureIndent{} -> Nothing - BDSetParSpacing{} -> Nothing - BDForceParSpacing{} -> Nothing - BDDebug{} -> Nothing - BDNonBottomSpacing _ x -> Just x diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs deleted file mode 100644 index 919decf..0000000 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Internal.Transformations.Floating where - -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils - - - --- note that this is not total, and cannot be with that exact signature. -mergeIndents :: BrIndent -> BrIndent -> BrIndent -mergeIndents BrIndentNone x = x -mergeIndents x BrIndentNone = x -mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = - BrIndentSpecial (max i j) -mergeIndents _ _ = error "mergeIndents" - - -transformSimplifyFloating :: BriDoc -> BriDoc -transformSimplifyFloating = stepBO .> stepFull - -- note that semantically, stepFull is completely sufficient. - -- but the bottom-up switch-to-top-down-on-match transformation has much - -- better complexity. - -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence - -- the push/pop cases would need to be copied over - where - descendPrior = transformDownMay $ \case - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) - BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x - BDAnnotationPrior annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationPrior annKey1 x - _ -> Nothing - descendRest = transformDownMay $ \case - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - BDAnnotationRest annKey1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x - BDAnnotationRest annKey1 (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationRest annKey1 x - _ -> Nothing - descendKW = transformDownMay $ \case - -- post floating in - BDAnnotationKW annKey1 kw (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented - BDAnnotationKW annKey1 kw (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationKW annKey1 kw $ List.last list] - BDAnnotationKW annKey1 kw (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationKW annKey1 kw $ List.last cols] - BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x - BDAnnotationKW annKey1 kw (BDDebug s x) -> - Just $ BDDebug s $ BDAnnotationKW annKey1 kw x - _ -> Nothing - descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) - BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) - _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) - _ -> Nothing - descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) - BDIndentLevelPushCur (BDDebug s x) -> - Just $ BDDebug s (BDIndentLevelPushCur x) - _ -> Nothing - descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) - BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) - _ -> Nothing - descendAddB = transformDownMay $ \case - BDAddBaseY BrIndentNone x -> Just x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> - Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationRest annKey1 x) -> - Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) - BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> - Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) - BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPop x) -> - Just $ BDIndentLevelPop (BDAddBaseY ind x) - BDAddBaseY ind (BDIndentLevelPushCur x) -> - Just $ BDIndentLevelPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDEnsureIndent ind2 x) -> - Just $ BDEnsureIndent (mergeIndents ind ind2) x - _ -> Nothing - stepBO :: BriDoc -> BriDoc - stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - transformUp f - where - f = \case - x@BDAnnotationPrior{} -> descendPrior x - x@BDAnnotationKW{} -> descendKW x - x@BDAnnotationRest{} -> descendRest x - x@BDAddBaseY{} -> descendAddB x - x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x - x@BDIndentLevelPushCur{} -> descendILPush x - x@BDIndentLevelPop{} -> descendILPop x - x -> x - stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ - Uniplate.rewrite $ \case - BDAddBaseY BrIndentNone x -> Just $ x - -- AddIndent floats into Lines. - BDAddBaseY indent (BDLines lines) -> - Just $ BDLines $ BDAddBaseY indent <$> lines - -- AddIndent floats into last column - BDAddBaseY indent (BDCols sig cols) -> - Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] - BDAddBaseY ind (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] - -- merge AddIndent and Par - BDAddBaseY ind1 (BDPar ind2 line indented) -> - Just $ BDPar (mergeIndents ind1 ind2) line indented - BDAddBaseY _ lit@BDLit{} -> Just $ lit - BDAddBaseY ind (BDBaseYPushCur x) -> - Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) - -- prior floating in - BDAnnotationPrior annKey1 (BDPar ind line indented) -> - Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented - BDAnnotationPrior annKey1 (BDSeq (l : lr)) -> - Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDLines (l : lr)) -> - Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr) - BDAnnotationPrior annKey1 (BDCols sig (l : lr)) -> - Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr) - -- EnsureIndent float-in - -- BDEnsureIndent indent (BDCols sig (col:colr)) -> - -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) - -- not sure if the following rule is necessary; tests currently are - -- unaffected. - -- BDEnsureIndent indent (BDLines lines) -> - -- Just $ BDLines $ BDEnsureIndent indent <$> lines - -- post floating in - BDAnnotationRest annKey1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDAnnotationRest annKey1 indented - BDAnnotationRest annKey1 (BDSeq list) -> - Just - $ BDSeq - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDLines list) -> - Just - $ BDLines - $ List.init list - ++ [BDAnnotationRest annKey1 $ List.last list] - BDAnnotationRest annKey1 (BDCols sig cols) -> - Just - $ BDCols sig - $ List.init cols - ++ [BDAnnotationRest annKey1 $ List.last cols] - _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Main.hs b/source/library/Language/Haskell/Brittany/Main.hs deleted file mode 100644 index e599fc2..0000000 --- a/source/library/Language/Haskell/Brittany/Main.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Language.Haskell.Brittany.Main where - -import Control.Monad (zipWithM) -import qualified Control.Monad.Trans.Except as ExceptT -import Data.CZipWith -import qualified Data.Either -import qualified Data.List.Extra -import qualified Data.Monoid -import qualified Data.Semigroup as Semigroup -import qualified Data.Text as Text -import qualified Data.Text.IO as Text.IO -import qualified Data.Text.Lazy as TextL -import DataTreePrint -import GHC (GenLocated(L)) -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as GHC -import qualified GHC.OldList as List -import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Obfuscation -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Paths_brittany -import qualified System.Directory as Directory -import qualified System.Environment as Environment -import qualified System.Exit -import qualified System.FilePath.Posix as FilePath -import qualified System.IO -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Text.PrettyPrint as PP -import Text.Read (Read(..)) -import UI.Butcher.Monadic - - - -data WriteMode = Display | Inplace - -instance Read WriteMode where - readPrec = val "display" Display <|> val "inplace" Inplace - where val iden v = ReadPrec.lift $ ReadP.string iden >> return v - -instance Show WriteMode where - show Display = "display" - show Inplace = "inplace" - - -main :: IO () -main = do - progName <- Environment.getProgName - args <- Environment.getArgs - mainWith progName args - -mainWith :: String -> [String] -> IO () -mainWith progName args = - Environment.withProgName progName - . Environment.withArgs args - $ mainFromCmdParserWithHelpDesc mainCmdParser - -helpDoc :: PP.Doc -helpDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDocW - [ "Reformats one or more haskell modules." - , "Currently affects only the module head (imports/exports), type" - , "signatures and function bindings;" - , "everything else is left unmodified." - , "Based on ghc-exactprint, thus (theoretically) supporting all" - , "that ghc does." - ] - , parDoc $ "Example invocations:" - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany" - , PP.nest 2 $ PP.text "read from stdin, output to stdout" - ] - , PP.hang (PP.text "") 2 $ PP.vcat - [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" - , PP.nest 2 $ PP.vcat - [ PP.text "run on all modules in current directory (no backup!)" - , PP.text "4 spaces indentation" - ] - ] - , parDocW - [ "This program is written carefully and contains safeguards to ensure" - , "the output is syntactically valid and that no comments are removed." - , "Nonetheless, this is a young project, and there will always be bugs," - , "and ensuring that the transformation never changes semantics of the" - , "transformed source is currently not possible." - , "Please do check the output and do not let brittany override your large" - , "codebase without having backups." - ] - , parDoc $ "There is NO WARRANTY, to the extent permitted by law." - , parDocW - [ "This program is free software released under the AGPLv3." - , "For details use the --license flag." - ] - , parDoc $ "See https://github.com/lspitzner/brittany" - , parDoc - $ "Please report bugs at" - ++ " https://github.com/lspitzner/brittany/issues" - ] - -licenseDoc :: PP.Doc -licenseDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" - , parDoc $ "Copyright (C) 2019 PRODA LTD" - , parDocW - [ "This program is free software: you can redistribute it and/or modify" - , "it under the terms of the GNU Affero General Public License," - , "version 3, as published by the Free Software Foundation." - ] - , parDocW - [ "This program is distributed in the hope that it will be useful," - , "but WITHOUT ANY WARRANTY; without even the implied warranty of" - , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , "GNU Affero General Public License for more details." - ] - , parDocW - [ "You should have received a copy of the GNU Affero General Public" - , "License along with this program. If not, see" - , "<http://www.gnu.org/licenses/>." - ] - ] - - -mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () -mainCmdParser helpDesc = do - addCmdSynopsis "haskell source pretty printer" - addCmdHelp $ helpDoc - -- addCmd "debugArgs" $ do - addHelpCommand helpDesc - addCmd "license" $ addCmdImpl $ print $ licenseDoc - -- addButcherDebugCommand - reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams - "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser - suppressOutput <- addSimpleBoolFlag - "" - ["suppress-output"] - (flagHelp $ parDoc - "suppress the regular output, i.e. the transformed haskell source" - ) - _verbosity <- addSimpleCountFlag - "v" - ["verbose"] - (flagHelp $ parDoc "[currently without effect; TODO]") - checkMode <- addSimpleBoolFlag - "c" - ["check-mode"] - (flagHelp - (PP.vcat - [ PP.text "check for changes but do not write them out" - , PP.text "exits with code 0 if no changes necessary, 1 otherwise" - , PP.text "and print file path(s) of files that have changes to stdout" - ] - ) - ) - writeMode <- addFlagReadParam - "" - ["write-mode"] - "(display|inplace)" - (flagHelp - (PP.vcat - [ PP.text "display: output for any input(s) goes to stdout" - , PP.text "inplace: override respective input file (without backup!)" - ] - ) - Data.Monoid.<> flagDefault Display - ) - inputParams <- addParamNoFlagStrings - "PATH" - (paramHelpStr "paths to input/inout haskell source files") - reorderStop - addCmdImpl $ void $ do - when printLicense $ do - print licenseDoc - System.Exit.exitSuccess - when printVersion $ do - do - putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" - putStrLn $ "Copyright (C) 2019 PRODA LTD" - putStrLn $ "There is NO WARRANTY, to the extent permitted by law." - System.Exit.exitSuccess - when printHelp $ do - liftIO - $ putStrLn - $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } - $ ppHelpShallow helpDesc - System.Exit.exitSuccess - - let - inputPaths = if null inputParams then [Nothing] else map Just inputParams - let - outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths - - configsToLoad <- liftIO $ if null configPaths - then - maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths - - config <- - runMaybeT - (if noUserConfig - then readConfigs cmdlineConfig configsToLoad - else readConfigsWithUserConfig cmdlineConfig configsToLoad - ) - >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x - when (config & _conf_debug & _dconf_dump_config & confUnpack) - $ trace (showConfigYaml config) - $ return () - - results <- zipWithM - (coreIO putStrErrLn config suppressOutput checkMode) - inputPaths - outputPaths - - if checkMode - then when (Changes `elem` (Data.Either.rights results)) - $ System.Exit.exitWith (System.Exit.ExitFailure 1) - else case results of - xs | all Data.Either.isRight xs -> pure () - [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) - - -data ChangeStatus = Changes | NoChanges - deriving (Eq) - --- | The main IO parts for the default mode of operation, and after commandline --- and config stuff is processed. -coreIO - :: (String -> IO ()) -- ^ error output function. In parallel operation, you - -- may want serialize the different outputs and - -- consequently not directly print to stderr. - -> Config -- ^ global program config. - -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so - -- currently not part of program config. - -> Bool -- ^ whether we are (just) in check mode. - -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. - -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. - -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = - ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - -- there is a good of code duplication between the following code and the - -- `pureModuleTransform` function. Unfortunately, there are also a good - -- amount of slight differences: This module is a bit more verbose, and - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- the flag will do the following: insert a marker string - -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - -- The flag is intentionally misspelled to prevent clashing with - -- inline-config stuff. - let - hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let - exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - - let - cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - (parseResult, originalContents) <- case inputPathM of - Nothing -> do - -- TODO: refactor this hack to not be mixed into parsing logic - let - hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let - hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id - inputString <- liftIO System.IO.getContents - parseRes <- liftIO $ parseModuleFromString - ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) - return (parseRes, Text.pack inputString) - Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc - inputText <- Text.IO.readFile p - -- The above means we read the file twice, but the - -- GHC API does not really expose the source it - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> - -- handle still open -> write below crashes - evil.) - return (parseRes, inputText) - case parseResult of - Left left -> do - putErrorLn "parse error:" - putErrorLn left - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - of - Left (err, input) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - ExceptT.throwE 61 - Right c -> -- trace (showTree c) $ - pure c - let moduleConf = cZipWith fromOptionIdentity config inlineConf - when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - let - disableFormatting = - moduleConf & _conf_disable_formatting & confUnpack - (errsWarns, outSText, hasChanges) <- do - if - | disableFormatting -> do - pure ([], originalContents, False) - | exactprintOnly -> do - let r = Text.pack $ ExactPrint.exactPrint parsedSource anns - pure ([], r, r /= originalContents) - | otherwise -> do - let - omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return - $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck - moduleConf - perItemConf - anns - parsedSource - let - hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let - out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ hackF - <$> TextL.splitOn (TextL.pack "\n") outRaw - else outRaw - out' <- if moduleConf & _conf_obfuscate & confUnpack - then lift $ obfuscate out - else pure out - pure $ (ews, out', out' /= originalContents) - let - customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = -1 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = -2 :: Int - customErrOrder ErrorMacroConfig{} = 5 - unless (null errsWarns) $ do - let - groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{} : _) -> do - putErrorLn - $ "ERROR: brittany pretty printer" - ++ " returned syntactically invalid result." - (ErrorInput str : _) -> do - putErrorLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{} : _) -> do - putErrorLn - $ "WARNING: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) - when - (config - & _conf_debug - & _dconf_dump_ast_unknown - & confUnpack - ) - $ do - putErrorLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - putErrorLn - " -> falling back on exactprint for this element of the module" - warns@(LayoutWarning{} : _) -> do - putErrorLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{} : _) -> do - putErrorLn - $ "Error: detected unprocessed comments." - ++ " The transformation output will most likely" - ++ " not contain some of the comments" - ++ " present in the input haskell source file." - putErrorLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" - (ErrorMacroConfig err input : _) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - [] -> error "cannot happen" - -- TODO: don't output anything when there are errors unless user - -- adds some override? - let - hasErrors = - if config & _conf_errorHandling & _econf_Werror & confUnpack - then not $ null errsWarns - else 0 < maximum (-1 : fmap customErrOrder errsWarns) - outputOnErrs = - config - & _conf_errorHandling - & _econf_produceOutputOnErrors - & confUnpack - shouldOutput = - not suppressOutput - && not checkMode - && (not hasErrors || outputOnErrs) - - when shouldOutput - $ addTraceSep (_conf_debug config) - $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let - isIdentical = case inputPathM of - Nothing -> False - Just _ -> not hasChanges - unless isIdentical $ Text.IO.writeFile p $ outSText - - when (checkMode && hasChanges) $ case inputPathM of - Nothing -> pure () - Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p - - when hasErrors $ ExceptT.throwE 70 - return (if hasChanges then Changes else NoChanges) - where - addTraceSep conf = - if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] - then trace "----" - else id diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs deleted file mode 100644 index e48ec56..0000000 --- a/source/test-suite/Main.hs +++ /dev/null @@ -1,37 +0,0 @@ -import qualified Control.Monad as Monad -import qualified Data.List as List -import qualified Language.Haskell.Brittany.Main as Brittany -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath -import qualified Test.Hspec as Hspec - -main :: IO () -main = Hspec.hspec . Hspec.parallel $ do - let directory = "data" - entries <- Hspec.runIO $ Directory.listDirectory directory - Monad.forM_ (List.sort entries) $ \entry -> - case FilePath.stripExtension "hs" entry of - Nothing -> pure () - Just slug -> Hspec.it slug $ do - let input = FilePath.combine directory entry - expected <- readFile input - let output = FilePath.combine "output" entry - Directory.copyFile input output - Brittany.mainWith - "brittany" - [ "--config-file" - , FilePath.combine directory "brittany.yaml" - , "--no-user-config" - , "--write-mode" - , "inplace" - , output - ] - actual <- readFile output - Literal actual `Hspec.shouldBe` Literal expected - -newtype Literal - = Literal String - deriving Eq - -instance Show Literal where - show (Literal x) = x diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs new file mode 100644 index 0000000..6f2d4d8 --- /dev/null +++ b/src-brittany/Main.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DataKinds #-} + +module Main where + + + +#include "prelude.inc" + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Data.Map as Map + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Data.CZipWith + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils + +import qualified Text.PrettyPrint as PP + +import DataTreePrint +import UI.Butcher.Monadic + +import qualified System.Exit +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Paths_brittany + + + +main :: IO () +main = mainFromCmdParserWithHelpDesc mainCmdParser + +helpDoc :: PP.Doc +helpDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDocW + [ "Transforms one haskell module by reformatting" + , "(parts of) the source code (while preserving the" + , "parts not transformed)." + , "Based on ghc-exactprint, thus (theoretically) supporting all" + , "that ghc does." + , "Currently, only type-signatures and function-bindings are transformed." + ] + , parDocW + [ "This program is written carefully and contains safeguards to ensure" + , "the transformation does not change semantics (or the syntax tree at all)" + , "and that no comments are removed." + , "Nonetheless, this is a young project, and there will always be bugs." + , "Please do check the output and do not let brittany override your large" + , "codebase without having backups." + ] + , parDoc $ "There is NO WARRANTY, to the extent permitted by law." + , parDocW ["This program is free software released under the AGPLv3.", "For details use the --license flag."] + , parDoc $ "See https://github.com/lspitzner/brittany" + , parDoc $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues" + ] + +licenseDoc :: PP.Doc +licenseDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDoc $ "Copyright (C) 2016-2017 Lennart Spitzner" + , parDocW + [ "This program is free software: you can redistribute it and/or modify" + , "it under the terms of the GNU Affero General Public License," + , "version 3, as published by the Free Software Foundation." + ] + , parDocW + [ "This program is distributed in the hope that it will be useful," + , "but WITHOUT ANY WARRANTY; without even the implied warranty of" + , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , "GNU Affero General Public License for more details." + ] + , parDocW + [ "You should have received a copy of the GNU Affero General Public" + , "License along with this program. If not, see" + , "<http://www.gnu.org/licenses/>." + ] + ] + + +mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () +mainCmdParser helpDesc = do + addCmdSynopsis "haskell source pretty printer" + addCmdHelp $ helpDoc + -- addCmd "debugArgs" $ do + addHelpCommand helpDesc + addCmd "license" $ addCmdImpl $ print $ licenseDoc + -- addButcherDebugCommand + reorderStart + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] mempty + inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "paths to input haskell source files") + outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file paths") + configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- configParser + suppressOutput <- addSimpleBoolFlag + "" + ["suppress-output"] + (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source") + _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]") + inplace <- addSimpleBoolFlag "" ["inplace"] (flagHelp $ parDoc "overwrite the input files") + reorderStop + inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file") + desc <- peekCmdDesc + addCmdImpl $ void $ do + when printLicense $ do + print licenseDoc + System.Exit.exitSuccess + when printVersion $ do + do + putStrLn $ "brittany version " ++ showVersion version + putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner" + putStrLn $ "There is NO WARRANTY, to the extent permitted by law." + System.Exit.exitSuccess + when printHelp $ do + liftIO $ print $ ppHelpShallow desc + System.Exit.exitSuccess + + let inputPaths' = case maybeToList inputParam ++ inputPaths of + [] -> [Nothing] + ps -> map Just ps + + outputPaths' <- case outputPaths of + [] | not inplace -> return [Nothing] + [] -> return inputPaths' + ps | not inplace -> return . map Just $ ps + _ -> do + putStrErrLn "cannot specify output files and inplace at the same time" + System.Exit.exitWith (System.Exit.ExitFailure 51) + + when (length inputPaths' /= length outputPaths') $ do + putStrErrLn "the number of inputs must match ther number of outputs" + System.Exit.exitWith (System.Exit.ExitFailure 52) + + config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do + trace (showConfigYaml config) $ return () + + let ios = zipWith (coreIO putStrErrLn config suppressOutput) inputPaths' outputPaths' + res <- fmap sequence_ $ sequence ios + case res of + Left _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + Right _ -> pure () + + +-- | The main IO parts for the default mode of operation, and after commandline +-- and config stuff is processed. +coreIO + :: (String -> IO ()) -- ^ error output function. In parallel operation, you + -- may want serialize the different outputs and + -- consequently not directly print to stderr. + -> Config -- ^ global program config. + -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so + -- currently not part of program config. + -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. + -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. + -> IO (Either Int ()) -- ^ Either an errorNo, or success. +coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEitherT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> EitherT.EitherT e IO () + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + -- there is a good of code duplication between the following code and the + -- `pureModuleTransform` function. Unfortunately, there are also a good + -- amount of slight differences: This module is a bit more verbose, and + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- the flag will do the following: insert a marker string + -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + parseResult <- case inputPathM of + Nothing -> do + -- TODO: refactor this hack to not be mixed into parsing logic + let hackF s = if "#include" `isPrefixOf` s then "-- BRITTANY_INCLUDE_HACK " ++ s else s + let hackTransform = + if hackAroundIncludes && not exactprintOnly then List.intercalate "\n" . fmap hackF . lines' else id + inputString <- liftIO $ System.IO.hGetContents System.IO.stdin + liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString) + Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc + case parseResult of + Left left -> do + putErrorLn "parse error:" + putErrorLn $ show left + EitherT.left 60 + Right (anns, parsedSource, hasCPP) -> do + when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + (errsWarns, outLText) <- do + if exactprintOnly + then do + pure ([], TextL.pack $ ExactPrint.exactPrint parsedSource anns) + else do + let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule config anns parsedSource + else liftIO $ pPrintModuleAndCheck config anns parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s + pure $ if hackAroundIncludes + then (ews, TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw) + else (ews, outRaw) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + when (not $ null errsWarns) $ do + let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns + groupedErrsWarns `forM_` \case + (ErrorOutputCheck{}:_) -> do + putErrorLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." + (ErrorInput str:_) -> do + putErrorLn $ "ERROR: parse error: " ++ str + uns@(ErrorUnknownNode{}:_) -> do + putErrorLn $ "ERROR: encountered unknown syntactical constructs:" + uns `forM_` \case + ErrorUnknownNode str ast -> do + putErrorLn str + when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + warns@(LayoutWarning{}:_) -> do + putErrorLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putErrorLn str + _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComment{}:_) -> do + putErrorLn + $ "Error: detected unprocessed comments." + ++ " The transformation output will most likely" + ++ " not contain certain of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> error "cannot happen (TM)" + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack + shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) + + when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of + Nothing -> liftIO $ TextL.IO.putStr $ outLText + Just p -> liftIO $ TextL.IO.writeFile p $ outLText + + when hasErrors $ EitherT.left 70 + where + addTraceSep conf = + if or + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] + then trace "----" + else id + + +readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config +readConfigs cmdlineConfig configPaths = do + let defLocalConfigPath = "brittany.yaml" + userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany" + let defUserConfigPath = userBritPath FilePath.</> "config.yaml" + merged <- case configPaths of + [] -> do + liftIO $ Directory.createDirectoryIfMissing False userBritPath + return cmdlineConfig + >>= readMergePersConfig defLocalConfigPath False + >>= readMergePersConfig defUserConfigPath True + -- TODO: ensure that paths exist ? + paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) (return cmdlineConfig) paths + return $ cZipWith fromOptionIdentity staticDefaultConfig merged diff --git a/src-idemtests/.gitignore b/src-idemtests/.gitignore new file mode 100644 index 0000000..4830bd8 --- /dev/null +++ b/src-idemtests/.gitignore @@ -0,0 +1,4 @@ +iterOne/ +iterTwo/ +brittany +report.txt diff --git a/src-idemtests/README b/src-idemtests/README new file mode 100644 index 0000000..3560f17 --- /dev/null +++ b/src-idemtests/README @@ -0,0 +1,17 @@ +idempotency testing on real-life examples, i.e. checks that brittany(x) is +equal to brittany(brittany(x)) for some x's. The idea is that these testcases +are not yet transformed, i.e. that x is not brittany(x). This can capture +certain bugs that are not detected by checking that brittany behaves as +identity on "well-formed" input. + +to run: + +- put a "brittany" executable into this directory. +- cd into this directory. +- ./run.sh + +report.txt will contain the results. + +note that only the configuration in brittany.yaml is tested, which contains +the default settings. ideally this would be managed in some other, more +transparent fashion. diff --git a/src-idemtests/brittany.yaml b/src-idemtests/brittany.yaml new file mode 100644 index 0000000..6e5dcfb --- /dev/null +++ b/src-idemtests/brittany.yaml @@ -0,0 +1,29 @@ +conf_errorHandling: + econf_Werror: false + econf_produceOutputOnErrors: false + econf_CPPMode: CPPModeNowarn +conf_layout: + lconfig_indentPolicy: IndentPolicyFree + lconfig_cols: 80 + lconfig_indentAmount: 2 + lconfig_importColumn: 60 + lconfig_altChooser: + tag: AltChooserBoundedSearch + contents: 3 + lconfig_indentWhereSpecial: true + lconfig_indentListSpecial: true +conf_forward: + options_ghc: [] +conf_debug: + dconf_dump_annotations: false + dconf_dump_bridoc_simpl_par: false + dconf_dump_bridoc_simpl_indent: false + dconf_dump_bridoc_simpl_floating: false + dconf_dump_ast_full: false + dconf_dump_bridoc_simpl_columns: false + dconf_dump_ast_unknown: false + dconf_dump_bridoc_simpl_alt: false + dconf_dump_bridoc_final: false + dconf_dump_bridoc_raw: false + dconf_dump_config: false + diff --git a/src-idemtests/cases/LayoutBasics.hs b/src-idemtests/cases/LayoutBasics.hs new file mode 100644 index 0000000..3664d3e --- /dev/null +++ b/src-idemtests/cases/LayoutBasics.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE KindSignatures #-} + +module Language.Haskell.Brittany.Internal.LayoutBasics + ( processDefault + , layoutByExact + -- , layoutByExactR + , descToBlockStart + , descToBlockMinMax + , descToMinMax + , rdrNameToText + , lrdrNameToText + , lrdrNameToTextAnn + , askIndent + , calcLayoutMin + , calcLayoutMax + , getCurRemaining + , layoutWriteAppend + , layoutWriteAppendMultiline + , layoutWriteNewline + , layoutWriteNewlinePlain + , layoutWriteEnsureNewline + , layoutWriteEnsureBlock + , layoutWriteEnsureBlockPlusN + , layoutWithAddIndent + , layoutWithAddIndentBlock + , layoutWithAddIndentN + , layoutWithAddIndentNBlock + , layoutWithNonParamIndent + , layoutWriteEnsureAbsoluteN + , layoutAddSepSpace + , moveToExactAnn + , moveToExactAnn' + , setOpIndent + , stringLayouter + , layoutWritePriorComments + , layoutWritePostComments + , layoutIndentRestorePostComment + , layoutWritePriorCommentsRestore + , layoutWritePostCommentsRestore + , extractCommentsPrior + , extractCommentsPost + , applyLayouter + , applyLayouterRestore + , filterAnns + , layouterFToLayouterM + , ppmMoveToExactLoc + , customLayouterF + , docEmpty + , docLit + , docAlt + , docSeq + , docPar + -- , docCols + , docPostComment + , docWrapNode + , briDocByExact + , fromMaybeIdentity + , foldedAnnKeys + ) +where + + + +-- more imports here.. + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils + +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified Outputable as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified SrcLoc as GHC +import SrcLoc ( SrcSpan ) +import OccName ( occNameString ) +import Name ( getOccString ) +import Module ( moduleName ) +import ApiAnnotation ( AnnKeywordId(..) ) + +import Data.Data +import Data.Generics.Schemes +import Data.Generics.Aliases + +import DataTreePrint + +import qualified Text.PrettyPrint as PP + +import Data.Function ( fix ) + + + +processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter + Text.Builder.Builder m, + MonadMultiReader ExactPrint.Types.Anns m) + => GenLocated SrcSpan ast + -> m () +processDefault x = do + anns <- mAsk + let str = ExactPrint.exactPrint x anns + -- this hack is here so our print-empty-module trick does not add + -- a newline at the start if there actually is no module header / imports + -- / anything. + -- TODO: instead the appropriate annotation could be removed when "cleaning" + -- the module (header). This would remove the need for this hack! + --test + case str of + "\n" -> return () + _ -> mTell $ Text.Builder.fromString $ str + + +layoutByExact :: ( MonadMultiReader Config m + , MonadMultiReader (ExactPrint.Types.Anns) m + , ExactPrint.Annotate.Annotate ast + ) + => GenLocated SrcSpan ast -> m Layouter +layoutByExact x = do + anns <- mAsk + trace (showTreeWithCustom (customLayouterF anns) x) $ layoutByExactR x + -- trace (ExactPrint.Utils.showAnnData anns 2 x) $ layoutByExactR x + +layoutByExactR :: (MonadMultiReader Config m + , MonadMultiReader (ExactPrint.Types.Anns) m + , ExactPrint.Annotate.Annotate ast) + => GenLocated SrcSpan ast -> m Layouter +layoutByExactR x = do + indent <- askIndent + anns <- mAsk + let t = Text.pack $ ExactPrint.exactPrint x anns + let tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines + let len = indent + maximum (Text.length <$> tlines) + return $ Layouter + { _layouter_desc = LayoutDesc Nothing $ Just $ BlockDesc AllSameIndent len len Nothing + , _layouter_func = \_ -> do + -- layoutWriteEnsureBlock + layoutWriteAppend $ Text.pack $ "{-" ++ show (ExactPrint.Types.mkAnnKey x, Map.lookup (ExactPrint.Types.mkAnnKey x) anns) ++ "-}" + zip [1..] tlines `forM_` \(i, l) -> do + layoutWriteAppend $ l + unless (i==tlineCount) layoutWriteNewline + do + let subKeys = foldedAnnKeys x + state <- mGet + let filterF k _ = not $ k `Set.member` subKeys + mSet $ state + { _lstate_commentsPrior = Map.filterWithKey filterF + $ _lstate_commentsPrior state + , _lstate_commentsPost = Map.filterWithKey filterF + $ _lstate_commentsPost state + } + , _layouter_ast = x + } + +briDocByExact :: (ExactPrint.Annotate.Annotate ast, + MonadMultiReader Config m, + MonadMultiReader ExactPrint.Types.Anns m + ) => GenLocated SrcSpan ast -> m BriDoc +briDocByExact ast = do + anns <- mAsk + traceIfDumpConf "ast" _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) + return $ docExt ast anns + +descToBlockStart :: LayoutDesc -> Maybe BlockStart +descToBlockStart (LayoutDesc _ (Just (BlockDesc bs _ _ _))) = Just bs +descToBlockStart (LayoutDesc (Just line) _) = Just $ RestOfLine line +descToBlockStart _ = Nothing + +descToBlockMinMax :: LayoutDesc -> Maybe (Int, Int) +descToBlockMinMax (LayoutDesc _ (Just (BlockDesc _ bmin bmax _))) = Just (bmin, bmax) +descToBlockMinMax _ = Nothing + +descToMinMax :: Int -> LayoutDesc -> Maybe (Int, Int) +descToMinMax p (LayoutDesc _ (Just (BlockDesc start bmin bmax _))) = + Just (max rolMin bmin, max rolMin bmax) + where + rolMin = case start of + RestOfLine rol -> p + _lColumns_min rol + AllSameIndent -> 0 + +descToMinMax p (LayoutDesc (Just (LayoutColumns _ _ lmin)) _) = + Just (len, len) + where + len = p + lmin +descToMinMax _ _ = + Nothing + +rdrNameToText :: RdrName -> Text +-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr +rdrNameToText ( Unqual occname ) = Text.pack $ occNameString occname +rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname + ++ "." + ++ occNameString occname +rdrNameToText ( Orig modul occname ) = Text.pack $ moduleNameString (moduleName modul) + ++ occNameString occname +rdrNameToText ( Exact name ) = Text.pack $ getOccString name + +lrdrNameToText :: GenLocated l RdrName -> Text +lrdrNameToText (L _ n) = rdrNameToText n + +lrdrNameToTextAnn :: ( MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => GenLocated SrcSpan RdrName + -> m Text +lrdrNameToTextAnn ast@(L _ n) = do + anns <- mAsk + let t = rdrNameToText n + let hasUni x (ExactPrint.Types.G y, _) = x==y + hasUni _ _ = False + -- TODO: in general: we should _always_ process all annotaiton stuff here. + -- whatever we don't probably should have had some effect on the + -- output. in such cases, resorting to byExact is probably the safe + -- choice. + return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> traceShow "Nothing" t + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> if + | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + | otherwise -> t + + +askIndent :: (MonadMultiReader Config m) => m Int +askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk + +-- minimum block width, judged from block info or line, whichever is +-- available. +-- example: calcLayoutMin doBlock ~~~ atomically $ do +-- foo +-- ## indent +-- ############# linepre +-- ############### result (in this case) +calcLayoutMin :: Int -- basic indentation amount + -> Int -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + -- stuff ("do" in the above example) and its width. + -> LayoutDesc + -> Int +calcLayoutMin indent linePre (LayoutDesc line block) = case (line, block) of + (_, Just (BlockDesc AllSameIndent m _ _)) -> indent + m + (_, Just (BlockDesc (RestOfLine inl) m _ _)) -> max (linePre + _lColumns_min inl) (indent + m) + (Just s, _) -> indent + _lColumns_min s + _ -> error "bad LayoutDesc mnasdoiucxvlkjasd" + +-- see +calcLayoutMax :: Int -- basic indentation amount + -> Int -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + -- stuff ("do" in the above example) and its width. + -> LayoutDesc + -> Int +calcLayoutMax indent linePre (LayoutDesc line block) = case (line, block) of + (Just s, _) -> linePre + _lColumns_min s + (_, Just (BlockDesc AllSameIndent _ m _)) -> indent + m + (_, Just (BlockDesc (RestOfLine inl) _ m _)) -> max (linePre + _lColumns_min inl) (indent + m) + _ -> error "bad LayoutDesc msdnfgouvadnfoiu" + +getCurRemaining :: ( MonadMultiReader Config m + , MonadMultiState LayoutState m + ) + => m Int +getCurRemaining = do + cols <- mAsk <&> _conf_layout .> _lconfig_cols .> runIdentity + clc <- _lstate_curLineCols <$> mGet + return $ cols - clc + +layoutWriteAppend :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Text + -> m () +layoutWriteAppend t = do + state <- mGet + if _lstate_addSepSpace state + then do + mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t + 1 + , _lstate_addSepSpace = False + } + mTell $ Text.Builder.fromText $ Text.pack " " <> t + else do + mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t } + mTell $ Text.Builder.fromText t + +layoutWriteAppendMultiline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Text + -> m () +layoutWriteAppendMultiline t = case Text.lines t of + [] -> return () + (l:lr) -> do + layoutWriteAppend l + lr `forM_` \x -> do + layoutWriteNewlinePlain + layoutWriteAppend x + +-- adds a newline and adds spaces to reach the current indentation level. +-- TODO: rename newline -> newlineBlock and newlinePlain -> newline +layoutWriteNewline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteNewline = do + state <- mGet + mSet $ state { _lstate_curLineCols = _lstate_indent state + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = False + } + mTell $ Text.Builder.fromString $ "\n" ++ replicate (_lstate_indent state) ' ' + +-- | does _not_ add spaces to again reach the current indentation levels. +layoutWriteNewlinePlain :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteNewlinePlain = do + state <- mGet + mSet $ state { _lstate_curLineCols = 0 + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = False + } + mTell $ Text.Builder.fromString $ "\n" + +layoutWriteEnsureNewline :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteEnsureNewline = do + state <- mGet + when (_lstate_curLineCols state /= _lstate_indent state) + $ layoutWriteNewline + +layoutWriteEnsureBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => m () +layoutWriteEnsureBlock = do + state <- mGet + let diff = _lstate_curLineCols state - _lstate_indent state + if diff>0 + then layoutWriteNewline + else if diff<0 + then do + layoutWriteAppend $ Text.pack $ replicate (negate diff) ' ' + mSet $ state { _lstate_curLineCols = _lstate_indent state + , _lstate_addSepSpace = False + } + else return () + +layoutWriteEnsureAbsoluteN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int -> m () +layoutWriteEnsureAbsoluteN n = do + state <- mGet + let diff = n - _lstate_curLineCols state + if diff>0 + then do + layoutWriteAppend $ Text.pack $ replicate diff ' ' + mSet $ state { _lstate_curLineCols = n + , _lstate_addSepSpace = False + } + else return () + +layoutWriteEnsureBlockPlusN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int -> m () +layoutWriteEnsureBlockPlusN n = do + state <- mGet + let diff = _lstate_curLineCols state - _lstate_indent state - n + if diff>0 + then layoutWriteNewline + else if diff<0 + then do + layoutWriteAppend $ Text.pack $ replicate (negate diff) ' ' + mSet $ state { _lstate_addSepSpace = False } + else return () + +layoutWithAddIndent :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + ,MonadMultiReader Config m) + => m () + -> m () +layoutWithAddIndent m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutWithAddIndentBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m + ,MonadMultiReader Config m) + => m () + -> m () +layoutWithAddIndentBlock m = do + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + layoutWriteEnsureBlock + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutWithAddIndentNBlock :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int + -> m () + -> m () +layoutWithAddIndentNBlock amount m = do + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + layoutWriteEnsureBlock + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutWithAddIndentN :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => Int + -> m () + -> m () +layoutWithAddIndentN amount m = do + state <- mGet + mSet state { _lstate_indent = _lstate_indent state + amount } + m + do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +layoutAddSepSpace :: MonadMultiState LayoutState m => m () +layoutAddSepSpace = do + state <- mGet + mSet $ state { _lstate_addSepSpace = True } + +moveToExactAnn :: (Data.Data.Data x, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m, + MonadMultiReader (Map AnnKey Annotation) m) => GenLocated SrcSpan x -> m () +moveToExactAnn ast = do + anns <- mAsk + case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of + Nothing -> return () + Just ann -> do + let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann + replicateM_ x $ layoutWriteNewline + +-- TODO: when refactoring is complete, the other version of this method +-- can probably be removed. +moveToExactAnn' :: (MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m, + MonadMultiReader (Map AnnKey Annotation) m) => AnnKey -> m () +moveToExactAnn' annKey = do + anns <- mAsk + case Map.lookup annKey anns of + Nothing -> return () + Just ann -> do + -- curY <- mGet <&> _lstate_curLineCols + let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann + replicateM_ x $ layoutWriteNewline + -- when (x/=0) $ do + -- replicateM_ x $ layoutWriteNewlinePlain + -- mModify $ \s -> s { _lstate_curLineCols = curY } + -- mTell $ Text.Builder.fromString $ replicate curY ' ' + +ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m + => ExactPrint.Types.DeltaPos + -> m () +ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do + replicateM_ x $ mTell $ Text.Builder.fromString "\n" + replicateM_ y $ mTell $ Text.Builder.fromString " " + +layoutWithNonParamIndent :: (MonadMultiWriter + Text.Builder.Builder m, + MonadMultiState LayoutState m) + => LayoutFuncParams -> m () -> m () +layoutWithNonParamIndent params m = do + case _params_opIndent params of + Nothing -> m + Just x -> layoutWithAddIndentN x m + +setOpIndent :: Int -> LayoutDesc -> LayoutFuncParams -> LayoutFuncParams +setOpIndent i desc p = p + { _params_opIndent = Just $ case _bdesc_opIndentFloatUp =<< _ldesc_block desc of + Nothing -> i + Just j -> max i j + } + +stringLayouter :: Data.Data.Data ast + => GenLocated SrcSpan ast -> Text -> Layouter +stringLayouter ast t = Layouter + { _layouter_desc = LayoutDesc + { _ldesc_line = Just $ LayoutColumns + { _lColumns_key = ColumnKeyUnique + , _lColumns_lengths = [Text.length t] + , _lColumns_min = Text.length t + } + , _ldesc_block = Nothing + } + , _layouter_func = \_ -> do + layoutWritePriorCommentsRestore ast + layoutWriteAppend t + layoutWritePostComments ast + , _layouter_ast = ast + } + +layoutWritePriorComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => GenLocated SrcSpan ast -> m () +layoutWritePriorComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.Types.mkAnnKey ast + let m = _lstate_commentsPrior state + let mAnn = Map.lookup key m + mSet $ state { _lstate_commentsPrior = Map.delete key m } + return mAnn + case mAnn of + Nothing -> return () + Just priors -> do + when (not $ null priors) $ do + state <- mGet + mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state } + priors `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewlinePlain + layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + +-- this currently only extracs from the `annsDP` field of Annotations. +-- per documentation, this seems sufficient, as the +-- "..`annFollowingComments` are only added by AST transformations ..". +layoutWritePostComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => GenLocated SrcSpan ast -> m () +layoutWritePostComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.Types.mkAnnKey ast + let m = _lstate_commentsPost state + let mAnn = Map.lookup key m + mSet $ state { _lstate_commentsPost = Map.delete key m } + return mAnn + case mAnn of + Nothing -> return () + Just posts -> do + when (not $ null posts) $ do + state <- mGet + mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state } + posts `forM_` \( ExactPrint.Types.Comment comment _ _ + , ExactPrint.Types.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewlinePlain + layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + +layoutIndentRestorePostComment :: ( Monad m + , MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + ) + => m () +layoutIndentRestorePostComment = do + mCommentCol <- _lstate_commentCol <$> mGet + case mCommentCol of + Nothing -> return () + Just commentCol -> do + layoutWriteNewlinePlain + layoutWriteAppend $ Text.pack $ replicate commentCol ' ' + +layoutWritePriorCommentsRestore :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => GenLocated SrcSpan ast -> m () +layoutWritePriorCommentsRestore x = do + layoutWritePriorComments x + layoutIndentRestorePostComment + +layoutWritePostCommentsRestore :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m) + => GenLocated SrcSpan ast -> m () +layoutWritePostCommentsRestore x = do + layoutWritePostComments x + layoutIndentRestorePostComment + +extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap +extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann -> + [r | let r = ExactPrint.Types.annPriorComments ann, not (null r)] +extractCommentsPost :: ExactPrint.Types.Anns -> PostMap +extractCommentsPost anns = flip Map.mapMaybe anns $ \ann -> + [r + | let + r = ExactPrint.Types.annsDP ann + >>= \case + (ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)] + _ -> [] + , not (null r) + ] + + +applyLayouter :: Layouter -> LayoutFuncParams -> LayoutM () +applyLayouter l@(Layouter _ _ ast) params = do + -- (always) write the prior comments at this point. + layoutWritePriorCommentsRestore ast + -- run the real stuff. + _layouter_func l params + -- if the _layouter_func has not done so already at some point + -- (there are nodes for which this makes sense), + -- write the post comments. + -- effect is `return ()` if there are no postComments. + layoutWritePostComments ast + +applyLayouterRestore :: Layouter -> LayoutFuncParams -> LayoutM () +applyLayouterRestore l@(Layouter _ _ ast) params = do + -- (always) write the prior comments at this point. + layoutWritePriorCommentsRestore ast + -- run the real stuff. + _layouter_func l params + -- if the _layouter_func has not done so already at some point + -- (there are nodes for which this makes sense), + -- write the post comments. + -- effect is `return ()` if there are no postComments. + layoutWritePostCommentsRestore ast + +foldedAnnKeys :: Data.Data.Data ast + => ast + -> Set ExactPrint.Types.AnnKey +foldedAnnKeys ast = everything + Set.union + (\x -> maybe + Set.empty + Set.singleton + [ gmapQi 1 (\t -> ExactPrint.Types.mkAnnKey $ L l t) x + | typeRepTyCon (typeOf (L () ())) == (typeRepTyCon (typeOf x)) + , l <- gmapQi 0 cast x + ] + ) + ast + +filterAnns :: Data.Data.Data ast + => ast + -> ExactPrint.Types.Anns + -> ExactPrint.Types.Anns +filterAnns ast anns = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns + +layouterFToLayouterM :: MultiReader '[Config, ExactPrint.Types.Anns] a -> LayoutM a +layouterFToLayouterM m = do + settings <- mAsk + anns <- mAsk + return $ runIdentity + $ runMultiReaderTNil + $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader anns + $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader settings + $ m + +-- new BriDoc stuff + +docEmpty :: BriDoc +docEmpty = BDEmpty + +docLit :: Text -> BriDoc +docLit t = BDLit t + +docExt :: ExactPrint.Annotate.Annotate ast + => GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> BriDoc +docExt x anns = BDExternal + (ExactPrint.Types.mkAnnKey x) + (foldedAnnKeys x) + (Text.pack $ ExactPrint.exactPrint x anns) + +docAlt :: [BriDoc] -> BriDoc +docAlt = BDAlt + + +docSeq :: [BriDoc] -> BriDoc +docSeq = BDSeq + + +docPostComment :: Data.Data.Data ast + => GenLocated SrcSpan ast + -> BriDoc + -> BriDoc +docPostComment ast bd = BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd + +docWrapNode :: Data.Data.Data ast + => GenLocated SrcSpan ast + -> BriDoc + -> BriDoc +docWrapNode ast bd = BDAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) + $ bd + +docPar :: BriDoc + -> BriDoc + -> BriDoc +docPar line indented = BDPar BrIndentNone line indented + +-- docPar :: BriDoc +-- -> BrIndent +-- -> [BriDoc] +-- -> BriDoc +-- docPar = BDPar + +-- docCols :: ColSig +-- -> [BriDoc] +-- -> BriDoc +-- docCols = BDCols + + +fromMaybeIdentity :: Identity a -> Maybe a -> Identity a +fromMaybeIdentity x y = Data.Coerce.coerce + $ fromMaybe (Data.Coerce.coerce x) y diff --git a/src-idemtests/run.sh b/src-idemtests/run.sh new file mode 100755 index 0000000..298ecef --- /dev/null +++ b/src-idemtests/run.sh @@ -0,0 +1,36 @@ +#!/bin/bash + +# set -x +set -e + +rm report.txt &> /dev/null || true + +mkdir iterOne &> /dev/null || true +mkdir iterTwo &> /dev/null || true + +for FILE in ./cases/* +do + NAME=$(basename "$FILE") + ITERNAMEONE="./iterOne/$NAME" + ITERNAMETWO="./iterTwo/$NAME" + if ! ./brittany -i "$FILE" -o "$ITERNAMEONE" + then + echo "FAILED step 1 for $FILE" | tee -a report.txt + continue + fi + if ! ./brittany -i "$ITERNAMEONE" -o "$ITERNAMETWO" + then + echo "FAILED step 2 for $FILE" | tee -a report.txt + continue + fi + if ! diff "$ITERNAMEONE" "$ITERNAMETWO" > diff.temp + then + echo "FAILED diff for $FILE with diff:" | tee -a report.txt + cat diff.temp | tee -a report.txt + echo "# meld $(realpath $ITERNAMEONE) $(realpath $ITERNAMETWO)" | tee -a report.txt + continue + fi + echo "success for $FILE" | tee -a report.txt +done + +rm diff.temp &> /dev/null || true diff --git a/src-libinterfacetests/Main.hs b/src-libinterfacetests/Main.hs new file mode 100644 index 0000000..8334328 --- /dev/null +++ b/src-libinterfacetests/Main.hs @@ -0,0 +1,32 @@ +module Main where + + + +import Test.Hspec +import Language.Haskell.Brittany +import qualified Data.Text as Text +import qualified System.Exit as Exit +import Control.Monad.IO.Class + + + +main :: IO () +main = hspec $ do + describe "library interface basic functionality" $ do + it "gives properly formatted result for valid input" $ do + let + input = Text.pack $ unlines + ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] + let expected = Text.pack $ unlines + [ "func =" + , " [ 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " , 00000000000000000000000" + , " ]" + ] + output <- liftIO $ parsePrintModule staticDefaultConfig input + input `shouldSatisfy` \_ -> case output of + Right x | x == expected -> True + _ -> False + diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs new file mode 100644 index 0000000..fe966e6 --- /dev/null +++ b/src-literatetests/Main.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import qualified Text.Parsec as Parsec +import Text.Parsec.Text ( Parser ) + +import Data.Char ( isSpace ) +import Data.List ( groupBy ) + +import Language.Haskell.Brittany.Internal + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config + +import Data.Coerce ( coerce ) + +import qualified Data.Text.IO as Text.IO + + + +data InputLine + = GroupLine Text + | HeaderLine Text + | PendingLine + | NormalLine Text + | CommentLine + deriving Show + + +main :: IO () +main = do + input <- Text.IO.readFile "src-literatetests/tests.blt" + let groups = createChunks input + hspec $ groups `forM_` \(groupname, tests) -> do + describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do + (if pend then before_ pending else id) + $ it (Text.unpack name) + $ roundTripEqual inp + where + -- this function might be implemented in a weirdly complex fashion; the + -- reason being that it was copied from a somewhat more complex variant. + createChunks :: Text -> [(Text, [(Text, Bool, Text)])] + createChunks input = +-- fmap (\case +-- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines) +-- HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines) +-- l -> error $ "first non-empty line must start with #test footest\n" ++ show l +-- ) +-- $ fmap (groupBy grouperT) + fmap + ( \case + GroupLine g:grouprest -> + (,) g + $ fmap + ( \case + HeaderLine n:PendingLine:rest | Just rlines <- mapM + extractNormal + rest -> + (n, True, Text.unlines rlines) + HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> + (n, False, Text.unlines rlines) + l -> + error + $ "first non-empty line must start with #test footest\n" + ++ show l + ) + $ groupBy grouperT + $ filter (not . lineIsSpace) + $ grouprest + l -> error $ "first non-empty line must be a #group\n" ++ show l + ) + $ groupBy grouperG + $ filter (not . lineIsSpace) + $ lineMapper + <$> Text.lines input + where + extractNormal (NormalLine l) = Just l + extractNormal _ = Nothing + specialLineParser :: Parser InputLine + specialLineParser = Parsec.choice + [ [ GroupLine $ Text.pack name + | _ <- Parsec.try $ Parsec.string "#group" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" + , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" + , _ <- Parsec.eof + ] + , [ HeaderLine $ Text.pack name + | _ <- Parsec.try $ Parsec.string "#test" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" + , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" + , _ <- Parsec.eof + ] + , [ PendingLine + | _ <- Parsec.try $ Parsec.string "#pending" + , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") + , _ <- Parsec.eof + ] + , [ CommentLine + | _ <- Parsec.many $ Parsec.oneOf " \t" + , _ <- + Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n") + , _ <- Parsec.eof + ] + ] + lineMapper :: Text -> InputLine + lineMapper line = case Parsec.runParser specialLineParser () "" line of + Left _e -> NormalLine line + Right l -> l + lineIsSpace :: InputLine -> Bool + lineIsSpace CommentLine = True + lineIsSpace _ = False + grouperG :: InputLine -> InputLine -> Bool + grouperG _ GroupLine{} = False + grouperG _ _ = True + grouperT :: InputLine -> InputLine -> Bool + grouperT _ HeaderLine{} = False + grouperT _ _ = True + + +-------------------- +-- past this line: copy-pasta from other test (meh..) +-------------------- +roundTripEqual :: Text -> Expectation +roundTripEqual t = + fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + `shouldReturn` Right (PPTextWrapper t) + +newtype PPTextWrapper = PPTextWrapper Text + deriving Eq + +instance Show PPTextWrapper where + show (PPTextWrapper t) = "\n" ++ Text.unpack t + + +defaultTestConfig :: Config +defaultTestConfig = Config + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) + { _econf_omit_output_valid_check = coerce True + } + , _conf_preprocessor = _conf_preprocessor staticDefaultConfig + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] + } + } + diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt new file mode 100644 index 0000000..e54841b --- /dev/null +++ b/src-literatetests/tests.blt @@ -0,0 +1,1080 @@ + +############################################################################### +############################################################################### +############################################################################### +#group type signatures +############################################################################### +############################################################################### +############################################################################### + +#test simple001 +func :: a -> a + +#test long typeVar +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + +#test keep linebreak mode +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + +#test simple parens 1 +func :: ((a)) + +#test simple parens 2 +func :: (a -> a) -> a + +#test simple parens 3 +func :: a -> (a -> a) + +#test did anyone say parentheses? +func :: (((((((((()))))))))) + +-- current output is.. funny. wonder if that can/needs to be improved.. +#test give me more! +#pending +func :: ((((((((((((((((((((((((((((((((((((((((((())))))))))))))))))))))))))))))))))))))))))) + +#test unit +func :: () + + +############################################################################### + +#test paren'd func 1 +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lakjsdlkjasldkj + -> lakjsdlkjasldkj + ) + +#test paren'd func 2 +func + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> (lakjsdlkjasldkj -> lakjsdlkjasldkj) + +#test paren'd func 3 +func + :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj) + -> lakjsdlkjasldkj + +#test paren'd func 4 +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> lakjsdlkjasldkj + +#test paren'd func 5 +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) + +############################################################################### + +#test type application 1 +func :: asd -> Either a b + +#test type application 2 +func + :: asd + -> Either + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + +#test type application 3 +func + :: asd + -> Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + +#test type application 4 +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd + +#test type application 5 +func + :: Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd) + +#test type application 6 +func + :: Trither + asd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + +#test type application paren 1 +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + +#test type application paren 2 +func + :: asd + -> ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + +#test type application paren 3 +func + :: ( Trither + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> asd + +############################################################################### + +#test list simple +func :: [a -> b] + +#test list func +func + :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ] + +#test list paren +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] + +################################################################## -- ############# + +#test tuple type 1 +func :: (a, b, c) + +#test tuple type 2 +func :: ((a, b, c), (a, b, c), (a, b, c)) + +#test tuple type long +func + :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + +#test tuple type nested +func + :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd) + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ) + +#test tuple type function +func + :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + ] +############################################################################### +#test type operator stuff +#pending +test050 :: a :+: b +test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd +test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + +############################################################################### + +#test forall oneliner +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b + +#test forall context multiline +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . Foo + => ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () + +#test forall no-context multiline +{-# LANGUAGE ScopedTypeVariables #-} +func + :: forall m + . ColMap2 + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> ColInfo + -> m () + +#test language pragma issue +{-# LANGUAGE ScopedTypeVariables #-} +func :: forall (a :: *) b . a -> b + +#test comments 1 +func :: a -> b -- comment + +#test comments 2 +funcA :: a -> b -- comment A +funcB :: a -> b -- comment B + +#test comments all +#pending +-- a +func -- b + :: -- c + a -- d + -> -- e + ( -- f + c -- g + , -- h + d -- i + ) -- j +-- k + +############################################################################### + +#test ImplicitParams 1 +{-# LANGUAGE ImplicitParams #-} +func :: (?asd::Int) -> () + +#test ImplicitParams 2 +{-# LANGUAGE ImplicitParams #-} +func + :: ( ?asd + :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + ) + -> () + + +############################################################################### +############################################################################### +############################################################################### +#group type signatures pragmas +############################################################################### +############################################################################### +############################################################################### + +#test inline pragma 1 +func = f + where + {-# INLINE f #-} + f = id + +#test inline pragma 2 +func = ($) + where + {-# INLINE ($) #-} + ($) = id + +#test inline pragma 3 +func = f + where + {-# INLINE CONLIKE [1] f #-} + f = id + +#test inline pragma 4 +#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2. +func = f + where + {-# INLINE [~] f #-} + f = id + + +############################################################################### +############################################################################### +############################################################################### +#group equation.basic +############################################################################### +############################################################################### +############################################################################### +## some basic testing of different kinds of equations. +## some focus on column layouting for multiple-equation definitions. +## (that part probably is not implemented in any way yet.) + +#test basic 1 +func x = x + +#test infix 1 +x *** y = x + +#test symbol prefix +(***) x y = x + + +############################################################################### +############################################################################### +############################################################################### +#group equation.patterns +############################################################################### +############################################################################### +############################################################################### + +#test wildcard +func _ = x + +#test simple long pattern +#pending +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x + +#test simple multiline pattern +#pending +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + = x + +#test another multiline pattern +#pending +func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable + a + b + = x + +#test simple constructor +func (A a) = a + +#test list constructor +func (x:xr) = x + +#test some other constructor symbol +#pending +func (x:+:xr) = x + + +############################################################################### +############################################################################### +############################################################################### +#group equation.guards +############################################################################### +############################################################################### +############################################################################### +#test simple guard +func | True = x + +#test multiple-clauses-1 +func x | x = simple expression + | otherwise = 0 + +#test multiple-clauses-2 +func x + | a somewhat longer guard x = "and a somewhat longer expession that does not" + | otherwise = "fit without putting the guards in new lines" + +#test multiple-clauses-3 +func x + | very long guard, another rather long guard that refers to x = nontrivial + expression + foo + bar + alsdkjlasdjlasj + | otherwise = 0 + +#test multiple-clauses-4 +func x + | very long guard, another rather long guard that refers to x + = nontrivialexpression foo bar alsdkjlasdjlasj + | otherwise + = 0 + +#test multiple-clauses-5 +func x + | very loooooooooooooooooooooooooooooong guard + , another rather long guard that refers to x + = nontrivial expression foo bar alsdkjlasdjlasj + | otherwise + = 0 + + +############################################################################### +############################################################################### +############################################################################### +#group expression.basic +############################################################################### +############################################################################### +############################################################################### + +#test var +func = x + +describe "infix op" $ do +#test 1 +func = x + x + +#test long +#pending +func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + +#test long keep linemode 1 +#pending +func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + +#test long keep linemode 2 +#pending +func = mweroiuxlskdfjlksj + + mweroiuxlskdfjlksj + + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj + +#test literals +func = 1 +func = "abc" +func = 1.1e5 +func = 'x' +func = 981409823458910394810928414192837123987123987123 + +#test lambdacase +{-# LANGUAGE LambdaCase #-} +func = \case + FooBar -> x + Baz -> y + +#test lambda +func = \x -> abc + +describe "app" $ do +#test 1 +func = klajsdas klajsdas klajsdas + +#test 2 +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + +#test 3 +func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas + lakjsdlajsdljas + lakjsdlajsdljas + +### +#group expression.basic.sections +### + +#test left +func = (1+) + +#test right +func = (+1) + +#test left inf +## TODO: this could be improved.. +func = (1`abc`) + +#test right inf +func = (`abc`1) + +### +#group tuples +### + +#test 1 +func = (abc, def) + +#test 2 +#pending +func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd + , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd) + + + +############################################################################### +############################################################################### +############################################################################### +#group expression.do statements +############################################################################### +############################################################################### +############################################################################### + +#test simple +func = do + stmt + stmt + +#test bind +func = do + x <- stmt + stmt x + +#test let +func = do + let x = 13 + stmt x + + +############################################################################### +############################################################################### +############################################################################### +#group expression.lists +############################################################################### +############################################################################### +############################################################################### + +#test monad-comprehension-case-of +func = + foooooo + $ [ case + foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + of + _ -> True + ] + + +############################################################################### +############################################################################### +############################################################################### +#group expression.multiwayif +############################################################################### +############################################################################### +############################################################################### + +#test simple +{-# LANGUAGE MultiWayIf #-} +func = if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 + +#test simplenested +{-# LANGUAGE MultiWayIf #-} +func = do + foo + bar $ if + | cond1 -> loooooooooooooooooooooooooooooong expr1 + | cond2 -> loooooooooooooooooooooooooooooong expr2 + + +############################################################################### +############################################################################### +############################################################################### +#group stylisticspecialcases +############################################################################### +############################################################################### +############################################################################### + +#test operatorprefixalignment-even-with-multiline-alignbreak +func = + foo + $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + ] + ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] + + +############################################################################### +############################################################################### +############################################################################### +#group regression +############################################################################### +############################################################################### +############################################################################### + +#test newlines-comment +func = do + abc <- foo + +--abc +return () + +#test parenthesis-around-unit +func = (()) + +#test let-defs indentation +func = do + let foo True = True + foo _ = False + return () + +#test record update indentation 1 +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state } + +#test record update indentation 2 +func = do + s <- mGet + mSet $ s { _lstate_indent = _lstate_indent state + , _lstate_indent = _lstate_indent state + } + +#test record update indentation 3 +func = do + s <- mGet + mSet $ s + { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd + } + +#test post-indent comment +func = do +-- abc + -- def + return () + +#test post-unindent comment +func = do + do + return () + -- abc + -- def + return () + +#test CPP empty comment case +#pending CPP parsing needs fixing for roundTripEqual +{-# LANGUAGE CPP #-} +module Test where +func = do +#if FOO + let x = 13 +#endif + stmt x + +## really, the following should be handled by forcing the Alt to multiline +## because there are comments. as long as this is not implemented though, +## we should ensure the trivial solution works. +#test comment inline placement (temporary) +func + :: Int -- basic indentation amount + -> Int -- currently used width in current line (after indent) + -- used to accurately calc placing of the current-line + -> LayoutDesc + -> Int + +#test some indentation thingy +func = + ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj + $ abc + $ def + $ ghi + $ jkl + ) + +#test parenthesized operator +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) + where reassoc (v, e, w) = (v, (e, w)) + +#test record pattern matching stuff +downloadRepoPackage = case repo of + RepoLocal {..} -> return () + RepoLocal { abc } -> return () + RepoLocal{} -> return () + +#test do let comment indentation level problem +func = do + let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' + (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' + -- default local dir target if there's no given target + utargets'' = "foo" + return () + +#test list comprehension comment placement +func = + [ (thing, take 10 alts) --TODO: select best ones + | (thing, _got, alts@(_:_)) <- nosuchFooThing + , gast <- award + ] + +#test if-then-else comment placement +func = if x + then if y -- y is important + then foo + else bar + else Nothing + +#test qualified infix pattern +#pending "TODO" +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return $ Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR + +#test type signature multiline forcing issue +layoutWriteNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () + +#test multiwayif proper indentation +{-# LANGUAGE MultiWayIf #-} +readMergePersConfig path shouldCreate conf = do + exists <- liftIO $ System.Directory.doesFileExist path + if + | exists -> do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " + ++ path + ++ ":" + liftIO $ putStrErrLn e + mzero + Right x -> return x + return $ fileConf Semigroup.<> conf + | shouldCreate -> do + liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap + (Option . Just . runIdentity) + staticDefaultConfig + return $ conf + | otherwise -> do + return conf + +#test nested pattern alignment issue" +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk + +#test nested pattern alignment issue" +func = BuildReport + where + convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _ _ ) -> InstallOk + +#test partially overflowing alignment issue" +showPackageDetailedInfo pkginfo = + renderStyle (style { lineLength = 80, ribbonsPerLine = 1 }) + $ char '*' + $+$ something + [ entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" + sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry + "Versions installed" + installedVersions + ( altText + null + (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]") + ) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) + then empty + else text "Modules:" + $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ] + +#test issue 7a +isValidPosition position | validX && validY = Just position + | otherwise = Nothing + +#test issue-6-pattern-linebreak-validity +## this is ugly, but at least syntactically valid. +foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do + (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String + -> IO Bool ) <- + ReflexHost.newExternalEvent + liftIO . forkIO . forever $ getLine >>= inputFire + ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent + +#test issue 16 +foldrDesc f z = unSwitchQueue $ \q -> + switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) + +#test issue 18 +autocheckCases = + [ ("Never Deadlocks" , representative deadlocksNever) + , ("No Exceptions" , representative exceptionsNever) + , ("Consistent Result", alwaysSame) -- already representative + ] + +#test issue 18b +autocheckCases = + [ ("Never Deadlocks", representative deadlocksNever) + , ("No Exceptions" , representative exceptionsNever) + , ( "Consistent Result" + , alwaysSame -- already representative + ) + ] + +#test issue 18c +func = + [ (abc, (1111, 1111)) + , (def, (2, 2)) + , foo -- comment + ] + +#test issue 26 +foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + where g a b = b + b * a + +#test issue 26b +foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo + +#test aggressive alignment 1 +func = do + abc <- expr + abcccccccccccccccccc <- expr + abcccccccccccccccccccccccccccccccccccccccccc <- expr + abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr + +#test example alignment 1 +func (MyLongFoo abc def) = 1 +func (Bar a d ) = 2 +func _ = 3 + +#test listcomprehension-case-of +parserCompactLocation = + [ try + $ [ ParseRelAbs (Text.Read.read digits) _ _ + | digits <- many1 digit + , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe + [ case divPart of + Nothing -> Left $ Text.Read.read digits + Just ddigits -> + Right $ Text.Read.read digits % Text.Read.read ddigits + | digits <- many1 digit + , divPart <- optionMaybe (string "/" *> many1 digit) + ] + ] + ] + +#test opapp-specialcasing-1 +func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + +#test opapp-specialcasing-2 +func = + fooooooooooooooooooooooooooooooooo + + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + +#test opapp-specialcasing-3 +func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo + [ foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + , foooooooooooooooooooooooooooooooo + ] + +#test opapp-indenting +parserPrim = + [ r + | r <- + [ SGPPrimFloat $ bool id (0-) minus $ readGnok "parserPrim" + (d1 ++ d2 ++ d3 ++ d4) + | d2 <- string "." + , d3 <- many1 (oneOf "0123456789") + , _ <- string "f" + ] + <|> [ SGPPrimFloat $ bool id (0-) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "f" + ] + <|> [ SGPPrimInt $ bool id (0-) minus $ fromIntegral + (readGnok "parserPrim" d1 :: Integer) + | _ <- string "i" + ] + ] + +#test another-parspacing-testcase + +samples = (SV.unpackaaaaadat) <&> \f -> + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + +#test recordupd-singleline-bug + +runBrittany tabSize text = do + let + config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce + tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } + parsePrintModule config text + +#test issue 38 + +{-# LANGUAGE TypeApplications #-} +foo = bar @Baz + +#test comment-before-BDCols +{-# LANGUAGE TypeApplications #-} +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do + docAlt + $ -- one-line solution + [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart + ] + ] + | not hasComments + , [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> [] + ] + ++ -- one-line solution + where in next line(s) + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , Data.Maybe.isJust mWhereDocs + ] + ++ -- two-line solution + where in next line(s) + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return + body + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] + +#test comment-testcase-17 +{-# LANGUAGE MultiWayIf #-} +func = do + let foo = if + | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO + -> max + (defLen - 0.2) -- TODO + (defLen * 0.8) + | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO + return True + +#test issue 49 + +foo n = case n of + 1 -> True + -1 -> False + +bar n = case n of + (-2, -2) -> (-2, -2) + +#test issue 48 a + +foo = + let a = b@1 + cccc = () + in foo + +#test issue 48 b + +{-# LANGUAGE TypeApplications #-} +foo = + let a = b @1 + cccc = () + in foo + + +############################################################################### +############################################################################### +############################################################################### +#group pending +############################################################################### +############################################################################### +############################################################################### + + + +## this testcase is not about idempotency, but about _how_ the output differs +## from the input; i cannot really express this yet with the current +## test-suite. +## #test ayaz +## +## myManageHook = +## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience] +## <+> composeAll +## [ className =? "Pidgin" --> doFloat +## , className =? "XCalc" --> doFloat +## -- plan9port's acme +## , className =? "acme" --> doFloat +## -- Acme with Vi bindings editor +## , title =? "ED" --> doFloat +## , title =? "wlc-x11" --> doFloat +## , className =? "Skype" --> doFloat +## , className =? "ffplay" --> doFloat +## , className =? "mpv" --> doFloat +## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc. +## -- Firefox works well tiled, but it has dialog windows we want to float. +## , appName =? "Browser" --> doFloat +## ] +## where +## role = stringProperty "WM_WINDOW_ROLE" + diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs new file mode 100644 index 0000000..09b4f2b --- /dev/null +++ b/src-unittests/AsymptoticPerfTests.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE QuasiQuotes #-} + +module AsymptoticPerfTests + ( asymptoticPerfTest + ) +where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import Language.Haskell.Brittany.Internal + +import TestUtils + + + +asymptoticPerfTest :: Spec +asymptoticPerfTest = do + it "1000 do statements" + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = do\n") + <> Text.replicate 1000 (Text.pack " statement\n") + it "1000 do nestings" + $ roundTripEqualWithTimeout 4000000 + $ (Text.pack "func = ") + <> mconcat + ( [0 .. 999] + <&> \(i :: Int) -> + (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") + ) + <> Text.replicate 2000 (Text.pack " ") + <> Text.pack "return\n" + <> Text.replicate 2002 (Text.pack " ") + <> Text.pack "()" + it "1000 AppOps" + $ roundTripEqualWithTimeout 1000000 + $ (Text.pack "func = expr") + <> Text.replicate 200 (Text.pack "\n . expr") --TODO diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs new file mode 100644 index 0000000..33a04eb --- /dev/null +++ b/src-unittests/TestMain.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import Language.Haskell.Brittany.Internal + +import AsymptoticPerfTests + + + +main :: IO () +main = hspec $ tests + +tests :: Spec +tests = do + describe "asymptotic perf roundtrips" $ asymptoticPerfTest diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs new file mode 100644 index 0000000..30eac3e --- /dev/null +++ b/src-unittests/TestUtils.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE QuasiQuotes #-} + +module TestUtils where + + + +#include "prelude.inc" + +import Test.Hspec + +import NeatInterpolation + +import Language.Haskell.Brittany.Internal + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config + +import System.Timeout ( timeout ) + +import Data.Coerce ( coerce ) + + + +roundTripEqual :: Text -> Expectation +roundTripEqual t = + fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + `shouldReturn` Right (PPTextWrapper t) + +roundTripEqualWithTimeout :: Int -> Text -> Expectation +roundTripEqualWithTimeout time t = + timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) + where + action = fmap (fmap PPTextWrapper) + (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) + +newtype PPTextWrapper = PPTextWrapper Text + deriving Eq + +instance Show PPTextWrapper where + show (PPTextWrapper t) = "\n" ++ Text.unpack t + +defaultTestConfig :: Config +defaultTestConfig = Config + { _conf_version = _conf_version staticDefaultConfig + , _conf_debug = _conf_debug staticDefaultConfig + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) + { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever + } + , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] + } + } diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs new file mode 100644 index 0000000..5f9a128 --- /dev/null +++ b/src/Language/Haskell/Brittany.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany + ( parsePrintModule + , staticDefaultConfig + , forwardOptionsSyntaxExtsEnabled + , Config + , CConfig(..) + , CDebugConfig(..) + , CLayoutConfig(..) + , CErrorHandlingConfig(..) + , CForwardOptions(..) + , CPreProcessorConfig(..) + , BrittanyError(..) + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config + diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs new file mode 100644 index 0000000..4c4bbf0 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal + ( parsePrintModule + , parsePrintModuleTests + , pPrintModule + , pPrintModuleAndCheck + -- re-export from utils: + , parseModule + , parseModuleFromString + ) +where + + + +#include "prelude.inc" + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers + +import Data.Data +import Control.Monad.Trans.Either +import Data.HList.HList +import Data.CZipWith + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.LayouterBasics + +import Language.Haskell.Brittany.Internal.Layouters.Type +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Backend +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import Language.Haskell.Brittany.Internal.Transformations.Alt +import Language.Haskell.Brittany.Internal.Transformations.Floating +import Language.Haskell.Brittany.Internal.Transformations.Par +import Language.Haskell.Brittany.Internal.Transformations.Columns +import Language.Haskell.Brittany.Internal.Transformations.Indent + +import qualified GHC as GHC hiding (parseModule) +import ApiAnnotation ( AnnKeywordId(..) ) +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) +import HsSyn +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC + + + +-- | Exposes the transformation in an pseudo-pure fashion. The signature +-- contains `IO` due to the GHC API not exposing a pure parsing function, but +-- there should be no observable effects. +-- +-- Note that this function ignores/resets all config values regarding +-- debugging, i.e. it will never use `trace`/write to stderr. +parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) +parsePrintModule configRaw inputText = runEitherT $ do + let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack + (anns, parsedSource, hasCPP) <- do + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITTANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes + then List.intercalate "\n" . fmap hackF . lines' + else id + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + parseResult <- lift $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform $ Text.unpack inputText) + case parseResult of + Left err -> left $ [ErrorInput err] + Right x -> pure $ x + (errsWarns, outputTextL) <- do + let omitCheck = + config + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule config anns parsedSource + else lift $ pPrintModuleAndCheck config anns parsedSource + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s + pure $ if hackAroundIncludes + then + ( ews + , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn + (TextL.pack "\n") + outRaw + ) + else (ews, outRaw) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + let hasErrors = + case config & _conf_errorHandling & _econf_Werror & confUnpack of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + if hasErrors then left $ errsWarns else pure $ TextL.toStrict outputTextL + + + +-- BrittanyErrors can be non-fatal warnings, thus both are returned instead +-- of an Either. +-- This should be cleaned up once it is clear what kinds of errors really +-- can occur. +pPrintModule + :: Config + -> ExactPrint.Types.Anns + -> GHC.ParsedSource + -> ([BrittanyError], TextL.Text) +pPrintModule conf anns parsedModule = + let + ((out, errs), debugStrings) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterW + $ MultiRWSS.withMultiReader anns + $ MultiRWSS.withMultiReader conf + $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) + $ do + traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations + $ annsDoc anns + ppModule parsedModule + tracer = + if Seq.null debugStrings + then + id + else + trace ("---- DEBUGMESSAGES ---- ") + . foldr (seq . join trace) id debugStrings + in + tracer $ (errs, Text.Builder.toLazyText out) + -- unless () $ do + -- + -- debugStrings `forM_` \s -> + -- trace s $ return () + +-- | Additionally checks that the output compiles again, appending an error +-- if it does not. +pPrintModuleAndCheck + :: Config + -> ExactPrint.Types.Anns + -> GHC.ParsedSource + -> IO ([BrittanyError], TextL.Text) +pPrintModuleAndCheck conf anns parsedModule = do + let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity + let (errs, output) = pPrintModule conf anns parsedModule + parseResult <- parseModuleFromString ghcOptions + "output" + (\_ -> return $ Right ()) + (TextL.unpack output) + let errs' = errs ++ case parseResult of + Left{} -> [ErrorOutputCheck] + Right{} -> [] + return (errs', output) + + +-- used for testing mostly, currently. +-- TODO: use parsePrintModule instead and remove this function. +parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text) +parsePrintModuleTests conf filename input = do + let inputStr = Text.unpack input + parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr + case parseResult of + Left (_ , s ) -> return $ Left $ "parsing error: " ++ s + Right (anns, parsedModule) -> do + let omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (errs, ltext) <- if omitCheck + then return $ pPrintModule conf anns parsedModule + else pPrintModuleAndCheck conf anns parsedModule + return $ if null errs + then Right $ TextL.toStrict $ ltext + else + let errStrs = errs <&> \case + ErrorInput str -> str + ErrorUnusedComment str -> str + LayoutWarning str -> str + ErrorUnknownNode str _ -> str + ErrorOutputCheck -> "Output is not syntactically valid." + in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs + + +-- this approach would for with there was a pure GHC.parseDynamicFilePragma. +-- Unfortunately that does not exist yet, so we cannot provide a nominally +-- pure interface. + +-- parsePrintModuleTests :: Text -> Either String Text +-- parsePrintModuleTests input = do +-- let dflags = GHC.unsafeGlobalDynFlags +-- let fakeFileName = "SomeTestFakeFileName.hs" +-- let pragmaInfo = GHC.getOptions +-- dflags +-- (GHC.stringToStringBuffer $ Text.unpack input) +-- fakeFileName +-- (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo +-- let parseResult = ExactPrint.Parsers.parseWith +-- dflags1 +-- fakeFileName +-- GHC.parseModule +-- inputStr +-- case parseResult of +-- Left (_, s) -> Left $ "parsing error: " ++ s +-- Right (anns, parsedModule) -> do +-- let (out, errs) = runIdentity +-- $ runMultiRWSTNil +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW +-- $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns +-- $ ppModule parsedModule +-- if (not $ null errs) +-- then do +-- let errStrs = errs <&> \case +-- ErrorUnusedComment str -> str +-- Left $ "pretty printing error(s):\n" ++ List.unlines errStrs +-- else return $ TextL.toStrict $ Text.Builder.toLazyText out + +ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () +ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do + let emptyModule = L loc m { hsmodDecls = [] } + (anns', post) <- do + anns <- mAsk + -- evil partiality. but rather unlikely. + return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of + Nothing -> (anns, []) + Just mAnn -> + let modAnnsDp = ExactPrint.Types.annsDP mAnn + isWhere (ExactPrint.Types.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.Types.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post) = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + mAnn' = mAnn { ExactPrint.Types.annsDP = pre } + anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns + in (anns', post) + MultiRWSS.withMultiReader anns' $ processDefault emptyModule + decls `forM_` \decl -> do + filteredAnns <- mAsk <&> \annMap -> + Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap + + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns + + config <- mAsk + + MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns :+: HNil + ppDecl decl + let finalComments = filter + ( fst .> \case + ExactPrint.Types.AnnComment{} -> True + _ -> False + ) + post + post `forM_` \case + (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do + ppmMoveToExactLoc l + mTell $ Text.Builder.fromString cmStr + (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) -> + let + folder (acc, _) (kw, ExactPrint.Types.DP (x, y)) = case kw of + ExactPrint.Types.AnnComment cm + | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm + -> ( acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , y + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + ) + _ -> (acc + x, y) + (cmX, cmY) = foldl' folder (0, 0) finalComments + in + ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY) + _ -> return () + +withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () +withTransformedAnns ast m = do + -- TODO: implement `local` for MultiReader/MultiRWS + readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR + MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) + m + MultiRWSS.mPutRawR readers + where + f anns = + let ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced + + +ppDecl :: LHsDecl RdrName -> PPMLocal () +ppDecl d@(L loc decl) = case decl of + SigD sig -> -- trace (_sigHead sig) $ + withTransformedAnns d $ do + -- runLayouter $ Old.layoutSig (L loc sig) + briDoc <- briDocMToPPM $ layoutSig (L loc sig) + layoutBriDoc briDoc + ValD bind -> -- trace (_bindHead bind) $ + withTransformedAnns d $ do + -- Old.layoutBind (L loc bind) + briDoc <- briDocMToPPM $ do + eitherNode <- layoutBind (L loc bind) + case eitherNode of + Left ns -> docLines $ return <$> ns + Right n -> return n + layoutBriDoc briDoc + _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc + +_sigHead :: Sig RdrName -> String +_sigHead = \case + TypeSig names _ -> + "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) + _ -> "unknown sig" + +_bindHead :: HsBind RdrName -> String +_bindHead = \case + FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) + PatBind _pat _ _ _ ([], []) -> "PatBind smth" + _ -> "unknown bind" + + + +layoutBriDoc :: BriDocNumbered -> PPMLocal () +layoutBriDoc briDoc = do + -- first step: transform the briDoc. + briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do + -- Note that briDoc is BriDocNumbered, but state type is BriDoc. + -- That's why the alt-transform looks a bit special here. + traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw + $ briDocToDoc + $ unwrapBriDocNumbered + $ briDoc + -- bridoc transformation: remove alts + transformAlts briDoc >>= mSet + mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-alt" + _dconf_dump_bridoc_simpl_alt + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyFloating .> mSet + mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-floating" + _dconf_dump_bridoc_simpl_floating + -- bridoc transformation: par removal + mGet >>= transformSimplifyPar .> mSet + mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-par" + _dconf_dump_bridoc_simpl_par + -- bridoc transformation: float stuff in + mGet >>= transformSimplifyColumns .> mSet + mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-columns" + _dconf_dump_bridoc_simpl_columns + -- bridoc transformation: indent + mGet >>= transformSimplifyIndent .> mSet + mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-indent" + _dconf_dump_bridoc_simpl_indent + mGet >>= briDocToDoc .> traceIfDumpConf "bridoc final" + _dconf_dump_bridoc_final + -- -- convert to Simple type + -- simpl <- mGet <&> transformToSimple + -- return simpl + + anns :: ExactPrint.Types.Anns <- mAsk + + let state = LayoutState + { _lstate_baseYs = [0] + , _lstate_curYOrAddNewline = Right 0 -- important that we use left here + -- because moveToAnn stuff of the + -- first node needs to do its + -- thing properly. + , _lstate_indLevels = [0] + , _lstate_indLevelLinger = 0 + , _lstate_comments = anns + , _lstate_commentCol = Nothing + , _lstate_addSepSpace = Nothing + } + + state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' + + let remainingComments = + extractAllComments =<< Map.elems (_lstate_comments state') + remainingComments + `forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell) + + return $ () diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs new file mode 100644 index 0000000..44264d4 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ConstraintKinds #-} + +module Language.Haskell.Brittany.Internal.Backend + ( layoutBriDocM + ) +where + + + +#include "prelude.inc" + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) + +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.BackendUtils +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + + +import qualified Data.Text.Lazy.Builder as Text.Builder + + +import Data.HList.ContainsType + +import Control.Monad.Extra ( whenM ) + +import qualified Control.Monad.Trans.Writer.Strict as WriterS + + + +type ColIndex = Int + +data ColumnSpacing + = ColumnSpacingLeaf Int + | ColumnSpacingRef Int Int + +type ColumnBlock a = [a] +type ColumnBlocks a = Seq [a] +type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) +type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) + -- (ratio of hasSpace, maximum, raw) + +data ColInfo + = ColInfoStart -- start value to begin the mapAccumL. + | ColInfoNo BriDoc + | ColInfo ColIndex ColSig [(Int, ColInfo)] + +instance Show ColInfo where + show ColInfoStart = "ColInfoStart" + show ColInfoNo{} = "ColInfoNo{}" + show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list + +data ColBuildState = ColBuildState + { _cbs_map :: ColMap1 + , _cbs_index :: ColIndex + } + +type LayoutConstraints m = ( MonadMultiReader Config m + , MonadMultiReader ExactPrint.Types.Anns m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + , MonadMultiState LayoutState m + ) + +layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () +layoutBriDocM = \case + BDEmpty -> do + return () -- can it be that simple + BDLit t -> do + layoutIndentRestorePostComment + layoutRemoveIndentLevelLinger + layoutWriteAppend t + BDSeq list -> do + list `forM_` layoutBriDocM + -- in this situation, there is nothing to do about cols. + -- i think this one does not happen anymore with the current simplifications. + -- BDCols cSig list | BDPar sameLine lines <- List.last list -> + -- alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines + BDCols _ list -> do + list `forM_` layoutBriDocM + BDSeparator -> do + layoutAddSepSpace + BDAddBaseY indent bd -> do + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ layoutBriDocM bd + BDBaseYPushCur bd -> do + layoutBaseYPushCur + layoutBriDocM bd + BDBaseYPop bd -> do + layoutBriDocM bd + layoutBaseYPop + BDIndentLevelPushCur bd -> do + layoutIndentLevelPushCur + layoutBriDocM bd + BDIndentLevelPop bd -> do + layoutBriDocM bd + layoutIndentLevelPop + BDEnsureIndent indent bd -> do + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteEnsureBlock + layoutBriDocM bd + BDPar indent sameLine indented -> do + layoutBriDocM sameLine + let indentF = case indent of + BrIndentNone -> id + BrIndentRegular -> layoutWithAddBaseCol + BrIndentSpecial i -> layoutWithAddBaseColN i + indentF $ do + layoutWriteNewlineBlock + layoutBriDocM indented + BDLines lines -> alignColsLines lines + BDAlt [] -> error "empty BDAlt" + BDAlt (alt:_) -> layoutBriDocM alt + BDForceMultiline bd -> layoutBriDocM bd + BDForceSingleline bd -> layoutBriDocM bd + BDForwardLineMode bd -> layoutBriDocM bd + BDExternal annKey subKeys shouldAddComment t -> do + let tlines = Text.lines $ t <> Text.pack "\n" + tlineCount = length tlines + anns :: ExactPrint.Anns <- mAsk + when shouldAddComment $ do + layoutWriteAppend + $ Text.pack + $ "{-" + ++ show (annKey, Map.lookup annKey anns) + ++ "-}" + zip [1 ..] tlines `forM_` \(i, l) -> do + layoutWriteAppend $ l + unless (i == tlineCount) layoutWriteNewlineBlock + do + state <- mGet + let filterF k _ = not $ k `Set.member` subKeys + mSet $ state + { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state + } + BDAnnotationPrior annKey bd -> do + state <- mGet + let m = _lstate_comments state + let allowMTEL = Data.Either.isRight (_lstate_curYOrAddNewline state) + mAnn <- do + let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annPriorComments = [] }) + annKey + m + } + return mAnn + case mAnn of + Nothing -> when allowMTEL $ moveToExactAnn annKey + Just [] -> when allowMTEL $ moveToExactAnn annKey + Just priors -> do + -- layoutResetSepSpace + priors + `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + do + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) + _ -> layoutMoveToCommentPos y x + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline $ Text.pack $ comment + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + when allowMTEL $ moveToExactAnn annKey + layoutBriDocM bd + BDAnnotationKW annKey keyword bd -> do + layoutBriDocM bd + mComments <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let mToSpan = case mAnn of + Just anns | keyword == Nothing -> Just anns + Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just + annR + _ -> Nothing + case mToSpan of + Just anns -> do + let (comments, rest) = flip spanMaybe anns $ \case + (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) + _ -> Nothing + mSet $ state + { _lstate_comments = Map.adjust + (\ann -> ann { ExactPrint.annsDP = rest }) + annKey + m + } + return $ nonEmpty comments + _ -> return Nothing + case mComments of + Nothing -> pure () + Just comments -> do + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + do + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) + _ -> layoutMoveToCommentPos y x + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline $ Text.pack $ comment + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDAnnotationRest annKey bd -> do + layoutBriDocM bd + mComments <- do + state <- mGet + let m = _lstate_comments state + let mComments = nonEmpty =<< extractAllComments <$> Map.lookup annKey m + mSet $ state + { _lstate_comments = Map.adjust + ( \ann -> ann { ExactPrint.annFollowingComments = [] + , ExactPrint.annPriorComments = [] + , ExactPrint.annsDP = [] + } + ) + annKey + m + } + return mComments + case mComments of + Nothing -> pure () + Just comments -> do + comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> + do + -- evil hack for CPP: + case comment of + ('#':_) -> layoutMoveToCommentPos y (-999) + _ -> layoutMoveToCommentPos y x + -- fixedX <- fixMoveToLineByIsNewline x + -- replicateM_ fixedX layoutWriteNewline + -- layoutMoveToIndentCol y + layoutWriteAppendMultiline $ Text.pack $ comment + -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDNonBottomSpacing bd -> layoutBriDocM bd + BDSetParSpacing bd -> layoutBriDocM bd + BDForceParSpacing bd -> layoutBriDocM bd + BDDebug s bd -> do + mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" + layoutBriDocM bd + +briDocLineLength :: BriDoc -> Int +briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc + -- the state encodes whether a separator was already + -- appended at the current position. + where + rec = \case + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> rec `mapM` bds + BDCols _ bds -> sum <$> rec `mapM` bds + BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar _ line _ -> rec line + BDAlt{} -> error "briDocLineLength BDAlt" + BDForceMultiline bd -> rec bd + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t -> return $ Text.length t + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDLines ls@(_:_) -> do + x <- StateS.get + return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing bd -> rec bd + BDDebug _ bd -> rec bd + +briDocIsMultiLine :: BriDoc -> Bool +briDocIsMultiLine briDoc = rec briDoc + where + rec :: BriDoc -> Bool + rec = \case + BDEmpty -> False + BDLit _ -> False + BDSeq bds -> any rec bds + BDCols _ bds -> any rec bds + BDSeparator -> False + BDAddBaseY _ bd -> rec bd + BDBaseYPushCur bd -> rec bd + BDBaseYPop bd -> rec bd + BDIndentLevelPushCur bd -> rec bd + BDIndentLevelPop bd -> rec bd + BDPar _ _ _ -> True + BDAlt{} -> error "briDocIsMultiLine BDAlt" + BDForceMultiline _ -> True + BDForceSingleline bd -> rec bd + BDForwardLineMode bd -> rec bd + BDExternal _ _ _ t | [_] <- Text.lines t -> False + BDExternal _ _ _ _ -> True + BDAnnotationPrior _ bd -> rec bd + BDAnnotationKW _ _ bd -> rec bd + BDAnnotationRest _ bd -> rec bd + BDLines (_:_:_) -> True + BDLines [_ ] -> False + BDLines [] -> error "briDocIsMultiLine BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing bd -> rec bd + BDDebug _ bd -> rec bd + +alignColsLines :: LayoutConstraints m => [BriDoc] -> m () +alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do + -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) + curX <- do + state <- mGet + return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe + 0 + (_lstate_addSepSpace state) + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack + alignBreak <- + mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack + case () of + _ -> + sequence_ + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos + <&> processInfo processedMap + where + (colInfos, finalState) = + StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) + -- maxZipper :: [Int] -> [Int] -> [Int] + -- maxZipper [] ys = ys + -- maxZipper xs [] = xs + -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr + colAggregation :: [Int] -> Int + colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ] + + processedMap :: ColMap2 + processedMap = + fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> + let + colss = colSpacingss <&> \spss -> case reverse spss of + [] -> [] + (xN:xR) -> + reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR + where + fLast (ColumnSpacingLeaf len ) = len + fLast (ColumnSpacingRef len _) = len + fInit (ColumnSpacingLeaf len) = len + fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of + Nothing -> 0 + Just (_, maxs, _) -> sum maxs + maxCols = {-Foldable.foldl1 maxZipper-} + fmap colAggregation $ transpose $ Foldable.toList + -- $ trace ("colss=" ++ show colss ++ " for" ++ take 100 (show $ briDocToDoc $ head bridocs)) + colss + (_, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + counter count l = if List.last posXs + List.last l <= colMax + then count + 1 + else count + ratio = fromIntegral (foldl counter (0 :: Int) colss) + / fromIntegral (length colss) + in + (ratio, maxCols, colss) + + mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocs bds = mergeBriDocsW ColInfoStart bds + + mergeBriDocsW + :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] + mergeBriDocsW _ [] = return [] + mergeBriDocsW lastInfo (bd:bdr) = do + info <- mergeInfoBriDoc True lastInfo bd + infor <- mergeBriDocsW + -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) + (if shouldBreakAfter bd then ColInfoStart else info) + bdr + return $ info : infor + + -- even with alignBreak config flag, we don't stop aligning for certain + -- ColSigs - the ones with "False" below. The main reason is that + -- there are uses of BDCols where they provide the alignment of several + -- consecutive full larger code segments, for example ColOpPrefix. + -- Motivating example is + -- > foo + -- > $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + -- > , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + -- > ] + -- > ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ] + -- If we break the alignment here, then all three lines for the first + -- list move left by one, which is horrible. We really don't want to + -- break whole-block alignments. + -- For list, listcomp, tuple and tuples the reasoning is much simpler: + -- alignment should not have much effect anyways, so i simply make the + -- choice here that enabling alignment is the safer route for preventing + -- potential glitches, and it should never have a negative effect. + -- For RecUpdate the argument is much less clear - it is mostly a + -- personal preference to not break alignment for those, even if + -- multiline. Really, this should be configurable.. (TODO) + shouldBreakAfter :: BriDoc -> Bool + shouldBreakAfter bd = if alignBreak + then briDocIsMultiLine bd && case bd of + (BDCols ColTyOpPrefix _) -> False + (BDCols ColPatternsFuncPrefix _) -> True + (BDCols ColPatternsFuncInfix _) -> True + (BDCols ColPatterns _) -> True + (BDCols ColCasePattern _) -> True + (BDCols ColBindingLine{} _) -> True + (BDCols ColGuard _) -> True + (BDCols ColGuardedBody _) -> True + (BDCols ColBindStmt _) -> True + (BDCols ColDoLet _) -> True + (BDCols ColRecUpdate _) -> False + (BDCols ColListComp _) -> False + (BDCols ColList _) -> False + (BDCols ColApp _) -> True + (BDCols ColTuple _) -> False + (BDCols ColTuples _) -> False + (BDCols ColOpPrefix _) -> False + _ -> True + else False + + mergeInfoBriDoc + :: Bool + -> ColInfo + -> BriDoc + -> StateS.StateT ColBuildState Identity ColInfo + mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag + mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = + \case + brdc@(BDCols colSig subDocs) + | infoSig == colSig && length subLengthsInfos == length subDocs + -> do + let + isLastList = if lastFlag + then (==length subDocs) <$> [1 ..] + else repeat False + infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs + `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd + let curLengths = briDocLineLength <$> subDocs + let trueSpacings = getTrueSpacings (zip curLengths infos) + do -- update map + s <- StateS.get + let m = _cbs_map s + let (Just (_, spaces)) = IntMapS.lookup infoInd m + StateS.put s + { _cbs_map = IntMapS.insert + infoInd + (lastFlag, spaces Seq.|> trueSpacings) + m + } + return $ ColInfo infoInd colSig (zip curLengths infos) + | otherwise + -> briDocToColInfo lastFlag brdc + brdc -> return $ ColInfoNo brdc + +briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo +briDocToColInfo lastFlag = \case + BDCols sig list -> withAlloc lastFlag $ \ind -> do + let isLastList = + if lastFlag then (==length list) <$> [1 ..] else repeat False + subInfos <- zip isLastList list `forM` uncurry briDocToColInfo + let lengthInfos = zip (briDocLineLength <$> list) subInfos + let trueSpacings = getTrueSpacings lengthInfos + return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) + bd -> return $ ColInfoNo bd + +getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] +getTrueSpacings lengthInfos = lengthInfos <&> \case + (len, ColInfo i _ _) -> ColumnSpacingRef len i + (len, _ ) -> ColumnSpacingLeaf len + +withAlloc + :: Bool + -> ( ColIndex + -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) + ) + -> StateS.State ColBuildState ColInfo +withAlloc lastFlag f = do + cbs <- StateS.get + let ind = _cbs_index cbs + StateS.put $ cbs { _cbs_index = ind + 1 } + (space, info) <- f ind + StateS.get >>= \c -> StateS.put + $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c } + return info + +processInfo :: LayoutConstraints m => ColMap2 -> ColInfo -> m () +processInfo m = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo ind _ list -> do + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack + alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack + curX <- do + state <- mGet + -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) + let spaceAdd = case _lstate_addSepSpace state of + Nothing -> 0 + Just i -> i + return $ case _lstate_curYOrAddNewline state of + Left i -> case _lstate_commentCol state of + Nothing -> spaceAdd + i + Just c -> c + Right{} -> spaceAdd + -- tellDebugMess $ show curX + let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m + let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols + -- handle the cases that the vertical alignment leads to more than max + -- cols: + -- this is not a full fix, and we must correct individually in addition. + -- because: the (at least) line with the largest element in the last + -- column will always still overflow, because we just updated the column + -- sizes in such a way that it works _if_ we have sizes (*factor) + -- in each column. but in that line, in the last column, we will be + -- forced to occupy the full vertical space, not reduced by any factor. + let fixedPosXs = case alignMode of + ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) + where + factor :: Float = + -- 0.0001 as an offering to the floating point gods. + min + 1.0001 + (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) + offsets = (subtract curX) <$> posXs + fixed = offsets <&> fromIntegral .> (*factor) .> truncate + _ -> posXs + -- tellDebugMess $ "maxCols = " ++ show maxCols + -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs + let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do + layoutWriteEnsureAbsoluteN destX + processInfo m (snd x) + noAlignAct = list `forM_` (snd .> processInfoIgnore) + animousAct = + -- per-item check if there is overflowing. + if List.last fixedPosXs + fst (List.last list) > colMax + then noAlignAct + else alignAct + case alignMode of + ColumnAlignModeDisabled -> noAlignAct + ColumnAlignModeUnanimously | maxX <= colMax -> alignAct + ColumnAlignModeUnanimously -> noAlignAct + ColumnAlignModeMajority limit | ratio >= limit -> animousAct + ColumnAlignModeMajority{} -> noAlignAct + ColumnAlignModeAnimouslyScale{} -> animousAct + ColumnAlignModeAnimously -> animousAct + ColumnAlignModeAlways -> alignAct + +processInfoIgnore :: LayoutConstraints m => ColInfo -> m () +processInfoIgnore = \case + ColInfoStart -> error "should not happen (TM)" + ColInfoNo doc -> layoutBriDocM doc + ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) + diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs new file mode 100644 index 0000000..a7d8594 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -0,0 +1,599 @@ +#define INSERTTRACES 0 + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeApplications #-} +#if !INSERTTRACES +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif + +module Language.Haskell.Brittany.Internal.BackendUtils + ( layoutWriteAppend + , layoutWriteAppendMultiline + , layoutWriteNewlineBlock + , layoutWriteNewline + , layoutWriteEnsureNewlineBlock + , layoutWriteEnsureBlock + , layoutWithAddBaseCol + , layoutWithAddBaseColBlock + , layoutWithAddBaseColN + , layoutWithAddBaseColNBlock + , layoutBaseYPushCur + , layoutBaseYPop + , layoutIndentLevelPushCur + , layoutIndentLevelPop + , layoutWriteEnsureAbsoluteN + , layoutAddSepSpace + , layoutSetCommentCol + , layoutMoveToCommentPos + , layoutIndentRestorePostComment + , moveToExactAnn + , ppmMoveToExactLoc + , layoutWritePriorComments + , layoutWritePostComments + , layoutRemoveIndentLevelLinger + ) +where + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey + , Annotation + , KeywordId + ) + +import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.Brittany.Internal.Utils + +import GHC ( Located, GenLocated(L), moduleNameString ) + + + +traceLocal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a) + => a + -> m () +#if INSERTTRACES +traceLocal x = do + mGet >>= tellDebugMessShow @LayoutState + tellDebugMessShow x +#else +traceLocal _ = return () +#endif + + +layoutWriteAppend + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Text + -> m () +layoutWriteAppend t = do + traceLocal ("layoutWriteAppend", t) + state <- mGet + case _lstate_curYOrAddNewline state of + Right i -> do +#if INSERTTRACES + tellDebugMessShow (" inserted newlines: ", i) +#endif + replicateM_ i $ mTell $ Text.Builder.fromString $ "\n" + Left{} -> do +#if INSERTTRACES + tellDebugMessShow (" inserted no newlines") +#endif + return () + let spaces = case _lstate_addSepSpace state of + Just i -> i + Nothing -> 0 +#if INSERTTRACES + tellDebugMessShow (" inserted spaces: ", spaces) +#endif + mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ') + mTell $ Text.Builder.fromText $ t + mModify $ \s -> s + { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of + Left c -> c + Text.length t + spaces + Right{} -> Text.length t + spaces + , _lstate_addSepSpace = Nothing + } + +layoutWriteAppendSpaces + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () +layoutWriteAppendSpaces i = do + traceLocal ("layoutWriteAppendSpaces", i) + unless (i == 0) $ do + state <- mGet + mSet $ state + { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state + } + +layoutWriteAppendMultiline + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Text + -> m () +layoutWriteAppendMultiline t = do + traceLocal ("layoutWriteAppendMultiline", t) + case Text.lines t of + [] -> layoutWriteAppend t -- need to write empty, too. + (l:lr) -> do + layoutWriteAppend l + lr `forM_` \x -> do + layoutWriteNewline + layoutWriteAppend x + +-- adds a newline and adds spaces to reach the base column. +layoutWriteNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () +layoutWriteNewlineBlock = do + traceLocal ("layoutWriteNewlineBlock") + state <- mGet + mSet $ state { _lstate_curYOrAddNewline = Right 1 + , _lstate_addSepSpace = Just $ lstate_baseY state + } + +-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) => Int -> m () +-- layoutMoveToIndentCol i = do +-- #if INSERTTRACES +-- tellDebugMessShow ("layoutMoveToIndentCol", i) +-- #endif +-- state <- mGet +-- mSet $ state +-- { _lstate_addSepSpace = Just +-- $ if isJust $ _lstate_addNewline state +-- then i +-- else _lstate_indLevelLinger state + i - _lstate_curY state +-- } + +layoutSetCommentCol + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutSetCommentCol = do + state <- mGet + let col = case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state + traceLocal ("layoutSetCommentCol", col) + unless (Data.Maybe.isJust $ _lstate_commentCol state) + $ mSet state { _lstate_commentCol = Just col } + +layoutMoveToCommentPos + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> Int + -> m () +layoutMoveToCommentPos y x = do + traceLocal ("layoutMoveToCommentPos", y, x) + state <- mGet + mSet state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right{} -> Right y + , _lstate_addSepSpace = if Data.Maybe.isJust (_lstate_commentCol state) + then Just $ case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else Just $ if y == 0 then x else _lstate_indLevelLinger state + x + , _lstate_commentCol = Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state + } + + +-- | does _not_ add spaces to again reach the current base column. +layoutWriteNewline + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () +layoutWriteNewline = do + traceLocal ("layoutWriteNewline") + state <- mGet + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right (i + 1) + , _lstate_addSepSpace = Nothing + } + +layoutWriteEnsureNewlineBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () +layoutWriteEnsureNewlineBlock = do + traceLocal ("layoutWriteEnsureNewlineBlock") + state <- mGet + mSet $ state + { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of + Left{} -> Right 1 + Right i -> Right $ max 1 i + , _lstate_addSepSpace = Just $ lstate_baseY state + , _lstate_commentCol = Nothing + } + +layoutWriteEnsureAbsoluteN + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () +layoutWriteEnsureAbsoluteN n = do + state <- mGet + let diff = case _lstate_curYOrAddNewline state of + Left i -> n - i + Right{} -> n + traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) + when (diff > 0) $ do + mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to + -- at least (Just 1), so we won't + -- overwrite any old value in any + -- bad way. + } + +layoutBaseYPushInternal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) + => Int + -> m () +layoutBaseYPushInternal i = do + traceLocal ("layoutBaseYPushInternal", i) + mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } + +layoutBaseYPopInternal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutBaseYPopInternal = do + traceLocal ("layoutBaseYPopInternal") + mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } + +layoutIndentLevelPushInternal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) + => Int + -> m () +layoutIndentLevelPushInternal i = do + traceLocal ("layoutIndentLevelPushInternal", i) + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = i : _lstate_indLevels s + } + +layoutIndentLevelPopInternal + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutIndentLevelPopInternal = do + traceLocal ("layoutIndentLevelPopInternal") + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + , _lstate_indLevels = List.tail $ _lstate_indLevels s + } + +layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) => m () +layoutRemoveIndentLevelLinger = do +#if INSERTTRACES + tellDebugMessShow ("layoutRemoveIndentLevelLinger") +#endif + mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s + } + +layoutWithAddBaseCol + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + , MonadMultiWriter (Seq String) m + ) + => m () + -> m () +layoutWithAddBaseCol m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseCol") +#endif + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + m + layoutBaseYPopInternal + +layoutWithAddBaseColBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader Config m + , MonadMultiWriter (Seq String) m + ) + => m () + -> m () +layoutWithAddBaseColBlock m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseColBlock") +#endif + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutBaseYPopInternal + +layoutWithAddBaseColNBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () + -> m () +layoutWithAddBaseColNBlock amount m = do + traceLocal ("layoutWithAddBaseColNBlock", amount) + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + layoutWriteEnsureBlock + m + layoutBaseYPopInternal + +layoutWriteEnsureBlock + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => m () +layoutWriteEnsureBlock = do + traceLocal ("layoutWriteEnsureBlock") + state <- mGet + let + diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of + (Nothing, Left i ) -> lstate_baseY state - i + (Nothing, Right{}) -> lstate_baseY state + (Just sp, Left i ) -> max sp (lstate_baseY state - i) + (Just sp, Right{}) -> max sp (lstate_baseY state) + -- when (diff>0) $ layoutWriteNewlineBlock + when (diff > 0) $ do + mSet $ state { _lstate_addSepSpace = Just $ diff } + +layoutWithAddBaseColN + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Int + -> m () + -> m () +layoutWithAddBaseColN amount m = do +#if INSERTTRACES + tellDebugMessShow ("layoutWithAddBaseColN", amount) +#endif + state <- mGet + layoutBaseYPushInternal $ lstate_baseY state + amount + m + layoutBaseYPopInternal + +layoutBaseYPushCur + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutBaseYPushCur = do + traceLocal ("layoutBaseYPushCur") + state <- mGet + case _lstate_commentCol state of + Nothing -> + case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i , Just j ) -> layoutBaseYPushInternal (i + j) + (Left i , Nothing) -> layoutBaseYPushInternal i + (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state + Just cCol -> layoutBaseYPushInternal cCol + +layoutBaseYPop + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutBaseYPop = do + traceLocal ("layoutBaseYPop") + layoutBaseYPopInternal + +layoutIndentLevelPushCur + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutIndentLevelPushCur = do + traceLocal ("layoutIndentLevelPushCur") + state <- mGet + let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i , Just j ) -> i + j + (Left i , Nothing) -> i + (Right{}, Just j ) -> j + (Right{}, Nothing) -> 0 + layoutIndentLevelPushInternal y + layoutBaseYPushInternal y + +layoutIndentLevelPop + :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m () +layoutIndentLevelPop = do + traceLocal ("layoutIndentLevelPop") + layoutBaseYPopInternal + layoutIndentLevelPopInternal + -- why are comment indentations relative to the previous indentation on + -- the first node of an additional indentation, and relative to the outer + -- indentation after the last node of some indented stuff? sure does not + -- make sense. + layoutRemoveIndentLevelLinger + +layoutAddSepSpace :: (MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => m () +layoutAddSepSpace = do +#if INSERTTRACES + tellDebugMessShow ("layoutAddSepSpace") +#endif + state <- mGet + mSet $ state + { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } + +-- TODO: when refactoring is complete, the other version of this method +-- can probably be removed. +moveToExactAnn + :: ( MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiReader (Map AnnKey Annotation) m + , MonadMultiWriter (Seq String) m + ) + => AnnKey + -> m () +moveToExactAnn annKey = do + traceLocal ("moveToExactAnn", annKey) + anns <- mAsk + case Map.lookup annKey anns of + Nothing -> return () + Just ann -> do + -- curY <- mGet <&> _lstate_curY + let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann + -- mModify $ \state -> state { _lstate_addNewline = Just x } + mModify $ \state -> + let upd = case _lstate_curYOrAddNewline state of + Left i -> if y == 0 then Left i else Right y + Right i -> Right $ max y i + in state + { _lstate_curYOrAddNewline = upd + , _lstate_addSepSpace = if Data.Either.isRight upd + then + _lstate_commentCol state + <|> _lstate_addSepSpace state + <|> Just (lstate_baseY state) + else Nothing + , _lstate_commentCol = Nothing + } +-- fixMoveToLineByIsNewline :: MonadMultiState +-- LayoutState m => Int -> m Int +-- fixMoveToLineByIsNewline x = do +-- newLineState <- mGet <&> _lstate_isNewline +-- return $ if newLineState == NewLineStateYes +-- then x-1 +-- else x + +ppmMoveToExactLoc + :: MonadMultiWriter Text.Builder.Builder m + => ExactPrint.DeltaPos + -> m () +ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do + replicateM_ x $ mTell $ Text.Builder.fromString "\n" + replicateM_ y $ mTell $ Text.Builder.fromString " " + +-- TODO: update and use, or clean up. Currently dead code. +layoutWritePriorComments + :: ( Data.Data.Data ast + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m + ) + => Located ast + -> m () +layoutWritePriorComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns + } + return mAnn +#if INSERTTRACES + tellDebugMessShow ("layoutWritePriorComments", ExactPrint.mkAnnKey ast, mAnn) +#endif + case mAnn of + Nothing -> return () + Just priors -> do + when (not $ null priors) $ layoutSetCommentCol + priors `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppendSpaces y + layoutWriteAppendMultiline $ Text.pack $ comment + +-- TODO: update and use, or clean up. Currently dead code. +-- this currently only extracs from the `annsDP` field of Annotations. +-- per documentation, this seems sufficient, as the +-- "..`annFollowingComments` are only added by AST transformations ..". +layoutWritePostComments :: (Data.Data.Data ast, + MonadMultiWriter Text.Builder.Builder m, + MonadMultiState LayoutState m + , MonadMultiWriter (Seq String) m) + => Located ast -> m () +layoutWritePostComments ast = do + mAnn <- do + state <- mGet + let key = ExactPrint.mkAnnKey ast + let anns = _lstate_comments state + let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns + mSet $ state + { _lstate_comments = + Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) + key + anns + } + return mAnn +#if INSERTTRACES + tellDebugMessShow ("layoutWritePostComments", ExactPrint.mkAnnKey ast, mAnn) +#endif + case mAnn of + Nothing -> return () + Just posts -> do + when (not $ null posts) $ layoutSetCommentCol + posts `forM_` \( ExactPrint.Comment comment _ _ + , ExactPrint.DP (x, y) + ) -> do + replicateM_ x layoutWriteNewline + layoutWriteAppend $ Text.pack $ replicate y ' ' + layoutWriteAppendMultiline $ Text.pack $ comment + +layoutIndentRestorePostComment + :: ( MonadMultiState LayoutState m + , MonadMultiWriter Text.Builder.Builder m + , MonadMultiWriter (Seq String) m + ) + => m () +layoutIndentRestorePostComment = do + state <- mGet + let mCommentCol = _lstate_commentCol state + let eCurYAddNL = _lstate_curYOrAddNewline state +#if INSERTTRACES + tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) +#endif + mModify $ \s -> s { _lstate_commentCol = Nothing } + case (mCommentCol, eCurYAddNL) of + (Just commentCol, Left{}) -> do + layoutWriteEnsureNewlineBlock + layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) + _ -> return () + +-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, +-- MonadMultiWriter Text.Builder.Builder m, +-- MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) +-- => Located ast -> m () +-- layoutWritePriorCommentsRestore x = do +-- layoutWritePriorComments x +-- layoutIndentRestorePostComment +-- +-- layoutWritePostCommentsRestore :: (Data.Data.Data ast, +-- MonadMultiWriter Text.Builder.Builder m, +-- MonadMultiState LayoutState m +-- , MonadMultiWriter (Seq String) m) +-- => Located ast -> m () +-- layoutWritePostCommentsRestore x = do +-- layoutWritePostComments x +-- layoutIndentRestorePostComment diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs new file mode 100644 index 0000000..49651d7 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -0,0 +1,229 @@ +module Language.Haskell.Brittany.Internal.Config + ( CConfig(..) + , CDebugConfig(..) + , CLayoutConfig(..) + , DebugConfig + , LayoutConfig + , Config + , configParser + , staticDefaultConfig + , forwardOptionsSyntaxExtsEnabled + , readMergePersConfig + , showConfigYaml + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import qualified Data.Yaml + +import UI.Butcher.Monadic + +import qualified System.Console.CmdArgs.Explicit as CmdArgs + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config.Types.Instances +import Language.Haskell.Brittany.Internal.Utils + +import Data.Coerce ( Coercible, coerce ) + + + +staticDefaultConfig :: Config +staticDefaultConfig = Config + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig + { _dconf_dump_config = coerce False + , _dconf_dump_annotations = coerce False + , _dconf_dump_ast_unknown = coerce False + , _dconf_dump_ast_full = coerce False + , _dconf_dump_bridoc_raw = coerce False + , _dconf_dump_bridoc_simpl_alt = coerce False + , _dconf_dump_bridoc_simpl_floating = coerce False + , _dconf_dump_bridoc_simpl_par = coerce False + , _dconf_dump_bridoc_simpl_columns = coerce False + , _dconf_dump_bridoc_simpl_indent = coerce False + , _dconf_dump_bridoc_final = coerce False + , _dconf_roundtrip_exactprint_only = coerce False + } + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline + , _econf_omit_output_valid_check = coerce False + } + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = coerce CPPModeAbort + , _ppconf_hackAroundIncludes = coerce False + } + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] + } + } + +forwardOptionsSyntaxExtsEnabled :: ForwardOptions +forwardOptionsSyntaxExtsEnabled = ForwardOptions + { _options_ghc = Identity + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] + } + +configParser :: CmdParser Identity out (CConfig Option) +configParser = do + -- TODO: why does the default not trigger; ind never should be []!! + ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") + cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") + importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)") + dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") + dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") + dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") + dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") + dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") + dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") + dumpBriDocFloating <- addSimpleBoolFlag "" + ["dump-bridoc-floating"] + (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") + dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") + + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") + wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany") + + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + + optionsGhc <- addFlagStringParams "" + ["ghc-options"] + "STRING" + (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + + return $ Config + { _conf_version = mempty + , _conf_debug = DebugConfig + { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig + , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations + , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST + , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST + , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw + , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt + , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar + , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating + , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns + , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent + , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal + , _dconf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + } + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ + , _lconfig_indentListSpecial = mempty -- falseToNothing _ + , _lconfig_importColumn = optionConcat importCol + , _lconfig_altChooser = mempty + , _lconfig_columnAlignMode = mempty + , _lconfig_alignmentLimit = mempty + , _lconfig_alignmentBreakOnMultiline = mempty + } + , _conf_errorHandling = ErrorHandlingConfig + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + , _econf_ExactPrintFallback = mempty + , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck + } + , _conf_preprocessor = PreProcessorConfig + { _ppconf_CPPMode = mempty + , _ppconf_hackAroundIncludes = mempty + } + , _conf_forward = ForwardOptions + { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] + } + } + where + falseToNothing = Option . Bool.bool Nothing (Just True) + wrapLast :: Option a -> Option (Semigroup.Last a) + wrapLast = fmap Semigroup.Last + optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a) + optionConcat = mconcat . fmap (pure . pure) + +-- configParser :: Parser Config +-- configParser = Config +-- <$> option (eitherReader $ maybe (Left "required <int>!") Right . readMaybe) +-- (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level") +-- <*> (Bar +-- <$> switch (long "bara" <> help "bara help") +-- <*> switch (long "barb") +-- <*> flag 3 5 (long "barc") +-- ) +-- +-- configParserInfo :: ParserInfo Config +-- configParserInfo = ParserInfo +-- { infoParser = configParser +-- , infoFullDesc = True +-- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" +-- , infoHeader = return $ PP.text "brittany" +-- , infoFooter = empty +-- , infoFailureCode = (-55) +-- , infoIntersperse = True +-- } + +readMergePersConfig + :: System.IO.FilePath -> Bool -> CConfig Option -> MaybeT IO (CConfig Option) +readMergePersConfig path shouldCreate conf = do + exists <- liftIO $ System.Directory.doesFileExist path + if + | exists -> do + contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm. + fileConf <- case Data.Yaml.decodeEither contents of + Left e -> do + liftIO + $ putStrErrLn + $ "error reading in brittany config from " ++ path ++ ":" + liftIO $ putStrErrLn e + mzero + Right x -> return x + return $ fileConf Semigroup.<> conf + | shouldCreate -> do + liftIO $ ByteString.writeFile path + $ Data.Yaml.encode + $ cMap (Option . Just . runIdentity) staticDefaultConfig + return $ conf + | otherwise -> do + return conf + +showConfigYaml :: Config -> String +showConfigYaml = Data.ByteString.Char8.unpack + . Data.Yaml.encode + . cMap (\(Identity x) -> Just x) + diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs similarity index 52% rename from source/library/Language/Haskell/Brittany/Internal/Config/Types.hs rename to src/Language/Haskell/Brittany/Internal/Config/Types.hs index 0f0075a..4fd4765 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -1,21 +1,28 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} -module Language.Haskell.Brittany.Internal.Config.Types where +module Language.Haskell.Brittany.Internal.Config.Types +where + + + +#include "prelude.inc" + +import Data.Yaml +import qualified Data.Aeson.Types as Aeson +import GHC.Generics + +import Data.Data ( Data ) + +import Data.Coerce ( Coercible, coerce ) + +import Data.Semigroup.Generic +import Data.Semigroup ( Last, Option ) import Data.CZipWith -import Data.Coerce (Coercible, coerce) -import Data.Data (Data) -import qualified Data.Semigroup as Semigroup -import Data.Semigroup (Last) -import Data.Semigroup.Generic -import GHC.Generics -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils () @@ -23,40 +30,33 @@ confUnpack :: Coercible a b => Identity a -> b confUnpack (Identity x) = coerce x data CDebugConfig f = DebugConfig - { _dconf_dump_config :: f (Semigroup.Last Bool) - , _dconf_dump_annotations :: f (Semigroup.Last Bool) - , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) - , _dconf_dump_ast_full :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) - , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) - , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) + , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CLayoutConfig f = LayoutConfig - { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. , _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentAmount :: f (Last Int) , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. , _lconfig_importColumn :: f (Last Int) - -- ^ for import statement layouting, column at which to align the - -- elements to be imported from a module. - -- It is expected that importAsColumn >= importCol. - , _lconfig_importAsColumn :: f (Last Int) - -- ^ for import statement layouting, column at which put the module's - -- "as" name (which also affects the positioning of the "as" keyword). - -- It is expected that importAsColumn >= importCol. - , _lconfig_altChooser :: f (Last AltChooser) + , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) - , _lconfig_alignmentLimit :: f (Last Int) + , _lconfig_alignmentLimit :: f (Last Int) -- roughly speaking, this sets an upper bound to the number of spaces -- inserted to create horizontal alignment. -- More specifically, if 'xs' are the widths of the columns in some @@ -73,85 +73,18 @@ data CLayoutConfig f = LayoutConfig -- short <- some more stuff -- that requires two lines -- loooooooong <- stuff - , _lconfig_hangingTypeSignature :: f (Last Bool) - -- Do not put "::" in a new line, and use hanging indentation for the - -- signature, i.e.: - -- func :: SomeLongStuff - -- -> SomeLongStuff - -- instead of the usual - -- func - -- :: SomeLongStuff - -- -> SomeLongStuff - -- As usual for hanging indentation, the result will be - -- context-sensitive (in the function name). - , _lconfig_reformatModulePreamble :: f (Last Bool) - -- whether the module preamble/header (module keyword, name, export list, - -- import statements) are reformatted. If false, only the elements of the - -- module (everything past the "where") are reformatted. - , _lconfig_allowSingleLineExportList :: f (Last Bool) - -- if true, and it fits in a single line, and there are no comments in the - -- export list, the following layout will be used: - -- > module MyModule (abc, def) where - -- > [stuff] - -- otherwise, the multi-line version is used: - -- > module MyModule - -- > ( abc - -- > , def - -- > ) - -- > where - , _lconfig_allowHangingQuasiQuotes :: f (Last Bool) - -- if false, the layouter sees any splices as infinitely big and places - -- them accordingly (in newlines, most likely); This also influences - -- parent nodes. - -- if true, the layouter is free to start a quasi-quotation at the end - -- of a line. - -- - -- false: - -- > let - -- > body = - -- > [json| - -- > hello - -- > |] - -- - -- true: - -- > let body = [json| - -- > hello - -- > |] - , _lconfig_experimentalSemicolonNewlines :: f (Last Bool) - -- enables an experimental feature to turn semicolons in brace notation - -- into newlines when using layout: - -- - -- > do { a ;; b } - -- - -- turns into - -- > do - -- > a - -- > - -- > b - -- - -- The implementation for this is a bit hacky and not tested; it might - -- break output syntax or not work properly for every kind of brace. So - -- far I have considered `do` and `case-of`. - -- , _lconfig_allowSinglelineRecord :: f (Last Bool) - -- -- if true, layouts record data decls as a single line when possible, e.g. - -- -- > MyPoint { x :: Double, y :: Double } - -- -- if false, always use the multi-line layout - -- -- > MyPoint - -- -- > { x :: Double - -- -- > , y :: Double - -- -- > } } - deriving Generic + deriving (Generic) data CForwardOptions f = ForwardOptions { _options_ghc :: f [String] } - deriving Generic + deriving (Generic) data CErrorHandlingConfig f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) - , _econf_Werror :: f (Semigroup.Last Bool) - , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) + , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) -- ^ Determines when to fall back on the exactprint'ed output when -- syntactical constructs are encountered which are not yet handled by -- brittany. @@ -161,34 +94,23 @@ data CErrorHandlingConfig f = ErrorHandlingConfig -- has different semantics than the code pre-transformation. , _econf_omit_output_valid_check :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CPreProcessorConfig f = PreProcessorConfig { _ppconf_CPPMode :: f (Semigroup.Last CPPMode) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) } - deriving Generic + deriving (Generic) data CConfig f = Config - { _conf_version :: f (Semigroup.Last Int) - , _conf_debug :: CDebugConfig f - , _conf_layout :: CLayoutConfig f + { _conf_version :: f (Semigroup.Last Int) + , _conf_debug :: CDebugConfig f + , _conf_layout :: CLayoutConfig f , _conf_errorHandling :: CErrorHandlingConfig f - , _conf_forward :: CForwardOptions f - , _conf_preprocessor :: CPreProcessorConfig f - , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - -- ^ this field is somewhat of a duplicate of the one in DebugConfig. - -- It is used for per-declaration disabling by the inline config - -- implementation. Could have re-used the existing field, but felt risky - -- to use a "debug" labeled field for non-debug functionality. - , _conf_disable_formatting :: f (Semigroup.Last Bool) - -- ^ Used for inline config that disables brittany entirely for this - -- module. Useful for wildcard application - -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something - -- in that direction). - , _conf_obfuscate :: f (Semigroup.Last Bool) + , _conf_forward :: CForwardOptions f + , _conf_preprocessor :: CPreProcessorConfig f } - deriving Generic + deriving (Generic) type DebugConfig = CDebugConfig Identity type LayoutConfig = CLayoutConfig Identity @@ -204,12 +126,12 @@ deriving instance Show (CForwardOptions Identity) deriving instance Show (CPreProcessorConfig Identity) deriving instance Show (CConfig Identity) -deriving instance Show (CDebugConfig Maybe) -deriving instance Show (CLayoutConfig Maybe) -deriving instance Show (CErrorHandlingConfig Maybe) -deriving instance Show (CForwardOptions Maybe) -deriving instance Show (CPreProcessorConfig Maybe) -deriving instance Show (CConfig Maybe) +deriving instance Show (CDebugConfig Option) +deriving instance Show (CLayoutConfig Option) +deriving instance Show (CErrorHandlingConfig Option) +deriving instance Show (CForwardOptions Option) +deriving instance Show (CPreProcessorConfig Option) +deriving instance Show (CConfig Option) deriving instance Data (CDebugConfig Identity) deriving instance Data (CLayoutConfig Identity) @@ -218,24 +140,17 @@ deriving instance Data (CForwardOptions Identity) deriving instance Data (CPreProcessorConfig Identity) deriving instance Data (CConfig Identity) -deriving instance Data (CDebugConfig Maybe) -deriving instance Data (CLayoutConfig Maybe) -deriving instance Data (CErrorHandlingConfig Maybe) -deriving instance Data (CForwardOptions Maybe) -deriving instance Data (CPreProcessorConfig Maybe) -deriving instance Data (CConfig Maybe) - -instance Semigroup.Semigroup (CDebugConfig Maybe) where +instance Semigroup.Semigroup (CDebugConfig Option) where (<>) = gmappend -instance Semigroup.Semigroup (CLayoutConfig Maybe) where +instance Semigroup.Semigroup (CLayoutConfig Option) where (<>) = gmappend -instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where +instance Semigroup.Semigroup (CErrorHandlingConfig Option) where (<>) = gmappend -instance Semigroup.Semigroup (CForwardOptions Maybe) where +instance Semigroup.Semigroup (CForwardOptions Option) where (<>) = gmappend -instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where +instance Semigroup.Semigroup (CPreProcessorConfig Option) where (<>) = gmappend -instance Semigroup.Semigroup (CConfig Maybe) where +instance Semigroup.Semigroup (CConfig Option) where (<>) = gmappend instance Semigroup.Semigroup (CDebugConfig Identity) where @@ -251,18 +166,24 @@ instance Semigroup.Semigroup (CPreProcessorConfig Identity) where instance Semigroup.Semigroup (CConfig Identity) where (<>) = gmappend -instance Monoid (CDebugConfig Maybe) where +instance Monoid (CDebugConfig Option) where mempty = gmempty -instance Monoid (CLayoutConfig Maybe) where + mappend = gmappend +instance Monoid (CLayoutConfig Option) where mempty = gmempty -instance Monoid (CErrorHandlingConfig Maybe) where + mappend = gmappend +instance Monoid (CErrorHandlingConfig Option) where mempty = gmempty -instance Monoid (CForwardOptions Maybe) where + mappend = gmappend +instance Monoid (CForwardOptions Option) where mempty = gmempty -instance Monoid (CPreProcessorConfig Maybe) where + mappend = gmappend +instance Monoid (CPreProcessorConfig Option) where mempty = gmempty -instance Monoid (CConfig Maybe) where + mappend = gmappend +instance Monoid (CConfig Option) where mempty = gmempty + mappend = gmappend data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more @@ -270,7 +191,7 @@ data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more | IndentPolicyFree -- can create new indentations whereever | IndentPolicyMultiple -- can create indentations only -- at any n * amount. - deriving (Eq, Show, Generic, Data) + deriving (Show, Generic, Data) data AltChooser = AltChooserSimpleQuick -- always choose last alternative. -- leads to tons of sparsely filled @@ -323,6 +244,9 @@ data ExactPrintFallbackMode -- A PROGRAM BY TRANSFORMING IT. deriving (Show, Generic, Data) +cMap :: CZipWith k => (forall a . f a -> g a) -> k f -> k g +cMap f c = cZipWith (\_ -> f) c c + deriveCZipWith ''CDebugConfig deriveCZipWith ''CLayoutConfig deriveCZipWith ''CErrorHandlingConfig @@ -330,9 +254,3 @@ deriveCZipWith ''CForwardOptions deriveCZipWith ''CPreProcessorConfig deriveCZipWith ''CConfig -instance CFunctor CDebugConfig -instance CFunctor CLayoutConfig -instance CFunctor CErrorHandlingConfig -instance CFunctor CForwardOptions -instance CFunctor CPreProcessorConfig -instance CFunctor CConfig diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs new file mode 100644 index 0000000..5f9f781 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -0,0 +1,127 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- These optimizations are disabled to improve compile times (and compilation +-- memory usage). When we do not disable them, the CI servers take more than +-- 10 minutes to compile this module alone. +-- Having looked into aeson and how the instances are written, I still do +-- not understand what makes GHC choke so much here. The size of the raw +-- expressions below looks fairly negligible, so there must be some expansion +-- due to inlining going on. But even disabling INLINE pragmas in aeson did +-- not seem to change anything. +-- Nonetheless, this solution works and has no downsides because the +-- instances defined here are not in any way performance-critical. +{-# OPTIONS_GHC -fno-pre-inlining #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fignore-interface-pragmas #-} + +module Language.Haskell.Brittany.Internal.Config.Types.Instances +where + + + +#include "prelude.inc" + +import Data.Yaml +import qualified Data.Aeson.Types as Aeson + +import Language.Haskell.Brittany.Internal.Config.Types + +import GHC.Generics + + + +aesonDecodeOptionsBrittany :: Aeson.Options +aesonDecodeOptionsBrittany = Aeson.defaultOptions + { Aeson.omitNothingFields = True + , Aeson.fieldLabelModifier = dropWhile (=='_') + } + +#define makeFromJSON(type)\ + instance FromJSON (type) where\ + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany;\ + {-# NOINLINE parseJSON #-} +#define makeToJSON(type)\ + instance ToJSON (type) where\ + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany;\ + {-# NOINLINE toJSON #-};\ + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany;\ + {-# NOINLINE toEncoding #-} + +#define makeFromJSONMaybe(type)\ + instance FromJSON (type Maybe) where\ + parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany;\ + {-# NOINLINE parseJSON #-} +#define makeFromJSONOption(type)\ + instance FromJSON (type Option) where\ + parseJSON = fmap (cMap Option) . parseJSON;\ + {-# NOINLINE parseJSON #-} +#define makeToJSONMaybe(type)\ + instance ToJSON (type Maybe) where\ + toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany;\ + {-# NOINLINE toJSON #-};\ + toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany;\ + {-# NOINLINE toEncoding #-} +#define makeToJSONOption(type)\ + instance ToJSON (type Option) where\ + toJSON = toJSON . cMap getOption;\ + {-# NOINLINE toJSON #-};\ + toEncoding = toEncoding . cMap getOption;\ + {-# NOINLINE toEncoding #-} + + +makeFromJSONOption(CDebugConfig) +makeFromJSONMaybe(CDebugConfig) +makeToJSONOption(CDebugConfig) +makeToJSONMaybe(CDebugConfig) + +makeFromJSON(IndentPolicy) +makeToJSON(IndentPolicy) +makeFromJSON(AltChooser) +makeToJSON(AltChooser) +makeFromJSON(ColumnAlignMode) +makeToJSON(ColumnAlignMode) +makeFromJSON(CPPMode) +makeToJSON(CPPMode) +makeFromJSON(ExactPrintFallbackMode) +makeToJSON(ExactPrintFallbackMode) + +makeFromJSONOption(CLayoutConfig) +makeFromJSONMaybe(CLayoutConfig) +makeToJSONOption(CLayoutConfig) +makeToJSONMaybe(CLayoutConfig) + +makeFromJSONOption(CErrorHandlingConfig) +makeFromJSONMaybe(CErrorHandlingConfig) +makeToJSONOption(CErrorHandlingConfig) +makeToJSONMaybe(CErrorHandlingConfig) + +makeFromJSONOption(CForwardOptions) +makeFromJSONMaybe(CForwardOptions) +makeToJSONOption(CForwardOptions) +makeToJSONMaybe(CForwardOptions) + +makeFromJSONOption(CPreProcessorConfig) +makeFromJSONMaybe(CPreProcessorConfig) +makeToJSONOption(CPreProcessorConfig) +makeToJSONMaybe(CPreProcessorConfig) + +makeFromJSONOption(CConfig) +makeToJSONOption(CConfig) +makeToJSONMaybe(CConfig) + +-- This custom instance ensures the "omitNothingFields" behaviour not only for +-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid +-- config file content. +instance FromJSON (CConfig Maybe) where + parseJSON (Object v) = Config + <$> v .:? Text.pack "conf_version" + <*> v .:?= Text.pack "conf_debug" + <*> v .:?= Text.pack "conf_layout" + <*> v .:?= Text.pack "conf_errorHandling" + <*> v .:?= Text.pack "conf_forward" + <*> v .:?= Text.pack "conf_preprocessor" + parseJSON invalid = Aeson.typeMismatch "Config" invalid + +-- Pretends that the value is {} when the key is not present. +(.:?=) :: FromJSON a => Object -> Text -> Parser a +o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure + diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs new file mode 100644 index 0000000..faa9526 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.ExactPrintUtils + ( parseModule + , parseModuleFromString + , commentAnnFixTransform + , commentAnnFixTransformGlob + , extractToplevelAnns + , foldedAnnKeys + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils + +import DynFlags ( getDynFlags ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import qualified DynFlags as GHC +import qualified GHC as GHC hiding (parseModule) +import qualified Parser as GHC +import qualified SrcLoc as GHC +import RdrName ( RdrName(..) ) +import HsSyn +import SrcLoc ( SrcSpan, Located ) +import RdrName ( RdrName(..) ) + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint + +import qualified Data.Generics as SYB +-- import Data.Generics.Schemes + + + +parseModule + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModule = + parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout + +-- | Parse a module with specific instructions for the C pre-processor. +parseModuleWithCpp + :: ExactPrint.CppOptions + -> ExactPrint.DeltaOptions + -> [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModuleWithCpp cpp opts args fp dynCheck = + ExactPrint.ghcWrapper $ EitherT.runEitherT $ do + dflags0 <- lift $ GHC.getSessionDynFlags + (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine + dflags0 + (GHC.noLoc <$> args) + void $ lift $ GHC.setSessionDynFlags dflags1 + dflags2 <- lift $ ExactPrint.initDynFlags fp + when (not $ null leftover) + $ EitherT.left + $ "when parsing ghc flags: leftover flags: " + ++ show (leftover <&> \(L _ s) -> s) + when (not $ null warnings) + $ EitherT.left + $ "when parsing ghc flags: encountered warnings: " + ++ show (warnings <&> \(L _ s) -> s) + x <- EitherT.EitherT $ liftIO $ dynCheck dflags2 + res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp + EitherT.hoistEither + $ either (\(span, err) -> Left $ show span ++ ": " ++ err) + (\(a, m) -> Right (a, m, x)) + $ ExactPrint.postParseTransform res opts + +parseModuleFromString + :: [String] + -> System.IO.FilePath + -> (GHC.DynFlags -> IO (Either String a)) + -> String + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +parseModuleFromString args fp dynCheck str = + ExactPrint.ghcWrapper $ EitherT.runEitherT $ do + dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str + (dflags1, leftover, warnings) <- + lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) + when (not $ null leftover) + $ EitherT.left + $ "when parsing ghc flags: leftover flags: " + ++ show (leftover <&> \(L _ s) -> s) + when (not $ null warnings) + $ EitherT.left + $ "when parsing ghc flags: encountered warnings: " + ++ show (warnings <&> \(L _ s) -> s) + x <- EitherT.EitherT $ liftIO $ dynCheck dflags1 + EitherT.hoistEither + $ either (\(span, err) -> Left $ show span ++ ": " ++ err) + (\(a, m) -> Right (a, m, x)) + $ ExactPrint.parseWith dflags1 fp GHC.parseModule str + +----------- + +commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () +commentAnnFixTransformGlob ast = do + let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) + extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ + const Seq.empty + `SYB.ext1Q` + (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) + let nodes = SYB.everything (<>) extract ast + let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey + annsMap = Map.fromListWith + (flip const) + [ (GHC.realSrcSpanEnd span, annKey) + | (GHC.RealSrcSpan span, annKey) <- Foldable.toList nodes + ] + nodes `forM_` (snd .> processComs annsMap) + where + processComs annsMap annKey1 = do + mAnn <- State.Class.gets fst <&> Map.lookup annKey1 + mAnn `forM_` \ann1 -> do + let priors = ExactPrint.annPriorComments ann1 + follows = ExactPrint.annFollowingComments ann1 + assocs = ExactPrint.annsDP ann1 + let + processCom + :: (ExactPrint.Comment, ExactPrint.DeltaPos) + -> ExactPrint.TransformT Identity Bool + processCom comPair@(com, _) = + case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of + GHC.UnhelpfulLoc{} -> return True -- retain comment at current node. + GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of + Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of + (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> + move $> False + (x, y) | x == y -> move $> False + _ -> return True + where + ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 + ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 + loc1 = GHC.srcSpanStart annKeyLoc1 + loc2 = GHC.srcSpanStart annKeyLoc2 + move = ExactPrint.modifyAnnsT $ \anns -> + let + ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns + ann2' = ann2 + { ExactPrint.annFollowingComments = + ExactPrint.annFollowingComments ann2 ++ [comPair] + } + in + Map.insert annKey2 ann2' anns + _ -> return True -- retain comment at current node. + priors' <- flip filterM priors processCom + follows' <- flip filterM follows $ processCom + assocs' <- flip filterM assocs $ \case + (ExactPrint.AnnComment com, dp) -> processCom (com, dp) + _ -> return True + let ann1' = ann1 { ExactPrint.annPriorComments = priors' + , ExactPrint.annFollowingComments = follows' + , ExactPrint.annsDP = assocs' + } + ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns + + + +commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform () +commentAnnFixTransform modul = SYB.everything (>>) genF modul + where + genF :: Data.Data.Data a => a -> ExactPrint.Transform () + genF = (\_ -> return ()) `SYB.extQ` exprF + exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform () + exprF lexpr@(L _ expr) = case expr of + RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) -> + moveTrailingComments lexpr (List.last fs) + RecordUpd _lname fs@(_:_) _ _ _ _ -> + moveTrailingComments lexpr (List.last fs) + _ -> return () + +moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b) + => GHC.Located a -> GHC.Located b -> ExactPrint.Transform () +moveTrailingComments astFrom astTo = do + let + k1 = ExactPrint.mkAnnKey astFrom + k2 = ExactPrint.mkAnnKey astTo + moveComments ans = ans' + where + an1 = Data.Maybe.fromJust $ Map.lookup k1 ans + an2 = Data.Maybe.fromJust $ Map.lookup k2 ans + cs1f = ExactPrint.annFollowingComments an1 + cs2f = ExactPrint.annFollowingComments an2 + (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1) + $ \case + (ExactPrint.AnnComment com, dp) -> Left (com, dp) + x -> Right x + an1' = an1 + { ExactPrint.annsDP = nonComments + , ExactPrint.annFollowingComments = [] + } + an2' = an2 + { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments + } + ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans + + ExactPrint.modifyAnnsT moveComments + +-- | split a set of annotations in a module into a map from top-level module +-- elements to the relevant annotations. Avoids quadratic behaviour a trivial +-- implementation would have. +extractToplevelAnns + :: Located (HsModule RdrName) + -> ExactPrint.Anns + -> Map ExactPrint.AnnKey ExactPrint.Anns +extractToplevelAnns lmod anns = output + where + (L _ (HsModule _ _ _ ldecls _ _)) = lmod + declMap :: Map ExactPrint.AnnKey ExactPrint.AnnKey + declMap = Map.unions $ ldecls <&> \ldecl -> + Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl) + modKey = ExactPrint.mkAnnKey lmod + output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns + +groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) +groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) + Map.empty + where + insert k a Nothing = Just (Map.singleton k a) + insert k a (Just m) = Just (Map.insert k a m) + +foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey +foldedAnnKeys ast = SYB.everything + Set.union + ( \x -> maybe + Set.empty + Set.singleton + [ SYB.gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x + | locTyCon == SYB.typeRepTyCon (SYB.typeOf x) + , l <- SYB.gmapQi 0 SYB.cast x + ] + ) + ast + where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) diff --git a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs similarity index 56% rename from source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs rename to src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 136468e..cffcad7 100644 --- a/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -1,42 +1,89 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +module Language.Haskell.Brittany.Internal.LayouterBasics + ( processDefault + , rdrNameToText + , lrdrNameToText + , lrdrNameToTextAnn + , lrdrNameToTextAnnTypeEqualityIsSpecial + , askIndent + , extractAllComments + , filterAnns + , docEmpty + , docLit + , docAlt + , docAltFilter + , docLines + , docCols + , docSeq + , docPar + , docNodeAnnKW + , docWrapNode + , docWrapNodePrior + , docWrapNodeRest + , docForceSingleline + , docForceMultiline + , docEnsureIndent + , docAddBaseY + , docSetBaseY + , docSetIndentLevel + , docSeparator + , docAnnotationPrior + , docAnnotationKW + , docAnnotationRest + , docNonBottomSpacing + , docSetParSpacing + , docForceParSpacing + , docDebug + , docSetBaseAndIndent + , briDocByExact + , briDocByExactNoComment + , briDocByExactInlineOnly + , foldedAnnKeys + , unknownNodeError + , appSep + , docCommaSep + , docParenLSep + , spacifyDocs + , briDocMToPPM + , allocateNode + , docSharedWrapper + , hasAnyCommentsBelow + ) +where -module Language.Haskell.Brittany.Internal.LayouterBasics where -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Writer.Strict as Writer -import qualified Data.Char as Char -import Data.Data -import qualified Data.Map as Map -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Data.Text.Lazy.Builder as Text.Builder -import DataTreePrint -import GHC (GenLocated(L), Located, moduleName, moduleNameString) -import qualified GHC.OldList as List -import GHC.Parser.Annotation (AnnKeywordId(..)) -import GHC.Types.Name (getOccString) -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader (RdrName(..)) -import qualified GHC.Types.SrcLoc as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.ExactPrintUtils -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +#include "prelude.inc" + import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint -import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation, KeywordId ) + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.ExactPrintUtils + +import RdrName ( RdrName(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import qualified SrcLoc as GHC +import OccName ( occNameString ) +import Name ( getOccString ) +import Module ( moduleName ) +import ApiAnnotation ( AnnKeywordId(..) ) + +import Data.Data +import Data.Generics.Schemes + +import DataTreePrint + +import Data.HList.HList + processDefault @@ -56,7 +103,7 @@ processDefault x = do -- the module (header). This would remove the need for this hack! case str of "\n" -> return () - _ -> mTell $ Text.Builder.fromString str + _ -> mTell $ Text.Builder.fromString $ str -- | Use ExactPrint's output for this node; add a newly generated inline comment -- at insertion position (meant to point out to the user that this node is @@ -68,10 +115,9 @@ briDocByExact -> ToBriDocM BriDocNumbered briDocByExact ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns True -- | Use ExactPrint's output for this node. @@ -85,45 +131,41 @@ briDocByExactNoComment -> ToBriDocM BriDocNumbered briDocByExactNoComment ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) docExt ast anns False -- | Use ExactPrint's output for this node, presuming that this output does -- not contain any newlines. If this property is not met, the semantics -- depend on the @econf_AllowRiskyExactPrintUse@ config flag. briDocByExactInlineOnly - :: (ExactPrint.Annotate.Annotate ast) + :: (ExactPrint.Annotate.Annotate ast, Data ast) => String -> Located ast -> ToBriDocM BriDocNumbered briDocByExactInlineOnly infoStr ast = do anns <- mAsk - traceIfDumpConf - "ast" - _dconf_dump_ast_unknown - (printTreeWithCustom 100 (customLayouterF anns) ast) + traceIfDumpConf "ast" + _dconf_dump_ast_unknown + (printTreeWithCustom 100 (customLayouterF anns) ast) let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack - let - exactPrintNode t = allocateNode $ BDFExternal - (ExactPrint.Types.mkAnnKey ast) - (foldedAnnKeys ast) - False - t + let exactPrintNode = allocateNode $ BDFExternal + (ExactPrint.Types.mkAnnKey ast) + (foldedAnnKeys ast) + False + exactPrinted let errorAction = do - mTell [ErrorUnknownNode infoStr ast] + mTell $ [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of - (ExactPrintFallbackModeNever, _) -> errorAction - (_, [t]) -> exactPrintNode - (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) - (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted - _ -> errorAction + (ExactPrintFallbackModeNever, _ ) -> errorAction + (_ , [_]) -> exactPrintNode + (ExactPrintFallbackModeRisky, _ ) -> exactPrintNode + _ -> errorAction rdrNameToText :: RdrName -> Text -- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr @@ -137,68 +179,37 @@ rdrNameToText (Exact name) = Text.pack $ getOccString name lrdrNameToText :: GenLocated l RdrName -> Text lrdrNameToText (L _ n) = rdrNameToText n -lrdrNameToTextAnnGen +lrdrNameToTextAnn :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => (Text -> Text) - -> Located RdrName + => Located RdrName -> m Text -lrdrNameToTextAnnGen f ast@(L _ n) = do +lrdrNameToTextAnn ast@(L _ n) = do anns <- mAsk - let t = f $ rdrNameToText n - let - hasUni x (ExactPrint.Types.G y, _) = x == y - hasUni _ _ = False + let t = rdrNameToText n + let hasUni x (ExactPrint.Types.G y, _) = x == y + hasUni _ _ = False -- TODO: in general: we should _always_ process all annotaiton stuff here. -- whatever we don't probably should have had some effect on the -- output. in such cases, resorting to byExact is probably the safe -- choice. return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> t + Nothing -> t Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of - Exact{} | t == Text.pack "()" -> t - _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" + Exact{} | t == Text.pack "()" -> t + _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnCommaTuple) aks -> t - _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" - _ | otherwise -> t - -lrdrNameToTextAnn - :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) - => Located RdrName - -> m Text -lrdrNameToTextAnn = lrdrNameToTextAnnGen id + _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" + _ | otherwise -> t lrdrNameToTextAnnTypeEqualityIsSpecial :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) => Located RdrName -> m Text lrdrNameToTextAnnTypeEqualityIsSpecial ast = do - let - f x = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - lrdrNameToTextAnnGen f ast - --- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects --- the annotations for a (parent) node for a tick to be added to the --- literal. --- Excessively long name to reflect on us having to work around such --- excessively obscure special cases in the exactprint API. -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick - :: ( Data ast - , MonadMultiReader Config m - , MonadMultiReader (Map AnnKey Annotation) m - ) - => Located ast - -> Located RdrName - -> m Text -lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do - hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote - x <- lrdrNameToTextAnn ast2 - let - lit = if x == Text.pack "Data.Type.Equality~" - then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh - else x - return $ if hasQuote then Text.cons '\'' lit else lit + x <- lrdrNameToTextAnn ast + return $ if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x askIndent :: (MonadMultiReader Config m) => m Int askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk @@ -207,113 +218,25 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk extractAllComments :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] extractAllComments ann = - ExactPrint.annPriorComments ann ++ extractRestComments ann - -extractRestComments - :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)] -extractRestComments ann = - ExactPrint.annFollowingComments ann - ++ (ExactPrint.annsDP ann >>= \case + ExactPrint.annPriorComments ann + ++ ExactPrint.annFollowingComments ann + ++ ( ExactPrint.annsDP ann >>= \case (ExactPrint.AnnComment com, dp) -> [(com, dp)] - _ -> [] + _ -> [] ) filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns -filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +filterAnns ast anns = + Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns --- | True if there are any comments that are --- a) connected to any node below (in AST sense) the given node AND --- b) after (in source code order) the node. hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsBelow ast@(L l _) = - List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l) - <$> astConnectedComments ast - -hasCommentsBetween - :: Data ast - => GHC.Located ast - -> AnnKeywordId - -> AnnKeywordId - -> ToBriDocM Bool -hasCommentsBetween ast leftKey rightKey = do - mAnn <- astAnn ast - let - go1 [] = False - go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest - go1 (_ : rest) = go1 rest - go2 [] = False - go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True - go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False - go2 (_ : rest) = go2 rest - case mAnn of - Nothing -> pure False - Just ann -> pure $ go1 $ ExactPrint.annsDP ann - --- | True if there are any comments that are connected to any node below (in AST --- sense) the given node -hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast - --- | True if there are any regular comments connected to any node below (in AST --- sense) the given node -hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsConnected ast = - any isRegularComment <$> astConnectedComments ast - --- | Regular comments are comments that are actually "source code comments", --- i.e. things that start with "--" or "{-". In contrast to comment-annotations --- used by ghc-exactprint for capturing symbols (and their exact positioning). --- --- Only the type instance layouter makes use of this filter currently, but --- it might make sense to apply it more aggressively or make it the default - --- I believe that most of the time we branch on the existence of comments, we --- only care about "regular" comments. We simply did not need the distinction --- because "irregular" comments are not that common outside of type/data decls. -isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool -isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst - -astConnectedComments - :: Data ast - => GHC.Located ast - -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)] -astConnectedComments ast = do +hasAnyCommentsBelow ast@(L l _) = do anns <- filterAnns ast <$> mAsk - pure $ extractAllComments =<< Map.elems anns - -hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyCommentsPrior ast = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors - -hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool -hasAnyRegularCommentsRest ast = astAnn ast <&> \case - Nothing -> False - Just ann -> any isRegularComment (extractRestComments ann) - -hasAnnKeywordComment - :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool -hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just ann -> any hasK (extractAllComments ann) - where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst - -hasAnnKeyword - :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) - => Located a - -> AnnKeywordId - -> m Bool -hasAnnKeyword ast annKeyword = astAnn ast <&> \case - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks - where - hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - -astAnn - :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) - => GHC.Located ast - -> m (Maybe Annotation) -astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk + return + $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) + $ (=<<) extractAllComments + $ Map.elems + $ anns -- new BriDoc stuff @@ -331,10 +254,10 @@ allocNodeIndex = do -- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docEmpty = allocateNode BDFEmpty --- +-- -- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered -- docLit t = allocateNode $ BDFLit t --- +-- -- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m) -- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered -- docExt x anns shouldAddComment = allocateNode $ BDFExternal @@ -342,51 +265,51 @@ allocNodeIndex = do -- (foldedAnnKeys x) -- shouldAddComment -- (Text.pack $ ExactPrint.exactPrint x anns) --- +-- -- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docAlt l = allocateNode . BDFAlt =<< sequence l --- --- +-- +-- -- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docSeq l = allocateNode . BDFSeq =<< sequence l --- +-- -- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered -- docLines l = allocateNode . BDFLines =<< sequence l --- +-- -- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered -- docCols sig l = allocateNode . BDFCols sig =<< sequence l --- +-- -- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered -- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm --- +-- -- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm --- +-- -- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm --- +-- -- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docSeparator = allocateNode BDFSeparator --- +-- -- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered -- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm --- +-- -- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered -- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm --- +-- -- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm --- +-- -- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- appSep x = docSeq [x, docSeparator] --- +-- -- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docCommaSep = appSep $ docLit $ Text.pack "," --- +-- -- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docParenLSep = appSep $ docLit $ Text.pack "(" --- --- +-- +-- -- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m) -- => Located ast -- -> m BriDocNumbered @@ -394,7 +317,7 @@ allocNodeIndex = do -- docPostComment ast bdm = do -- bd <- bdm -- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd --- +-- -- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m) -- => Located ast -- -> m BriDocNumbered @@ -409,7 +332,7 @@ allocNodeIndex = do -- $ (,) i2 -- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) -- $ bd --- +-- -- docPar :: MonadMultiState NodeAllocIndex m -- => m BriDocNumbered -- -> m BriDocNumbered @@ -418,13 +341,13 @@ allocNodeIndex = do -- line <- lineM -- indented <- indentedM -- allocateNode $ BDFPar BrIndentNone line indented --- +-- -- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm --- +-- -- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered -- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm --- +-- -- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered -- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd @@ -434,9 +357,6 @@ docEmpty = allocateNode BDFEmpty docLit :: Text -> ToBriDocM BriDocNumbered docLit t = allocateNode $ BDFLit t -docLitS :: String -> ToBriDocM BriDocNumbered -docLitS s = allocateNode $ BDFLit $ Text.pack s - docExt :: (ExactPrint.Annotate.Annotate ast) => Located ast @@ -452,17 +372,8 @@ docExt x anns shouldAddComment = allocateNode $ BDFExternal docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt l = allocateNode . BDFAlt =<< sequence l -newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a) - deriving (Functor, Applicative, Monad) - -addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () -addAlternativeCond cond doc = when cond (addAlternative doc) - -addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () -addAlternative = CollectAltM . Writer.tell . (: []) - -runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered -runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action +docAltFilter :: [(Bool, ToBriDocM BriDocNumbered)] -> ToBriDocM BriDocNumbered +docAltFilter = docAlt . map snd . filter fst docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered @@ -502,35 +413,21 @@ docSeparator = allocateNode BDFSeparator docAnnotationPrior :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationPrior annKey bdm = - allocateNode . BDFAnnotationPrior annKey =<< bdm +docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm docAnnotationKW :: AnnKey -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docAnnotationKW annKey kw bdm = - allocateNode . BDFAnnotationKW annKey kw =<< bdm - -docMoveToKWDP - :: AnnKey - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docMoveToKWDP annKey kw shouldRestoreIndent bdm = - allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm +docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docAnnotationRest :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm - -docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm @@ -548,35 +445,7 @@ docCommaSep :: ToBriDocM BriDocNumbered docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered -docParenLSep = appSep docParenL - --- TODO: we don't make consistent use of these (yet). However, I think the --- most readable approach overall might be something else: define --- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`. --- I think those two would make the usage most readable. --- lit "(" and appSep (lit "(") are understandable and short without --- introducing a new top-level binding for all types of parentheses. -docParenL :: ToBriDocM BriDocNumbered -docParenL = docLit $ Text.pack "(" - -docParenR :: ToBriDocM BriDocNumbered -docParenR = docLit $ Text.pack ")" - -docParenHashLSep :: ToBriDocM BriDocNumbered -docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] - -docParenHashRSep :: ToBriDocM BriDocNumbered -docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] - -docBracketL :: ToBriDocM BriDocNumbered -docBracketL = docLit $ Text.pack "[" - -docBracketR :: ToBriDocM BriDocNumbered -docBracketR = docLit $ Text.pack "]" - - -docTick :: ToBriDocM BriDocNumbered -docTick = docLit $ Text.pack "'" +docParenLSep = appSep $ docLit $ Text.pack "(" docNodeAnnKW :: Data.Data.Data ast @@ -587,31 +456,21 @@ docNodeAnnKW docNodeAnnKW ast kw bdm = docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm -docNodeMoveToKWDP - :: Data.Data.Data ast - => Located ast - -> AnnKeywordId - -> Bool - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered -docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm - class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast - -> a - -> a + -> ToBriDocM a + -> ToBriDocM a docWrapNodePrior :: ( Data.Data.Data ast) => Located ast - -> a - -> a + -> ToBriDocM a + -> ToBriDocM a docWrapNodeRest :: ( Data.Data.Data ast) => Located ast - -> a - -> a + -> ToBriDocM a + -> ToBriDocM a -instance DocWrapable (ToBriDocM BriDocNumbered) where +instance DocWrapable BriDocNumbered where docWrapNode ast bdm = do bd <- bdm i1 <- allocNodeIndex @@ -625,102 +484,93 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNodePrior ast bdm = do bd <- bdm i1 <- allocNodeIndex - return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd + return + $ (,) i1 + $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) + $ bd docWrapNodeRest ast bdm = do bd <- bdm i2 <- allocNodeIndex - return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd + return + $ (,) i2 + $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) + $ bd -instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where - docWrapNode ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNode ast bd] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> - [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] - _ -> error "cannot happen (TM)" - docWrapNodePrior ast bdms = case bdms of - [] -> [] - [bd] -> [docWrapNodePrior ast bd] - (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR - docWrapNodeRest ast bdms = case reverse bdms of - [] -> [] - (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR - -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where +instance DocWrapable a => DocWrapable [a] where docWrapNode ast bdsm = do bds <- bdsm case bds of - [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well. + [] -> return $ [] -- TODO: this might be bad. maybe. then again, not really. well. [bd] -> do bd' <- docWrapNode ast (return bd) return [bd'] - (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ [bd1'] ++ reverse bdM ++ [bdN'] _ -> error "cannot happen (TM)" docWrapNodePrior ast bdsm = do bds <- bdsm case bds of - [] -> return [] - (bd1 : bdR) -> do + [] -> return $ [] + (bd1:bdR) -> do bd1' <- docWrapNodePrior ast (return bd1) - return (bd1' : bdR) + return $ (bd1':bdR) docWrapNodeRest ast bdsm = do bds <- bdsm case reverse bds of - [] -> return [] - (bdN : bdR) -> do + [] -> return $ [] + (bdN:bdR) -> do bdN' <- docWrapNodeRest ast (return bdN) - return $ reverse (bdN' : bdR) + return $ reverse $ (bdN':bdR) -instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where +instance DocWrapable a => DocWrapable (Seq a) where docWrapNode ast bdsm = do bds <- bdsm case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. + Seq.EmptyL -> return $ Seq.empty -- TODO: this might be bad. maybe. then again, not really. well. bd1 Seq.:< rest -> case Seq.viewr rest of Seq.EmptyR -> do bd1' <- docWrapNode ast (return bd1) return $ Seq.singleton bd1' bdM Seq.:> bdN -> do bd1' <- docWrapNodePrior ast (return bd1) - bdN' <- docWrapNodeRest ast (return bdN) + bdN' <- docWrapNodeRest ast (return bdN) return $ (bd1' Seq.<| bdM) Seq.|> bdN' docWrapNodePrior ast bdsm = do bds <- bdsm case Seq.viewl bds of - Seq.EmptyL -> return Seq.empty + Seq.EmptyL -> return $ Seq.empty bd1 Seq.:< bdR -> do bd1' <- docWrapNodePrior ast (return bd1) return $ bd1' Seq.<| bdR docWrapNodeRest ast bdsm = do bds <- bdsm case Seq.viewr bds of - Seq.EmptyR -> return Seq.empty + Seq.EmptyR -> return $ Seq.empty bdR Seq.:> bdN -> do bdN' <- docWrapNodeRest ast (return bdN) return $ bdR Seq.|> bdN' -instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where +instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where docWrapNode ast stuffM = do (bds, bd, x) <- stuffM if null bds then do bd' <- docWrapNode ast (return bd) - return (bds, bd', x) + return $ (bds, bd', x) else do bds' <- docWrapNodePrior ast (return bds) bd' <- docWrapNodeRest ast (return bd) - return (bds', bd', x) + return $ (bds', bd', x) docWrapNodePrior ast stuffM = do (bds, bd, x) <- stuffM bds' <- docWrapNodePrior ast (return bds) - return (bds', bd, x) + return $ (bds', bd, x) docWrapNodeRest ast stuffM = do (bds, bd, x) <- stuffM bd' <- docWrapNodeRest ast (return bd) - return (bds, bd', x) + return $ (bds, bd', x) @@ -729,7 +579,7 @@ docPar -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docPar lineM indentedM = do - line <- lineM + line <- lineM indented <- indentedM allocateNode $ BDFPar BrIndentNone line indented @@ -744,12 +594,9 @@ docEnsureIndent docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd unknownNodeError - :: Data.Data.Data ast - => String - -> GenLocated GHC.SrcSpan ast - -> ToBriDocM BriDocNumbered + :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered unknownNodeError infoStr ast = do - mTell [ErrorUnknownNode infoStr ast] + mTell $ [ErrorUnknownNode infoStr ast] docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered] @@ -758,24 +605,18 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds] briDocMToPPM :: ToBriDocM a -> PPMLocal a briDocMToPPM m = do - (x, errs, debugs) <- briDocMToPPMInner m + readers <- MultiRWSS.mGetRawR + let ((x, errs), debugs) = + runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) + $ MultiRWSS.withMultiReaders readers + $ MultiRWSS.withMultiWriterAW + $ MultiRWSS.withMultiWriterAW + $ m mTell debugs mTell errs return x -briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) -briDocMToPPMInner m = do - readers <- MultiRWSS.mGetRawR - let - ((x, errs), debugs) = - runIdentity - $ MultiRWSS.runMultiRWSTNil - $ MultiRWSS.withMultiStateA (NodeAllocIndex 1) - $ MultiRWSS.withMultiReaders readers - $ MultiRWSS.withMultiWriterAW - $ MultiRWSS.withMultiWriterAW - $ m - pure (x, errs, debugs) - docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) docSharedWrapper f x = return <$> f x diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs new file mode 100644 index 0000000..5073eab --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Language.Haskell.Brittany.Internal.Layouters.Decl + ( layoutSig + , layoutBind + , layoutLocalBinds + , layoutGuardLStmt + , layoutPatternBind + , layoutGrhs + , layoutPatternBindFinal + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import SrcLoc ( SrcSpan ) +import HsSyn +import Name +import BasicTypes ( InlinePragma(..) + , Activation(..) + , InlineSpec(..) + , RuleMatchInfo(..) + ) +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import Language.Haskell.Brittany.Internal.Layouters.Type +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Pattern + +import Bag ( mapBagM ) + + + +layoutSig :: ToBriDoc Sig +layoutSig lsig@(L _loc sig) = case sig of +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + TypeSig names (HsWC _ (HsIB _ typ _)) -> docWrapNode lsig $ do +#else /* ghc-8.0 */ + TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do +#endif + nameStrs <- names `forM` lrdrNameToTextAnn + let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsBelow lsig + docAlt + $ [ docSeq + [ appSep $ docWrapNodeRest lsig $ docLit nameStr + , appSep $ docLit $ Text.pack "::" + , docForceSingleline typeDoc + ] + | not hasComments + ] + ++ [ docAddBaseY BrIndentRegular $ docPar + (docWrapNodeRest lsig $ docLit nameStr) + ( docCols + ColTyOpPrefix + [ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) $ typeDoc + ] + ) + ] + InlineSig name (InlinePragma _ spec _arity phaseAct conlike) -> + docWrapNode lsig $ do + nameStr <- lrdrNameToTextAnn name + let specStr = case spec of + Inline -> "INLINE " + Inlinable -> "INLINABLE " + NoInline -> "NOINLINE " + EmptyInlineSpec -> "" -- i have no idea if this is correct. + let phaseStr = case phaseAct of + NeverActive -> "[] " + AlwaysActive -> "" + ActiveBefore _ i -> "[~" ++ show i ++ "] " + ActiveAfter _ i -> "[" ++ show i ++ "] " + let conlikeStr = case conlike of + FunLike -> "" + ConLike -> "CONLIKE " + docLit + $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) + <> nameStr + <> Text.pack " #-}" + _ -> briDocByExactNoComment lsig -- TODO + +layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName)) +layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of + BodyStmt body _ _ _ -> layoutExpr body + BindStmt lPat expr _ _ _ -> do + patDoc <- docSharedWrapper layoutPat lPat + expDoc <- docSharedWrapper layoutExpr expr + docCols ColBindStmt + [ appSep $ colsWrapPat =<< patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", expDoc] + ] + _ -> unknownNodeError "" lgstmt -- TODO + +layoutBind + :: ToBriDocC + (HsBindLR RdrName RdrName) + (Either [BriDocNumbered] BriDocNumbered) +layoutBind lbind@(L _ bind) = case bind of + FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do + idStr <- lrdrNameToTextAnn fId + binderDoc <- docLit $ Text.pack "=" + funcPatDocs <- + docWrapNode lbind + $ docWrapNode lmatches + $ layoutPatternBind (Just idStr) binderDoc + `mapM` matches + return $ Left $ funcPatDocs + PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do + patDocs <- colsWrapPat =<< layoutPat pat + clauseDocs <- layoutGrhs `mapM` grhss + mWhereDocs <- layoutLocalBinds whereBinds + binderDoc <- docLit $ Text.pack "=" + hasComments <- hasAnyCommentsBelow lbind + fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing + binderDoc + (Just patDocs) + clauseDocs + mWhereDocs + hasComments + _ -> Right <$> unknownNodeError "" lbind + +data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName) + | BagSig (LSig RdrName) + +bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan +bindOrSigtoSrcSpan (BagBind (L l _)) = l +bindOrSigtoSrcSpan (BagSig (L l _)) = l + +layoutLocalBinds + :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered]) +layoutLocalBinds lbinds@(L _ binds) = case binds of + -- HsValBinds (ValBindsIn lhsBindsLR []) -> + -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering + -- x@(HsValBinds (ValBindsIn{})) -> + -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x + HsValBinds (ValBindsIn bindlrs sigs) -> do + let + unordered + = [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered + docs <- docWrapNode lbinds $ join <$> ordered `forM` \case + BagBind b -> either id return <$> layoutBind b + BagSig s -> return <$> layoutSig s + return $ Just $ docs + x@(HsValBinds (ValBindsOut _binds _lsigs)) -> + -- i _think_ this case never occurs in non-processed ast + Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x + x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x + EmptyLocalBinds -> return $ Nothing + +-- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is +-- parSpacing stuff.B +layoutGrhs + :: LGRHS RdrName (LHsExpr RdrName) + -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName) +layoutGrhs lgrhs@(L _ (GRHS guards body)) = do + guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards + bodyDoc <- layoutExpr body + return (guardDocs, bodyDoc, body) + +layoutPatternBind + :: Maybe Text + -> BriDocNumbered + -> LMatch RdrName (LHsExpr RdrName) + -> ToBriDocM BriDocNumbered +layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do + patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + let isInfix = isInfixMatch match + patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of + (Just idStr, p1:pr) | isInfix -> docCols + ColPatternsFuncInfix + ( [appSep $ docForceSingleline p1, appSep $ docLit idStr] + ++ (spacifyDocs $ docForceSingleline <$> pr) + ) + (Just idStr, [] ) -> docLit idStr + (Just idStr, ps) -> + docCols ColPatternsFuncPrefix + $ appSep (docLit $ idStr) + : (spacifyDocs $ docForceSingleline <$> ps) + (Nothing, ps) -> + docCols ColPatterns + $ (List.intersperse docSeparator $ docForceSingleline <$> ps) + clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss + mWhereDocs <- layoutLocalBinds whereBinds + let alignmentToken = if null pats then Nothing else mIdStr + hasComments <- hasAnyCommentsBelow lmatch + layoutPatternBindFinal alignmentToken + binderDoc + (Just patDoc) + clauseDocs + mWhereDocs + hasComments + +layoutPatternBindFinal + :: Maybe Text + -> BriDocNumbered + -> Maybe BriDocNumbered + -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] + -> Maybe [BriDocNumbered] + -> Bool + -> ToBriDocM BriDocNumbered +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do + let patPartInline = case mPatDoc of + Nothing -> [] + Just patDoc -> [appSep $ docForceSingleline $ return patDoc] + patPartParWrap = case mPatDoc of + Nothing -> id + Just patDoc -> docPar (return patDoc) + whereIndent <- do + shouldSpecial <- mAsk + <&> _conf_layout + .> _lconfig_indentWhereSpecial + .> confUnpack + regularIndentAmount <- mAsk + <&> _conf_layout + .> _lconfig_indentAmount + .> confUnpack + pure $ if shouldSpecial + then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) + else BrIndentRegular + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just [w] -> fmap (pure . pure) $ docAlt + [ docEnsureIndent BrIndentRegular + $ docSeq + [ docLit $ Text.pack "where" + , docSeparator + , docForceSingleline $ return w + ] + , docEnsureIndent whereIndent $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ return w + ] + ] + Just ws -> fmap (pure . pure) $ docEnsureIndent whereIndent $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] + let singleLineGuardsDoc guards = appSep $ case guards of + [] -> docEmpty + [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] + gs -> docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + docAlt + $ -- one-line solution + [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return body + , wherePart + ] + ] + | not hasComments + , [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w + ] + _ -> [] + ] + ++ -- one-line solution + where in next line(s) + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [appSep $ return binderDoc, docForceParSpacing $ return body] + ] + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + , Data.Maybe.isJust mWhereDocs + ] + ++ -- two-line solution + where in next line(s) + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body + ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] + ++ -- pattern and exactly one clause in single line, body as par; + -- where in following lines + [ docLines + $ [ docCols + (ColBindingLine alignmentToken) + [ docSeq (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] + ] + ] + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] + ++ wherePartMultiLine + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] + ++ -- pattern and exactly one clause in single line, body in new line. + [ docLines + $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular + $ docNonBottomSpacing + $ (docAddBaseY BrIndentRegular $ return body) + ] + ++ wherePartMultiLine + | [(guards, body, _)] <- [clauseDocs] + , let guardPart = singleLineGuardsDoc guards + ] + ++ -- multiple clauses added in-paragraph, each in a single line + -- example: foo | bar = baz + -- | lll = asd + [ docLines + $ [ docSeq + [ appSep $ docForceSingleline $ return patDoc + , docSetBaseY + $ docLines + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ] + ++ wherePartMultiLine + | Just patDoc <- [mPatDoc] + ] + ++ -- multiple clauses, each in a separate, single line + [ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> do + let guardPart = singleLineGuardsDoc guardDocs + -- the docForceSingleline might seems superflous, but it + -- helps the alternative resolving impl. + docForceSingleline $ docCols + ColGuardedBody + [ guardPart + , docSeq + [ appSep $ return binderDoc + , docForceSingleline $ return bodyDoc + -- i am not sure if there is a benefit to using + -- docForceParSpacing additionally here: + -- , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + ] + ++ -- multiple clauses, each with the guard(s) in a single line, body + -- as a paragraph + [ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + <&> \(guardDocs, bodyDoc, _) -> + docSeq + $ ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docSeparator + , docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + ] + ++ -- multiple clauses, each with the guard(s) in a single line, body + -- in a new line as a paragraph + [ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [ docForceSingleline + $ docSeq [appSep $ docLit $ Text.pack "|", return g] + ] + gs -> + [ docForceSingleline + $ docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ] + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular + $ docForceParSpacing + $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + ] + ++ -- conservative approach: everything starts on the left. + [ docLines + $ [ docAddBaseY BrIndentRegular + $ patPartParWrap + $ docLines + $ map docSetBaseY + $ clauseDocs + >>= \(guardDocs, bodyDoc, _) -> + ( case guardDocs of + [] -> [] + [g] -> + [docSeq [appSep $ docLit $ Text.pack "|", return g]] + (g1:gr) -> + ( docSeq [appSep $ docLit $ Text.pack "|", return g1] + : ( gr + <&> \g -> + docSeq + [appSep $ docLit $ Text.pack ",", return g] + ) + ) + ) + ++ [ docCols + ColOpPrefix + [ appSep $ return binderDoc + , docAddBaseY BrIndentRegular $ return bodyDoc + ] + ] + ] + ++ wherePartMultiLine + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs new file mode 100644 index 0000000..a6ba345 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -0,0 +1,975 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.Layouters.Expr + ( layoutExpr + , litBriDoc + , overLitValBriDoc + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) ) +import HsSyn +import Name +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Type + + + +layoutExpr :: ToBriDoc HsExpr +layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of + HsVar vname -> do + docLit =<< lrdrNameToTextAnn vname + HsUnboundVar var -> case var of + OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname + TrueExprHole oname -> docLit $ Text.pack $ occNameString oname + HsRecFld{} -> do + -- TODO + briDocByExactInlineOnly "HsRecFld" lexpr + HsOverLabel{} -> do + -- TODO + briDocByExactInlineOnly "HsOverLabel{}" lexpr + HsIPVar{} -> do + -- TODO + briDocByExactInlineOnly "HsOverLabel{}" lexpr + HsOverLit (OverLit olit _ _ _) -> do + allocateNode $ overLitValBriDoc olit + HsLit lit -> do + allocateNode $ litBriDoc lit + HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do + patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p + bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body + let funcPatternPartLine = + docCols ColCasePattern + $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator])) + docAlt + [ -- single line + docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceSingleline bodyDoc + ] + -- double line + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docForceSingleline bodyDoc) + -- wrapped par spacing + , docSetParSpacing + $ docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine + , appSep $ docLit $ Text.pack "->" + , docWrapNode lgrhs $ docForceParSpacing bodyDoc + ] + -- conservative + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) + ] + HsLam{} -> + unknownNodeError "HsLam too complex" lexpr +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do +#else /* ghc-8.0 */ + HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do +#endif + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "\\case") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + HsApp exp1@(L _ HsApp{}) exp2 -> do + let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName]) + gather list = \case + (L _ (HsApp l r)) -> gather (r:list) l + x -> (x, list) + let (headE, paramEs) = gather [exp2] exp1 + headDoc <- docSharedWrapper layoutExpr headE + paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs + docAlt + [ -- foo x y + docCols ColApp + $ appSep (docForceSingleline headDoc) + : spacifyDocs (docForceSingleline <$> paramDocs) + , -- foo x + -- y + docSeq + [ appSep (docForceSingleline headDoc) + , docSetBaseY + $ docAddBaseY BrIndentRegular + $ docLines + $ (docForceSingleline <$> paramDocs) + ] + , -- foo + -- x + -- y + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docForceSingleline headDoc) + ( docNonBottomSpacing + $ docLines paramDocs + ) + , -- ( multi + -- line + -- function + -- ) + -- x + -- y + docAddBaseY BrIndentRegular + $ docPar + headDoc + ( docNonBottomSpacing + $ docLines paramDocs + ) + ] + HsApp exp1 exp2 -> do + -- TODO: if expDoc1 is some literal, we may want to create a docCols here. + expDoc1 <- docSharedWrapper layoutExpr exp1 + expDoc2 <- docSharedWrapper layoutExpr exp2 + docAlt + [ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2] + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docSeq + [ appSep $ docForceSingleline expDoc1 + , docForceParSpacing expDoc2 + ] + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docForceSingleline expDoc1) + expDoc2 + , docAddBaseY BrIndentRegular + $ docPar + expDoc1 + expDoc2 + ] +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsAppType exp1 (HsWC _ ty1) -> do +#else /* ghc-8.0 */ + HsAppType exp1 (HsWC _ _ ty1) -> do +#endif + t <- docSharedWrapper layoutType ty1 + e <- docSharedWrapper layoutExpr exp1 + docAlt + [ docSeq + [ docForceSingleline e + , docSeparator + , docLit $ Text.pack "@" + , docForceSingleline t + ] + , docPar + e + (docSeq [docLit $ Text.pack "@", t ]) + ] + HsAppTypeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsAppTypeOut{}" lexpr + OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do + let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)]) + gather opExprList = \case + (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1 + final -> (final, opExprList) + (leftOperand, appList) = gather [] expLeft + leftOperandDoc <- docSharedWrapper layoutExpr leftOperand + appListDocs <- appList `forM` \(x,y) -> [ (xD, yD) + | xD <- docSharedWrapper layoutExpr x + , yD <- docSharedWrapper layoutExpr y + ] + opLastDoc <- docSharedWrapper layoutExpr expOp + expLastDoc <- docSharedWrapper layoutExpr expRight + let allowPar = case (expOp, expRight) of + (L _ (HsVar (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ (L _ HsVar{}))) -> False + _ -> True + docAlt + [ docSeq + [ appSep $ docForceSingleline leftOperandDoc + , docSeq + $ (appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] + ) + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc + ] + -- this case rather leads to some unfortunate layouting than to anything + -- useful; disabling for now. (it interfers with cols stuff.) + -- , docSetBaseY + -- - $ docPar + -- leftOperandDoc + -- ( docLines + -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + -- ) + , docPar + leftOperandDoc + ( docLines + $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) + ] + OpApp expLeft expOp _ expRight -> do + expDocLeft <- docSharedWrapper layoutExpr expLeft + expDocOp <- docSharedWrapper layoutExpr expOp + expDocRight <- docSharedWrapper layoutExpr expRight + let allowPar = case (expOp, expRight) of + (L _ (HsVar (L _ (Unqual occname))), _) + | occNameString occname == "$" -> True + (_, L _ (HsApp _ (L _ HsVar{}))) -> False + _ -> True + docAltFilter + $ [ -- one-line + (,) True + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceSingleline expDocRight + ] + -- , -- line + freely indented block for right expression + -- docSeq + -- [ appSep $ docForceSingleline expDocLeft + -- , appSep $ docForceSingleline expDocOp + -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight + -- ] + , -- two-line + (,) True + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + ( docForceSingleline + $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] + ) + , -- one-line + par + (,) allowPar + $ docSeq + [ appSep $ docForceSingleline expDocLeft + , appSep $ docForceSingleline expDocOp + , docForceParSpacing expDocRight + ] + , -- more lines + (,) True + $ docAddBaseY BrIndentRegular + $ docPar + expDocLeft + (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) + ] + NegApp op _ -> do + opDoc <- docSharedWrapper layoutExpr op + docSeq $ [ docLit $ Text.pack "-" + , opDoc + ] + HsPar innerExp -> do + innerExpDoc <- docSharedWrapper layoutExpr innerExp + docAlt + [ docSeq + [ docLit $ Text.pack "(" + , docForceSingleline innerExpDoc + , docLit $ Text.pack ")" + ] + , docSetBaseY $ docLines + [ docCols ColOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) innerExpDoc + ] + , docLit $ Text.pack ")" + ] + ] + SectionL left op -> do -- TODO: add to testsuite + leftDoc <- docSharedWrapper layoutExpr left + opDoc <- docSharedWrapper layoutExpr op + docSeq [leftDoc, opDoc] + SectionR op right -> do -- TODO: add to testsuite + opDoc <- docSharedWrapper layoutExpr op + rightDoc <- docSharedWrapper layoutExpr right + docSeq [opDoc, rightDoc] + ExplicitTuple args boxity + | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do + argDocs <- docSharedWrapper layoutExpr `mapM` argExprs + hasComments <- hasAnyCommentsBelow lexpr + let (openLit, closeLit) = case boxity of + Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") + Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)") + case splitFirstLast argDocs of + FirstLastEmpty -> docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit + ] + FirstLastSingleton e -> docAlt + [ docCols ColTuple + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + , closeLit + ] + , docSetBaseY $ docLines + [ docSeq + [ openLit + , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e + ] + , closeLit + ] + ] + FirstLast e1 ems eN -> + docAltFilter + [ (,) (not hasComments) + $ docCols ColTuple + ( [docSeq [openLit, docForceSingleline e1]] + ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e]) + ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]] + ) + , (,) True + $ let + start = docCols ColTuples + [appSep $ openLit, e1] + linesM = ems <&> \d -> + docCols ColTuples [docCommaSep, d] + lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN] + end = closeLit + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ] + ExplicitTuple{} -> + unknownNodeError "ExplicitTuple|.." lexpr + HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do + cExpDoc <- docSharedWrapper layoutExpr cExp + binderDoc <- docLit $ Text.pack "->" + funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + docAlt + [ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docSeq + [ appSep $ docLit $ Text.pack "case" + , appSep $ docForceSingleline cExpDoc + , docLit $ Text.pack "of" + ]) + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + , docPar + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "case") cExpDoc + ) + ( docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "of") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) + ) + ] + HsIf _ ifExpr thenExpr elseExpr -> do + ifExprDoc <- docSharedWrapper layoutExpr ifExpr + thenExprDoc <- docSharedWrapper layoutExpr thenExpr + elseExprDoc <- docSharedWrapper layoutExpr elseExpr + hasComments <- hasAnyCommentsBelow lexpr + docAltFilter + [ -- if _ then _ else _ + (,) (not hasComments) + $ docSeq + [ appSep $ docLit $ Text.pack "if" + , appSep $ docForceSingleline ifExprDoc + , appSep $ docLit $ Text.pack "then" + , appSep $ docForceSingleline thenExprDoc + , appSep $ docLit $ Text.pack "else" + , docForceSingleline elseExprDoc + ] + , -- either + -- if expr + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if expr + -- then + -- stuff + -- else + -- stuff + -- note that this has par-spacing + (,) True + $ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY (BrIndentSpecial 3) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + , -- either + -- if multi + -- line + -- condition + -- then foo + -- bar + -- else foo + -- bar + -- or + -- if multi + -- line + -- condition + -- then + -- stuff + -- else + -- stuff + -- note that this does _not_ have par-spacing + (,) True + $ docAddBaseY BrIndentRegular + $ docPar + ( docAddBaseY (BrIndentSpecial 3) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ]) + (docLines + [ docAddBaseY BrIndentRegular + $ docNodeAnnKW lexpr (Just AnnThen) + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + ] + , docAddBaseY BrIndentRegular + $ docAlt + [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ]) + , (,) True + $ docSetBaseY + $ docLines + [ docAddBaseY (BrIndentSpecial 3) + $ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if" + , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc + ] + , docNodeAnnKW lexpr (Just AnnThen) + $ docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "then") thenExprDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "else") elseExprDoc + ] + ] + HsMultiIf _ cases -> do + clauseDocs <- cases `forM` layoutGrhs + binderDoc <- docLit $ Text.pack "->" + hasComments <- hasAnyCommentsBelow lexpr + docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "if") + (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) + HsLet binds exp1 -> do + expDoc1 <- docSharedWrapper layoutExpr exp1 + mBindDocs <- layoutLocalBinds binds + -- this `docSetIndentLevel` might seem out of place, but is here due to + -- ghc-exactprint's DP handling of "let" in particular. + -- Just pushing another indentation level is a straightforward approach + -- to making brittany idempotent, even though the result is non-optimal + -- if "let" is moved horizontally as part of the transformation, as the + -- comments before the first let item are moved horizontally with it. + docSetIndentLevel $ case mBindDocs of + Just [bindDoc] -> docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , appSep $ docForceSingleline $ return bindDoc + , appSep $ docLit $ Text.pack "in" + , docForceSingleline $ expDoc1 + ] + , docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ return bindDoc + ] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 + ] + ] + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (appSep $ docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) + , docAddBaseY BrIndentRegular + $ docPar + (appSep $ docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] + ] + Just bindDocs@(_:_) -> docAlt + [ docLines + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + , docSeq + [ appSep $ docLit $ Text.pack "in " + , docSetBaseY $ expDoc1 + ] + ] + , docLines + [ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + , docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "in") + (docSetBaseY $ expDoc1) + ] + ] + _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1] + -- docSeq [appSep $ docLit "let in", expDoc1] + HsDo DoExpr (L _ stmts) _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "do") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + HsDo MDoExpr (L _ stmts) _ -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docLit $ Text.pack "mdo") + (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs) + HsDo x (L _ stmts) _ | case x of { ListComp -> True + ; MonadComp -> True + ; _ -> False } -> do + stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts + hasComments <- hasAnyCommentsBelow lexpr + docAltFilter + [ (,) (not hasComments) + $ docSeq + [ docNodeAnnKW lexpr Nothing + $ appSep + $ docLit + $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) + $ appSep + $ docForceSingleline + $ List.last stmtDocs + , appSep $ docLit $ Text.pack "|" + , docSeq $ List.intersperse docCommaSep + $ fmap docForceSingleline $ List.init stmtDocs + , docLit $ Text.pack " ]" + ] + , (,) True + $ let + start = docCols ColListComp + [ docNodeAnnKW lexpr Nothing + $ appSep $ docLit $ Text.pack "[" + , docSetBaseY + $ docNodeAnnKW lexpr (Just AnnOpenS) + $ List.last stmtDocs + ] + (s1:sM) = List.init stmtDocs + line1 = docCols ColListComp + [appSep $ docLit $ Text.pack "|", s1] + lineM = sM <&> \d -> + docCols ColListComp [docCommaSep, d] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] + ] + HsDo{} -> do + -- TODO + unknownNodeError "HsDo{} no comp" lexpr + ExplicitList _ _ elems@(_:_) -> do + elemDocs <- elems `forM` docSharedWrapper layoutExpr + hasComments <- hasAnyCommentsBelow lexpr + case splitFirstLast elemDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]" + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "[" + , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "[" + , docSeparator + , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e + ] + , docLit $ Text.pack "]" + ] + ] + FirstLast e1 ems eN -> + docAltFilter + [ (,) (not hasComments) + $ docSeq + $ [docLit $ Text.pack "["] + ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])) + ++ [docLit $ Text.pack "]"] + , (,) True + $ let + start = docCols ColList + [appSep $ docLit $ Text.pack "[", e1] + linesM = ems <&> \d -> + docCols ColList [docCommaSep, d] + lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN] + end = docLit $ Text.pack "]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] + ] + ExplicitList _ _ [] -> + docLit $ Text.pack "[]" + ExplicitPArr{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitPArr{}" lexpr + RecordCon lname _ _ (HsRecFields [] Nothing) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{" + , docLit $ Text.pack "}" + ] + RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do + let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname + ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr fExpr + return $ (fieldl, lrdrNameToText lnameF, fExpDoc) + docAlt + [ docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing $ nameDoc) + (docNonBottomSpacing $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n + , case fd1e of + Just x -> docSeq + [ appSep $ docLit $ Text.pack "=" + , docWrapNodeRest fd1l $ docAddBaseY BrIndentRegular $ x + ] + Nothing -> docEmpty + ] + lineR = fdr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "," + , appSep $ docLit $ fText + , case fDoc of + Just x -> docWrapNode lfield $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN]) + -- TODO oneliner (?) + ] + RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do + let t = lrdrNameToText lname + docWrapNode lname $ docLit $ t <> Text.pack " {..}" + RecordCon{} -> + unknownNodeError "RecordCon with puns" lexpr + RecordUpd rExpr [] _ _ _ _ -> do + rExprDoc <- docSharedWrapper layoutExpr rExpr + docSeq [rExprDoc, docLit $ Text.pack "{}"] + RecordUpd rExpr fields@(_:_) _ _ _ _ -> do + rExprDoc <- docSharedWrapper layoutExpr rExpr + rFs@((rF1f, rF1n, rF1e):rFr) <- fields + `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do + rFExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutExpr rFExpr + return $ case ambName of + Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) + docAlt + -- singleline + [ docSeq + [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc + , appSep $ docLit $ Text.pack "{" + , appSep $ docSeq $ List.intersperse docCommaSep + $ rFs <&> \case + (lfield, fieldStr, Just fieldDoc) -> + docWrapNode lfield $ docSeq + [ appSep $ docLit fieldStr + , appSep $ docLit $ Text.pack "=" + , docForceSingleline fieldDoc + ] + (lfield, fieldStr, Nothing) -> + docWrapNode lfield $ docLit fieldStr + , docLit $ Text.pack "}" + ] + -- wild-indentation block + , docSeq + [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc + , docSetBaseY $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , case rF1e of + Just x -> docWrapNodeRest rF1f $ docSeq + [ appSep $ docLit $ Text.pack "=" + , docForceSingleline $ x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "," + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docForceSingleline x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN] + ] + -- strict indentation block + , docSetParSpacing + $ docAddBaseY BrIndentRegular + $ docPar + (docNodeAnnKW lexpr Nothing $ rExprDoc) + (docNonBottomSpacing $ docLines $ let + line1 = docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "{" + , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n + , docWrapNodeRest rF1f $ case rF1e of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular $ x + ] + Nothing -> docEmpty + ] + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + [ appSep $ docLit $ Text.pack "," + , appSep $ docLit $ fText + , case fDoc of + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular x + ] + Nothing -> docEmpty + ] + lineN = docSeq + [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty + , docLit $ Text.pack "}" + ] + in [line1] ++ lineR ++ [lineN]) + ] +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do +#else /* ghc-8.0 */ + ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do +#endif + expDoc <- docSharedWrapper layoutExpr exp1 + typDoc <- docSharedWrapper layoutType typ1 + docSeq + [ appSep expDoc + , appSep $ docLit $ Text.pack "::" + , typDoc + ] + ExprWithTySigOut{} -> do + -- TODO + briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr + ArithSeq _ Nothing info -> + case info of + From e1 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , docLit $ Text.pack "..]" + ] + FromThen e1 e2 -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , docLit $ Text.pack "..]" + ] + FromTo e1 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , appSep $ docForceSingleline e1Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + FromThenTo e1 e2 eN -> do + e1Doc <- docSharedWrapper layoutExpr e1 + e2Doc <- docSharedWrapper layoutExpr e2 + eNDoc <- docSharedWrapper layoutExpr eN + docSeq + [ docLit $ Text.pack "[" + , docForceSingleline e1Doc + , appSep $ docLit $ Text.pack "," + , appSep $ docForceSingleline e2Doc + , appSep $ docLit $ Text.pack ".." + , docForceSingleline eNDoc + , docLit $ Text.pack "]" + ] + ArithSeq{} -> + briDocByExactInlineOnly "ArithSeq" lexpr + PArrSeq{} -> do + -- TODO + briDocByExactInlineOnly "PArrSeq{}" lexpr + HsSCC{} -> do + -- TODO + briDocByExactInlineOnly "HsSCC{}" lexpr + HsCoreAnn{} -> do + -- TODO + briDocByExactInlineOnly "HsCoreAnn{}" lexpr + HsBracket{} -> do + -- TODO + briDocByExactInlineOnly "HsBracket{}" lexpr + HsRnBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsRnBracketOut{}" lexpr + HsTcBracketOut{} -> do + -- TODO + briDocByExactInlineOnly "HsTcBracketOut{}" lexpr + HsSpliceE{} -> do + -- TODO + briDocByExactInlineOnly "HsSpliceE{}" lexpr + HsProc{} -> do + -- TODO + briDocByExactInlineOnly "HsProc{}" lexpr + HsStatic{} -> do + -- TODO + briDocByExactInlineOnly "HsStatic{}" lexpr + HsArrApp{} -> do + -- TODO + briDocByExactInlineOnly "HsArrApp{}" lexpr + HsArrForm{} -> do + -- TODO + briDocByExactInlineOnly "HsArrForm{}" lexpr + HsTick{} -> do + -- TODO + briDocByExactInlineOnly "HsTick{}" lexpr + HsBinTick{} -> do + -- TODO + briDocByExactInlineOnly "HsBinTick{}" lexpr + HsTickPragma{} -> do + -- TODO + briDocByExactInlineOnly "HsTickPragma{}" lexpr + EWildPat{} -> do + docLit $ Text.pack "_" + EAsPat asName asExpr -> do + docSeq + [ docLit $ (lrdrNameToText asName) <> Text.pack "@" + , layoutExpr asExpr + ] + EViewPat{} -> do + -- TODO + briDocByExactInlineOnly "EViewPat{}" lexpr + ELazyPat{} -> do + -- TODO + briDocByExactInlineOnly "ELazyPat{}" lexpr + HsWrap{} -> do + -- TODO + briDocByExactInlineOnly "HsWrap{}" lexpr +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsConLikeOut{} -> do + -- TODO + briDocByExactInlineOnly "HsWrap{}" lexpr + ExplicitSum{} -> do + -- TODO + briDocByExactInlineOnly "ExplicitSum{}" lexpr +#endif + + +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +litBriDoc :: HsLit -> BriDocFInt +litBriDoc = \case + HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat (FL t _) _type -> BDFLit $ Text.pack t + HsFloatPrim (FL t _) -> BDFLit $ Text.pack t + HsDoublePrim (FL t _) -> BDFLit $ Text.pack t + _ -> error "litBriDoc: literal with no SourceText" + +overLitValBriDoc :: OverLitVal -> BriDocFInt +overLitValBriDoc = \case + HsIntegral (SourceText t) _ -> BDFLit $ Text.pack t + HsFractional (FL t _) -> BDFLit $ Text.pack t + HsIsString (SourceText t) _ -> BDFLit $ Text.pack t + _ -> error "overLitValBriDoc: literal with no SourceText" +#else +litBriDoc :: HsLit -> BriDocFInt +litBriDoc = \case + HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] + HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString + HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString + HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsInteger t _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i + HsRat (FL t _) _type -> BDFLit $ Text.pack t + HsFloatPrim (FL t _) -> BDFLit $ Text.pack t + HsDoublePrim (FL t _) -> BDFLit $ Text.pack t + +overLitValBriDoc :: OverLitVal -> BriDocFInt +overLitValBriDoc = \case + HsIntegral t _ -> BDFLit $ Text.pack t + HsFractional (FL t _) -> BDFLit $ Text.pack t + HsIsString t _ -> BDFLit $ Text.pack t +#endif diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot new file mode 100644 index 0000000..0d01034 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.Layouters.Expr + ( layoutExpr + , litBriDoc + , overLitValBriDoc + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import HsSyn +import Name + + + +layoutExpr :: ToBriDoc HsExpr + +-- layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) + +litBriDoc :: HsLit -> BriDocFInt + +overLitValBriDoc :: OverLitVal -> BriDocFInt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs new file mode 100644 index 0000000..b36fcaa --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.Layouters.Pattern + ( layoutPat + , colsWrapPat + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import RdrName ( RdrName(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import HsSyn +import Name +import BasicTypes + +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import Language.Haskell.Brittany.Internal.Layouters.Type + + + +layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered) +layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of + WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n + LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit + ParPat inner -> do + left <- docLit $ Text.pack "(" + right <- docLit $ Text.pack ")" + innerDocs <- colsWrapPat =<< layoutPat inner + return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right + -- return $ (left Seq.<| innerDocs) Seq.|> right + -- case Seq.viewl innerDocs of + -- Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur.. + -- x1 Seq.:< rest -> case Seq.viewr rest of + -- Seq.EmptyR -> + -- fmap return $ docSeq + -- [ docLit $ Text.pack "(" + -- , return x1 + -- , docLit $ Text.pack ")" + -- ] + -- middle Seq.:> xN -> do + -- x1' <- docSeq [docLit $ Text.pack "(", return x1] + -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] + -- return $ (x1' Seq.<| middle) Seq.|> xN' + ConPatIn lname (PrefixCon args) -> do + let nameDoc = lrdrNameToText lname + argDocs <- layoutPat `mapM` args + if null argDocs + then return <$> docLit nameDoc + else do + x1 <- appSep (docLit nameDoc) + xR <- fmap Seq.fromList + $ sequence + $ spacifyDocs + $ fmap colsWrapPat argDocs + return $ x1 Seq.<| xR + ConPatIn lname (InfixCon left right) -> do + let nameDoc = lrdrNameToText lname + leftDoc <- colsWrapPat =<< layoutPat left + rightDoc <- colsWrapPat =<< layoutPat right + middle <- docLit nameDoc + return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc + ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do + let t = lrdrNameToText lname + fmap Seq.singleton $ docLit $ t <> Text.pack "{}" + ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + let t = lrdrNameToText lname + fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do + fExpDoc <- if pun + then return Nothing + else Just <$> docSharedWrapper layoutPat fPat + return $ (lrdrNameToText lnameF, fExpDoc) + fmap Seq.singleton $ docSeq + [ appSep $ docLit t + , appSep $ docLit $ Text.pack "{" + , docSeq $ List.intersperse docCommaSep + $ fds <&> \case + (fieldName, Just fieldDoc) -> docSeq + [ appSep $ docLit $ fieldName + , appSep $ docLit $ Text.pack "=" + , fieldDoc >>= colsWrapPat + ] + (fieldName, Nothing) -> docLit fieldName + , docSeparator + , docLit $ Text.pack "}" + ] + ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do + let t = lrdrNameToText lname + fmap Seq.singleton $ docSeq + [ appSep $ docLit t + , docLit $ Text.pack "{..}" + ] + TuplePat args boxity _ -> do + case boxity of + Boxed -> wrapPatListy args "(" ")" + Unboxed -> wrapPatListy args "(#" "#)" + AsPat asName asPat -> do + wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do +#else /* ghc-8.0 */ + SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do +#endif + patDocs <- layoutPat pat1 + tyDoc <- docSharedWrapper layoutType ty1 + case Seq.viewr patDocs of + Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd" + xR Seq.:> xN -> do + xN' <- -- at the moment, we don't support splitting patterns into + -- multiple lines. but we cannot enforce pasting everything + -- into one line either, because the type signature will ignore + -- this if we overflow sufficiently. + -- In order to prevent syntactically invalid results in such + -- cases, we need the AddBaseY here. + -- This can all change when patterns get multiline support. + docAddBaseY BrIndentRegular $ docSeq + [ appSep $ return xN + , appSep $ docLit $ Text.pack "::" + , docForceSingleline $ tyDoc + ] + return $ xR Seq.|> xN' + ListPat elems _ _ -> + wrapPatListy elems "[" "]" + BangPat pat1 -> do + wrapPatPrepend pat1 (docLit $ Text.pack "!") + LazyPat pat1 -> do + wrapPatPrepend pat1 (docLit $ Text.pack "~") + NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do + litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit + negDoc <- docLit $ Text.pack "-" + pure $ case mNegative of + Just{} -> Seq.fromList [negDoc, litDoc] + Nothing -> Seq.singleton litDoc + +-- if MIN_VERSION_ghc(8,0,0) +-- VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n +-- else +-- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n +-- endif + _ -> fmap return $ briDocByExactInlineOnly "some unknown pattern" lpat + +colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered +colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList + +wrapPatPrepend + :: Located (Pat RdrName) + -> ToBriDocM BriDocNumbered + -> ToBriDocM (Seq BriDocNumbered) +wrapPatPrepend pat prepElem = do + patDocs <- layoutPat pat + case Seq.viewl patDocs of + Seq.EmptyL -> return $ Seq.empty + x1 Seq.:< xR -> do + x1' <- docSeq [prepElem, return x1] + return $ x1' Seq.<| xR + +wrapPatListy + :: [Located (Pat RdrName)] + -> String + -> String + -> ToBriDocM (Seq BriDocNumbered) +wrapPatListy elems start end = do + elemDocs <- Seq.fromList elems `forM` \e -> layoutPat e >>= colsWrapPat + sDoc <- docLit $ Text.pack start + eDoc <- docLit $ Text.pack end + case Seq.viewl elemDocs of + Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end + x1 Seq.:< rest -> do + rest' <- rest `forM` \bd -> docSeq + [ docLit $ Text.pack "," + , docSeparator + , return bd + ] + return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs new file mode 100644 index 0000000..692b467 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.Layouters.Stmt + ( layoutStmt + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import HsSyn +import Name +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.Decl +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr + + + +layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) +layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of + LastStmt body False _ -> do + layoutExpr body + BindStmt lPat expr _ _ _ -> do + patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat + expDoc <- docSharedWrapper layoutExpr expr + docAlt + [ docCols + ColBindStmt + [ appSep patDoc + , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] + ] + , docCols + ColBindStmt + [ appSep patDoc + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "<-") (expDoc) + ] + ] + LetStmt binds -> layoutLocalBinds binds >>= \case + Nothing -> docLit $ Text.pack "let" -- i just tested + -- it, and it is + -- indeed allowed. + -- heh. + Just [] -> docLit $ Text.pack "let" -- this probably never happens + Just [bindDoc] -> docAlt + [ docCols + ColDoLet + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ return bindDoc + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "let") + (docSetBaseAndIndent $ return bindDoc) + ] + Just bindDocs -> docAlt + [ docSeq + [ appSep $ docLit $ Text.pack "let" + , docSetBaseAndIndent $ docLines $ return <$> bindDocs + ] + , docAddBaseY BrIndentRegular $ docPar + (docLit $ Text.pack "let") + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + ] + BodyStmt expr _ _ _ -> do + expDoc <- docSharedWrapper layoutExpr expr + docAddBaseY BrIndentRegular $ expDoc + _ -> briDocByExactInlineOnly "some unknown statement" lstmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot new file mode 100644 index 0000000..0cb46be --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.Layouters.Stmt + ( layoutStmt + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import HsSyn +import Name +import qualified FastString +import BasicTypes + + + +layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs new file mode 100644 index 0000000..36d1633 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.Layouters.Type + ( layoutType + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics + +import RdrName ( RdrName(..) ) +import GHC ( runGhc, GenLocated(L), moduleNameString ) +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) +import HsSyn +import Name +import Outputable ( ftext, showSDocUnsafe ) +import BasicTypes + +import DataTreePrint + + + +layoutType :: ToBriDoc HsType +layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of + -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsTyVar _ name -> do +#else /* ghc-8.0 */ + HsTyVar name -> do +#endif + t <- lrdrNameToTextAnn name + docWrapNode name $ docLit t + HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do + typeDoc <- docSharedWrapper layoutType typ2 + tyVarDocs <- bndrs `forM` \case + (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + cntxtDocs <- cntxts `forM` docSharedWrapper layoutType + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + let + tyVarDocLineList = tyVarDocs >>= \case + (tname, Nothing) -> [docLit $ Text.pack " " <> tname] + (tname, Just doc) -> [ docLit $ Text.pack " (" + <> tname + <> Text.pack " :: " + , docForceSingleline $ doc + , docLit $ Text.pack ")" + ] + forallDoc = docAlt + [ let + open = docLit $ Text.pack "forall" + in docSeq ([open]++tyVarDocLineList) + , docPar + (docLit (Text.pack "forall")) + (docLines + $ tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ]) + ] + contextDoc = case cntxtDocs of + [x] -> x + _ -> docAlt + [ let + open = docLit $ Text.pack "(" + close = docLit $ Text.pack ")" + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) + , let + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs + ] + close = docLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) cntxtDoc + ] + in docPar open $ docLines $ list ++ [close] + ] + docAlt + -- :: forall a b c . (Foo a b c) => a b -> c + [ docSeq + [ if null bndrs + then docEmpty + else let + open = docLit $ Text.pack "forall" + close = docLit $ Text.pack " . " + in docSeq ([open]++tyVarDocLineList++[close]) + , docForceSingleline contextDoc + , docLit $ Text.pack " => " + , docForceSingleline typeDoc + ] + -- :: forall a b c + -- . (Foo a b c) + -- => a b + -- -> c + , docPar + forallDoc + ( docLines + [ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack " . " + , docAddBaseY (BrIndentSpecial 3) + $ contextDoc + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc + ] + ] + ) + ] + HsForAllTy bndrs typ2 -> do + typeDoc <- layoutType typ2 + tyVarDocs <- bndrs `forM` \case + (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- layoutType kind + return $ (lrdrNameToText lrdrName, Just $ return d) + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + let + tyVarDocLineList = tyVarDocs >>= \case + (tname, Nothing) -> [docLit $ Text.pack " " <> tname] + (tname, Just doc) -> [ docLit $ Text.pack " (" + <> tname + <> Text.pack " :: " + , docForceSingleline doc + , docLit $ Text.pack ")" + ] + docAlt + -- forall x . x + [ docSeq + [ if null bndrs + then docEmpty + else let + open = docLit $ Text.pack "forall" + close = docLit $ Text.pack " . " + in docSeq ([open]++tyVarDocLineList++[close]) + , docForceSingleline $ return $ typeDoc + ] + -- :: forall x + -- . x + , docPar + (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ". " + , maybeForceML $ return typeDoc + ] + ) + -- :: forall + -- (x :: *) + -- . x + , docPar + (docLit (Text.pack "forall")) + (docLines + $ (tyVarDocs <&> \case + (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname + (tname, Just doc) -> docEnsureIndent BrIndentRegular + $ docLines + [ docCols ColTyOpPrefix + [ docParenLSep + , docLit tname + ] + , docCols ColTyOpPrefix + [ docLit $ Text.pack ":: " + , doc + ] + , docLit $ Text.pack ")" + ] + ) + ++[ docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack ". " + , maybeForceML $ return typeDoc + ] + ] + ) + ] + (HsQualTy (L _ []) _) -> + briDocByExactInlineOnly "HsQualTy [] _" ltype + HsQualTy lcntxts@(L _ cntxts@(_:_)) typ1 -> do + typeDoc <- docSharedWrapper layoutType typ1 + cntxtDocs <- cntxts `forM` docSharedWrapper layoutType + let + contextDoc = docWrapNode lcntxts $ case cntxtDocs of + [x] -> x + _ -> docAlt + [ let + open = docLit $ Text.pack "(" + close = docLit $ Text.pack ")" + list = List.intersperse docCommaSep + $ docForceSingleline <$> cntxtDocs + in docSeq ([open]++list++[close]) + , let + open = docCols ColTyOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) + $ head cntxtDocs + ] + close = docLit $ Text.pack ")" + list = List.tail cntxtDocs <&> \cntxtDoc -> + docCols ColTyOpPrefix + [ docCommaSep + , docAddBaseY (BrIndentSpecial 2) + $ cntxtDoc + ] + in docPar open $ docLines $ list ++ [close] + ] + let maybeForceML = case typ1 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + docAlt + -- (Foo a b c) => a b -> c + [ docSeq + [ docForceSingleline contextDoc + , docLit $ Text.pack " => " + , docForceSingleline typeDoc + ] + -- (Foo a b c) + -- => a b + -- -> c + , docPar + (docForceSingleline contextDoc) + ( docCols ColTyOpPrefix + [ docLit $ Text.pack "=> " + , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc + ] + ) + ] + HsFunTy typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + let maybeForceML = case typ2 of + (L _ HsFunTy{}) -> docForceMultiline + _ -> id + hasComments <- hasAnyCommentsBelow ltype + docAlt $ + [ docSeq + [ appSep $ docForceSingleline typeDoc1 + , appSep $ docLit $ Text.pack "->" + , docForceSingleline typeDoc2 + ] + | not hasComments + ] ++ + [ docPar + (docNodeAnnKW ltype Nothing typeDoc1) + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" + , docAddBaseY (BrIndentSpecial 3) + $ maybeForceML typeDoc2 + ] + ) + ] + HsParTy typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack "(" + , docForceSingleline typeDoc1 + , docLit $ Text.pack ")" + ] + , docPar + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docParenLSep + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack ")") + ] + HsAppTy typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + docAlt + [ docSeq + [ docForceSingleline typeDoc1 + , docLit $ Text.pack " " + , docForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + (docEnsureIndent BrIndentRegular typeDoc2) + ] + HsAppsTy [] -> error "HsAppsTy []" + HsAppsTy [L _ (HsAppPrefix typ1)] -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc1 + HsAppsTy [_lname@(L _ (HsAppInfix name))] -> do + -- this redirection is somewhat hacky, but whatever. + -- TODO: a general problem when doing deep inspections on + -- the type (and this is not the only instance) + -- is that we potentially omit annotations on some of + -- the middle constructors. i have no idea under which + -- circumstances exactly important annotations (comments) + -- would be assigned to such constructors. + typeDoc1 <- -- docSharedWrapper layoutType $ (L l $ HsTyVar name) + lrdrNameToTextAnnTypeEqualityIsSpecial name + docLit typeDoc1 + HsAppsTy (L _ (HsAppPrefix typHead):typRestA) + | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t + _ -> Nothing) typRestA -> do + docHead <- docSharedWrapper layoutType typHead + docRest <- docSharedWrapper layoutType `mapM` typRest + docAlt + [ docSeq + $ docForceSingleline docHead : (docRest >>= \d -> + [ docLit $ Text.pack " ", docForceSingleline d ]) + , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) + ] + HsAppsTy (typHead:typRest) -> do + docHead <- docSharedWrapper layoutAppType typHead + docRest <- docSharedWrapper layoutAppType `mapM` typRest + docAlt + [ docSeq + $ docForceSingleline docHead : (docRest >>= \d -> + [ docLit $ Text.pack " ", docForceSingleline d ]) + , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) + ] + where + layoutAppType (L _ (HsAppPrefix t)) = layoutType t + layoutAppType (L _ (HsAppInfix t)) = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecial t + HsListTy typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack "[" + , docForceSingleline typeDoc1 + , docLit $ Text.pack "]" + ] + , docPar + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[ " + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack "]") + ] + HsPArrTy typ1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype $ docLit $ Text.pack "[:" + , docForceSingleline typeDoc1 + , docLit $ Text.pack ":]" + ] + , docPar + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype $ docLit $ Text.pack "[:" + , docAddBaseY (BrIndentSpecial 2) $ typeDoc1 + ]) + (docLit $ Text.pack ":]") + ] + HsTupleTy tupleSort typs -> case tupleSort of + HsUnboxedTuple -> unboxed + HsBoxedTuple -> simple + HsConstraintTuple -> simple + HsBoxedOrConstraintTuple -> simple + where + unboxed = if null typs then error "unboxed unit?" else unboxedL + simple = if null typs then unitL else simpleL + unitL = docLit $ Text.pack "()" + simpleL = do + docs <- docSharedWrapper layoutType `mapM` typs + docAlt + [ docSeq $ [docLit $ Text.pack "("] + ++ List.intersperse docCommaSep (docForceSingleline <$> docs) + ++ [docLit $ Text.pack ")"] + , let + start = docCols ColTyOpPrefix [docParenLSep, head docs] + lines = List.tail docs <&> \d -> + docCols ColTyOpPrefix [docCommaSep, d] + end = docLit $ Text.pack ")" + in docPar + (docAddBaseY (BrIndentSpecial 2) $ start) + (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + ] + unboxedL = do + docs <- docSharedWrapper layoutType `mapM` typs + docAlt + [ docSeq $ [docLit $ Text.pack "(#"] + ++ List.intersperse docCommaSep docs + ++ [docLit $ Text.pack "#)"] + , let + start = docCols ColTyOpPrefix [docLit $ Text.pack "(#", head docs] + lines = List.tail docs <&> \d -> + docCols ColTyOpPrefix [docCommaSep, d] + end = docLit $ Text.pack "#)" + in docPar + (docAddBaseY (BrIndentSpecial 2) start) + (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + ] + HsOpTy{} -> -- TODO + briDocByExactInlineOnly "HsOpTy{}" ltype + -- HsOpTy typ1 opName typ2 -> do + -- -- TODO: these need some proper fixing. precedences don't add up. + -- -- maybe the parser just returns some trivial right recursion + -- -- parse result for any type level operators. + -- -- need to check how things are handled on the expression level. + -- let opStr = lrdrNameToText opName + -- let opLen = Text.length opStr + -- layouter1@(Layouter desc1 _ _) <- layoutType typ1 + -- layouter2@(Layouter desc2 _ _) <- layoutType typ2 + -- let line = do -- Maybe + -- l1 <- _ldesc_line desc1 + -- l2 <- _ldesc_line desc2 + -- let len1 = _lColumns_min l1 + -- let len2 = _lColumns_min l2 + -- let len = 2 + opLen + len1 + len2 + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol1 <- descToBlockStart desc1 + -- (min2, max2) <- descToMinMax (1+opLen) desc2 + -- let (minR, maxR) = case descToBlockMinMax desc1 of + -- Nothing -> (min2, max2) + -- Just (min1, max1) -> (max min1 min2, max max1 max2) + -- return $ BlockDesc + -- { _bdesc_blockStart = rol1 + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Just (1+opLen) + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \params -> do + -- remaining <- getCurRemaining + -- let allowSameLine = _params_sepLines params /= SepLineTypeOp + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do + -- applyLayouterRestore layouter1 defaultParams + -- layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " " + -- applyLayouterRestore layouter2 defaultParams + -- _ -> do + -- let upIndent = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params + -- let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2 + -- layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams + -- layoutWriteNewline + -- layoutWriteAppend $ opStr <> Text.pack " " + -- layoutWriteEnsureBlockPlusN downIndent + -- applyLayouterRestore layouter2 defaultParams + -- { _params_sepLines = SepLineTypeOp + -- , _params_opIndent = Just downIndent + -- } + -- , _layouter_ast = ltype + -- } +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsIParamTy (L _ (HsIPName ipName)) typ1 -> do +#else /* ghc-8.0 */ + HsIParamTy (HsIPName ipName) typ1 -> do +#endif + typeDoc1 <- docSharedWrapper layoutType typ1 + docAlt + [ docSeq + [ docWrapNodeRest ltype + $ docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::") + , docForceSingleline typeDoc1 + ] + , docPar + ( docLit + $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) + ) + (docCols ColTyOpPrefix + [ docWrapNodeRest ltype + $ docLit $ Text.pack "::" + , docAddBaseY (BrIndentSpecial 2) typeDoc1 + ]) + ] + HsEqTy typ1 typ2 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + typeDoc2 <- docSharedWrapper layoutType typ2 + docAlt + [ docSeq + [ docForceSingleline typeDoc1 + , docWrapNodeRest ltype + $ docLit $ Text.pack " ~ " + , docForceSingleline typeDoc2 + ] + , docPar + typeDoc1 + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype + $ docLit $ Text.pack "~ " + , docAddBaseY (BrIndentSpecial 2) typeDoc2 + ]) + ] + -- TODO: test KindSig + HsKindSig typ1 kind1 -> do + typeDoc1 <- docSharedWrapper layoutType typ1 + kindDoc1 <- docSharedWrapper layoutType kind1 + docAlt + [ docSeq + [ docForceSingleline typeDoc1 + , docLit $ Text.pack " :: " + , docForceSingleline kindDoc1 + ] + , docPar + typeDoc1 + ( docCols ColTyOpPrefix + [ docWrapNodeRest ltype + $ docLit $ Text.pack ":: " + , docAddBaseY (BrIndentSpecial 3) kindDoc1 + ]) + ] + HsBangTy{} -> -- TODO + briDocByExactInlineOnly "HsBangTy{}" ltype + -- HsBangTy bang typ1 -> do + -- let bangStr = case bang of + -- HsSrcBang _ unpackness strictness -> + -- (++) + -- (case unpackness of + -- SrcUnpack -> "{-# UNPACK -#} " + -- SrcNoUnpack -> "{-# NOUNPACK -#} " + -- NoSrcUnpack -> "" + -- ) + -- (case strictness of + -- SrcLazy -> "~" + -- SrcStrict -> "!" + -- NoSrcStrict -> "" + -- ) + -- let bangLen = length bangStr + -- layouter@(Layouter desc _ _) <- layoutType typ1 + -- let line = do -- Maybe + -- l <- _ldesc_line desc + -- let len = bangLen + _lColumns_min l + -- return $ LayoutColumns + -- { _lColumns_key = ColumnKeyUnique + -- , _lColumns_lengths = [len] + -- , _lColumns_min = len + -- } + -- let block = do -- Maybe + -- rol <- descToBlockStart desc + -- (minR,maxR) <- descToBlockMinMax desc + -- return $ BlockDesc + -- { _bdesc_blockStart = rol + -- , _bdesc_min = minR + -- , _bdesc_max = maxR + -- , _bdesc_opIndentFloatUp = Nothing + -- } + -- return $ Layouter + -- { _layouter_desc = LayoutDesc + -- { _ldesc_line = line + -- , _ldesc_block = block + -- } + -- , _layouter_func = \_params -> do + -- remaining <- getCurRemaining + -- case line of + -- Just (LayoutColumns _ _ m) | m <= remaining -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- applyLayouterRestore layouter defaultParams + -- _ -> do + -- layoutWriteAppend $ Text.pack $ bangStr + -- layoutWritePostCommentsRestore ltype + -- applyLayouterRestore layouter defaultParams + -- , _layouter_ast = ltype + -- } + HsSpliceTy{} -> -- TODO + briDocByExactInlineOnly "HsSpliceTy{}" ltype + HsDocTy{} -> -- TODO + briDocByExactInlineOnly "HsDocTy{}" ltype + HsRecTy{} -> -- TODO + briDocByExactInlineOnly "HsRecTy{}" ltype +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsExplicitListTy _ _ typs -> do +#else /* ghc-8.0 */ + HsExplicitListTy _ typs -> do +#endif + typDocs <- docSharedWrapper layoutType `mapM` typs + docAlt + [ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse docCommaSep typDocs + ++ [docLit $ Text.pack "]"] + -- TODO + ] + HsExplicitTupleTy{} -> -- TODO + briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype + HsTyLit lit -> case lit of +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsNumTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" + HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext + HsStrTy NoSourceText _ -> + error "overLitValBriDoc: literal with no SourceText" +#else /* ghc-8.0 */ + HsNumTy srctext _ -> docLit $ Text.pack srctext + HsStrTy srctext _ -> docLit $ Text.pack srctext +#endif + HsCoreTy{} -> -- TODO + briDocByExactInlineOnly "HsCoreTy{}" ltype + HsWildCardTy _ -> + docLit $ Text.pack "_" +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsSumTy{} -> -- TODO + briDocByExactInlineOnly "HsSumTy{}" ltype +#endif diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs new file mode 100644 index 0000000..0ed9b6c --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -0,0 +1,378 @@ +module Language.Haskell.Brittany.Internal.Prelude (module E) +where + + + +import Data.Functor.Identity as E ( Identity(..) ) +import Control.Concurrent.Chan as E ( Chan ) +import Control.Concurrent.MVar as E ( MVar ) +import Data.Int as E ( Int ) +import Data.Word as E ( Word ) +import Prelude as E ( Integer + , Float + , Double + ) +import Control.Monad.ST as E ( ST ) +import Data.Bool as E ( Bool(..) ) +import Data.Char as E ( Char ) +import Data.Either as E ( Either(..) ) +import Data.IORef as E ( IORef ) +import Data.Maybe as E ( Maybe(..) ) +import Data.Semigroup as E ( Option(..) ) +import Data.Monoid as E ( Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + , Alt(..) + ) +import Data.Ord as E ( Ordering(..) + , Down(..) + ) +import Data.Ratio as E ( Ratio + , Rational + ) +import Data.String as E ( String ) +import Data.Void as E ( Void ) +import System.IO as E ( IO ) +import Data.Proxy as E ( Proxy(..) ) +import Data.Sequence as E ( Seq ) + +import Data.Map as E ( Map ) +import Data.Set as E ( Set ) + +import Data.Text as E ( Text ) + +import Prelude as E ( Char + , String + , Int + , Integer + , Float + , Double + , Bool (..) + , undefined + , Eq (..) + , Ord (..) + , Enum (..) + , Bounded (..) + , Maybe (..) + , Either (..) + , IO + , (<$>) + , (.) + , ($) + , ($!) + , Num (..) + , Integral (..) + , Fractional (..) + , Floating (..) + , RealFrac (..) + , RealFloat (..) + , fromIntegral + , error + , foldr + , foldl + , foldr1 + , id + , map + , subtract + , putStrLn + , putStr + , Show (..) + , print + , fst + , snd + , (++) + , not + , (&&) + , (||) + , curry + , uncurry + , Ordering (..) + , flip + , const + , seq + , reverse + , otherwise + , traverse + , realToFrac + , or + , and + , head + , any + , (^) + , Foldable + , Traversable + ) + +import Data.Function as E ( fix + ) + +import Data.Foldable as E ( foldl' + , foldr' + , fold + , asum + ) + +import Data.List as E ( partition + , null + , elem + , notElem + , minimum + , maximum + , length + , all + , take + , drop + , find + , sum + , zip + , zip3 + , zipWith + , repeat + , replicate + , iterate + , nub + , filter + , intersperse + , intercalate + , isSuffixOf + , isPrefixOf + , dropWhile + , takeWhile + , unzip + , break + , transpose + , sortBy + , mapAccumL + , mapAccumR + , uncons + ) + +import Data.List.NonEmpty as E ( NonEmpty(..) + , nonEmpty + ) + +import Data.Tuple as E ( swap + ) + +import Data.Char as E ( ord + , chr + ) + +import Data.Maybe as E ( fromMaybe + , maybe + , listToMaybe + , maybeToList + , catMaybes + ) + +import Data.Word as E ( Word32 + ) + +import Data.Ord as E ( comparing + , Down (..) + ) + +import Data.Either as E ( either + ) + +import Data.Ratio as E ( Ratio + , (%) + , numerator + , denominator + ) + +import Text.Read as E ( readMaybe + ) + +import Control.Monad as E ( Functor (..) + , Monad (..) + , MonadPlus (..) + , mapM + , mapM_ + , forM + , forM_ + , sequence + , sequence_ + , (=<<) + , (>=>) + , (<=<) + , forever + , void + , join + , replicateM + , replicateM_ + , guard + , when + , unless + , liftM + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , filterM + , (<$!>) + ) + +import Control.Applicative as E ( Applicative (..) + , Alternative (..) + ) + +import Foreign.Storable as E ( Storable ) +import GHC.Exts as E ( Constraint ) + +import Control.Concurrent as E ( threadDelay + , forkIO + , forkOS + ) + +import Control.Concurrent.MVar as E ( MVar + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , takeMVar + , swapMVar + ) + +import Control.Exception as E ( evaluate + , bracket + , assert + ) + +import Debug.Trace as E ( trace + , traceId + , traceShowId + , traceShow + , traceStack + , traceShowId + , traceIO + , traceM + , traceShowM + ) + +import Foreign.ForeignPtr as E ( ForeignPtr + ) + +import Data.Monoid as E ( (<>) + , mconcat + , Monoid (..) + ) + +import Data.Bifunctor as E ( bimap ) +import Data.Functor as E ( (<$), ($>) ) +import Data.Function as E ( (&) ) +import System.IO as E ( hFlush + , stdout + ) + +import Data.Typeable as E ( Typeable + ) + +import Control.Arrow as E ( first + , second + , (***) + , (&&&) + , (>>>) + , (<<<) + ) + +import Data.Functor.Identity as E ( Identity (..) + ) + +import Data.Proxy as E ( Proxy (..) + ) + +import Data.Version as E ( showVersion + ) + +import Data.List.Extra as E ( nubOrd + , stripSuffix + ) +import Control.Monad.Extra as E ( whenM + , unlessM + , ifM + , notM + , orM + , andM + , anyM + , allM + ) + +import Data.Tree as E ( Tree(..) + ) + +import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..) + -- , MultiRWSTNull + -- , MultiRWS + -- , + MonadMultiReader(..) + , MonadMultiWriter(..) + , MonadMultiState(..) + -- , runMultiRWST + -- , runMultiRWSTASW + -- , runMultiRWSTW + -- , runMultiRWSTAW + -- , runMultiRWSTSW + -- , runMultiRWSTNil + -- , runMultiRWSTNil_ + -- , withMultiReader + -- , withMultiReader_ + -- , withMultiReaders + -- , withMultiReaders_ + -- , withMultiWriter + -- , withMultiWriterAW + -- , withMultiWriterWA + -- , withMultiWriterW + -- , withMultiWriters + -- , withMultiWritersAW + -- , withMultiWritersWA + -- , withMultiWritersW + -- , withMultiState + -- , withMultiStateAS + -- , withMultiStateSA + -- , withMultiStateA + -- , withMultiStateS + -- , withMultiState_ + -- , withMultiStates + -- , withMultiStatesAS + -- , withMultiStatesSA + -- , withMultiStatesA + -- , withMultiStatesS + -- , withMultiStates_ + -- , inflateReader + -- , inflateMultiReader + -- , inflateWriter + -- , inflateMultiWriter + -- , inflateState + -- , inflateMultiState + -- , mapMultiRWST + -- , mGetRawR + -- , mGetRawW + -- , mGetRawS + -- , mPutRawR + -- , mPutRawW + -- , mPutRawS + ) + +import Control.Monad.Trans.MultiReader ( runMultiReaderTNil + , runMultiReaderTNil_ + , MultiReaderT (..) + , MultiReader + , MultiReaderTNull + ) + +import Data.Text as E ( Text ) + +import Control.Monad.IO.Class as E ( MonadIO (..) + ) + +import Control.Monad.Trans.Class as E ( lift + ) +import Control.Monad.Trans.Maybe as E ( MaybeT (..) + ) + +import Data.Data as E ( toConstr + ) + diff --git a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs similarity index 74% rename from source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs rename to src/Language/Haskell/Brittany/Internal/PreludeUtils.hs index 394a78d..d34690c 100644 --- a/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs @@ -1,16 +1,20 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +module Language.Haskell.Brittany.Internal.PreludeUtils +where -module Language.Haskell.Brittany.Internal.PreludeUtils where -import Control.Applicative -import Control.DeepSeq (NFData, force) -import Control.Exception.Base (evaluate) -import Control.Monad + +import Prelude import qualified Data.Strict.Maybe as Strict import Debug.Trace -import Prelude +import Control.Monad import System.IO +import Control.DeepSeq ( NFData, force ) +import Control.Exception.Base ( evaluate ) + +import Control.Applicative + instance Applicative Strict.Maybe where @@ -19,6 +23,7 @@ instance Applicative Strict.Maybe where _ <*> _ = Strict.Nothing instance Monad Strict.Maybe where + return = Strict.Just Strict.Nothing >>= _ = Strict.Nothing Strict.Just x >>= f = f x @@ -29,10 +34,11 @@ instance Alternative Strict.Maybe where traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) -traceFunctionWith name s1 s2 f x = trace traceStr y - where - y = f x - traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y +traceFunctionWith name s1 s2 f x = + trace traceStr y + where + y = f x + traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y (<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) = flip (<$!>) @@ -40,18 +46,15 @@ traceFunctionWith name s1 s2 f x = trace traceStr y putStrErrLn :: String -> IO () putStrErrLn s = hPutStrLn stderr s -putStrErr :: String -> IO () -putStrErr s = hPutStr stderr s - printErr :: Show a => a -> IO () printErr = putStrErrLn . show errorIf :: Bool -> a -> a errorIf False = id -errorIf True = error "errorIf" +errorIf True = error "errorIf" errorIfNote :: Maybe String -> a -> a -errorIfNote Nothing = id +errorIfNote Nothing = id errorIfNote (Just x) = error x (<&>) :: Functor f => f a -> (a -> b) -> f b diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs new file mode 100644 index 0000000..93c31c6 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -0,0 +1,822 @@ +#define INSERTTRACESALT 0 +#define INSERTTRACESALTVISIT 0 +#define INSERTTRACESGETSPACING 0 + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Internal.Transformations.Alt + ( transformAlts + ) +where + + + +#include "prelude.inc" + +import Data.HList.ContainsType + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Control.Monad.Memo as Memo + + + +data AltCurPos = AltCurPos + { _acp_line :: Int -- chars in the current line + , _acp_indent :: Int -- current indentation level + , _acp_indentPrep :: Int -- indentChange affecting the next Par + , _acp_forceMLFlag :: AltLineModeState + } + deriving (Show) + +data AltLineModeState + = AltLineModeStateNone + | AltLineModeStateForceML Bool -- true ~ decays on next wrap + | AltLineModeStateForceSL + | AltLineModeStateContradiction + -- i.e. ForceX False -> ForceX True -> None + deriving (Show) + +altLineModeRefresh :: AltLineModeState -> AltLineModeState +altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone +altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False +altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction + +altLineModeDecay :: AltLineModeState -> AltLineModeState +altLineModeDecay AltLineModeStateNone = AltLineModeStateNone +altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True +altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone +altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL +altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction + +mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos +mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of + (AltLineModeStateContradiction, _) -> acp + (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } + (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp + (AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> + acp { _acp_forceMLFlag = s } + _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } + + +-- removes any BDAlt's from the BriDoc +transformAlts + :: forall r w s + . ( Data.HList.ContainsType.ContainsType Config r + , Data.HList.ContainsType.ContainsType (Seq String) w + ) + => BriDocNumbered + -> MultiRWSS.MultiRWS r w s BriDoc +transformAlts briDoc = + MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) + $ Memo.startEvalMemoT + $ fmap unwrapBriDocNumbered + $ rec + $ briDoc + where + -- this function is exponential by nature and cannot be improved in any + -- way i can think of, and i've tried. (stupid StableNames.) + -- transWrap :: BriDoc -> BriDocNumbered + -- transWrap brDc = flip StateS.evalState (1::Int) + -- $ Memo.startEvalMemoT + -- $ go brDc + -- where + -- incGet = StateS.get >>= \i -> StateS.put (i+1) $> i + -- go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered + -- go = Memo.memo $ \bdX -> do + -- i <- lift $ incGet + -- fmap (\bd' -> (i,bd')) $ case bdX of + -- BDEmpty -> return $ BDFEmpty + -- BDLit t -> return $ BDFLit t + -- BDSeq list -> BDFSeq <$> go `mapM` list + -- BDCols sig list -> BDFCols sig <$> go `mapM` list + -- BDSeparator -> return $ BDFSeparator + -- BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd + -- BDSetBaseY bd -> BDFSetBaseY <$> go bd + -- BDSetIndentLevel bd -> BDFSetIndentLevel <$> go bd + -- BDPar ind line indented -> [ BDFPar ind line' indented' + -- | line' <- go line + -- , indented' <- go indented + -- ] + -- BDAlt alts -> BDFAlt <$> go `mapM` alts -- not that this will happen + -- BDForceMultiline bd -> BDFForceMultiline <$> go bd + -- BDForceSingleline bd -> BDFForceSingleline <$> go bd + -- BDForwardLineMode bd -> BDFForwardLineMode <$> go bd + -- BDExternal k ks c t -> return $ BDFExternal k ks c t + -- BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd + -- BDAnnotationPost annKey bd -> BDFAnnotationRest annKey <$> go bd + -- BDLines lines -> BDFLines <$> go `mapM` lines + -- BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd + -- BDProhibitMTEL bd -> BDFProhibitMTEL <$> go bd + + + + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered + rec bdX@(brDcId, brDc) = do +#if INSERTTRACESALTVISIT + do + acp :: AltCurPos <- mGet + tellDebugMess $ "transformAlts: visiting: " ++ case brDc of + BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp) + BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp) + _ -> show (toConstr brDc, acp) +#endif + let reWrap = (,) brDcId + -- debugAcp :: AltCurPos <- mGet + case brDc of + -- BDWrapAnnKey annKey bd -> do + -- acp <- mGet + -- mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + -- BDWrapAnnKey annKey <$> rec bd + BDFEmpty{} -> processSpacingSimple bdX $> bdX + BDFLit{} -> processSpacingSimple bdX $> bdX + BDFSeq list -> + reWrap . BDFSeq <$> list `forM` rec + BDFCols sig list -> + reWrap . BDFCols sig <$> list `forM` rec + BDFSeparator -> processSpacingSimple bdX $> bdX + BDFAddBaseY indent bd -> do + acp <- mGet + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r + BDFBaseYPushCur bd -> do + acp <- mGet + mSet $ acp { _acp_indent = _acp_line acp } + r <- rec bd + return $ reWrap $ BDFBaseYPushCur r + BDFBaseYPop bd -> do + acp <- mGet + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indentPrep acp } + return $ reWrap $ BDFBaseYPop r + BDFIndentLevelPushCur bd -> do + reWrap . BDFIndentLevelPushCur <$> rec bd + BDFIndentLevelPop bd -> do + reWrap . BDFIndentLevelPop <$> rec bd + BDFPar indent sameLine indented -> do + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + acp <- mGet + let ind = _acp_indent acp + _acp_indentPrep acp + indAdd + mSet $ acp + { _acp_indent = ind + , _acp_indentPrep = 0 + } + sameLine' <- rec sameLine + mModify $ \acp' -> acp' + { _acp_line = ind + , _acp_indent = ind + } + indented' <- rec indented + return $ reWrap $ BDFPar indent sameLine' indented' + BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a + -- possibility, but i will prefer a + -- fail-early approach; BDEmpty does not + -- make sense semantically for Alt[]. + BDFAlt alts -> do + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack + case altChooser of + AltChooserSimpleQuick -> do + rec $ head alts + AltChooserShallowBest -> do + spacings <- alts `forM` getSpacing + acp <- mGet + let lineCheck LineModeInvalid = False + lineCheck (LineModeValid (VerticalSpacing _ p _)) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lineCheck _ = error "ghc exhaustive check is insufficient" + lconf <- _conf_layout <$> mAsk +#if INSERTTRACESALT + tellDebugMess $ "considering options with " ++ show (length alts, acp) +#endif + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( hasSpace1 lconf acp vs && lineCheck vs, bd)) +#if INSERTTRACESALT + zip spacings options `forM_` \(vs, (_, bd)) -> + tellDebugMess $ " " ++ "spacing=" ++ show vs + ++ ",hasSpace1=" ++ show (hasSpace1 lconf acp vs) + ++ ",lineCheck=" ++ show (lineCheck vs) + ++ " " ++ show (toConstr bd) +#endif + id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) + $ rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> + [ -- traceShow ("choosing option " ++ show i) $ + x + | b + ]) + $ zip [1..] options + AltChooserBoundedSearch limit -> do + spacings <- alts `forM` getSpacings limit + acp <- mGet + let lineCheck (VerticalSpacing _ p _) = + case _acp_forceMLFlag acp of + AltLineModeStateNone -> True + AltLineModeStateForceSL{} -> p == VerticalSpacingParNone + AltLineModeStateForceML{} -> p /= VerticalSpacingParNone + AltLineModeStateContradiction -> False + lconf <- _conf_layout <$> mAsk +#if INSERTTRACESALT + tellDebugMess $ "considering options with " ++ show (length alts, acp) +#endif + let options = -- trace ("considering options:" ++ show (length alts, acp)) $ + (zip spacings alts + <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) + ( any (hasSpace2 lconf acp) vs + && any lineCheck vs, bd)) + let checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) +#if INSERTTRACESALT + zip spacings options `forM_` \(vs, (_, bd)) -> + tellDebugMess $ " " ++ "spacing=" ++ show vs + ++ ",hasSpace2=" ++ show (hasSpace2 lconf acp <$> vs) + ++ ",lineCheck=" ++ show (lineCheck <$> vs) + ++ " " ++ show (toConstr bd) + tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions) +#endif + id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x) + $ rec + $ fromMaybe (-- trace ("choosing last") $ + List.last alts) + $ Data.List.Extra.firstJust (fmap snd) checkedOptions + BDFForceMultiline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp (AltLineModeStateForceML False) + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForceSingleline bd -> do + acp <- mGet + x <- do + mSet $ mergeLineMode acp AltLineModeStateForceSL + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFForwardLineMode bd -> do + acp <- mGet + x <- do + mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } + rec bd + acp' <- mGet + mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } + return $ x + BDFExternal{} -> processSpacingSimple bdX $> bdX + BDFAnnotationPrior annKey bd -> do + acp <- mGet + mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } + bd' <- rec bd + return $ reWrap $ BDFAnnotationPrior annKey bd' + BDFAnnotationRest annKey bd -> + reWrap . BDFAnnotationRest annKey <$> rec bd + BDFAnnotationKW annKey kw bd -> + reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. + BDFLines (l:lr) -> do + ind <- _acp_indent <$> mGet + l' <- rec l + lr' <- lr `forM` \x -> do + mModify $ \acp -> acp + { _acp_line = ind + , _acp_indent = ind + } + rec x + return $ reWrap $ BDFLines (l':lr') + BDFEnsureIndent indent bd -> do + acp <- mGet + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack + let indAdd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> indAmount + BrIndentSpecial i -> i + mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid, + -- in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = _acp_line acp + indAdd + } + r <- rec bd + acp' <- mGet + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ case indent of + BrIndentNone -> r + BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r + BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r + BDFNonBottomSpacing bd -> rec bd + BDFSetParSpacing bd -> rec bd + BDFForceParSpacing bd -> rec bd + BDFDebug s bd -> do + acp :: AltCurPos <- mGet + tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp + reWrap . BDFDebug s <$> rec bd + processSpacingSimple :: (MonadMultiReader + Config m, + MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m () + processSpacingSimple bd = getSpacing bd >>= \case + LineModeInvalid -> error "processSpacingSimple inv" + LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do + acp <- mGet + mSet $ acp { _acp_line = _acp_line acp + i } + LineModeValid (VerticalSpacing _ _ _) -> error "processSpacingSimple par" + _ -> error "ghc exhaustive check is insufficient" + hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool + hasSpace1 _ _ LineModeInvalid = False + hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs + hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" + hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) + hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + +getSpacing + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => BriDocNumbered + -> m (LineModeValidity VerticalSpacing) +getSpacing !bridoc = rec bridoc + where + rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) + rec (brDcId, brDc) = do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + result <- case brDc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLit t -> + return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False + BDFSeq list -> + sumVs <$> rec `mapM` list + BDFCols _sig list -> sumVs <$> rec `mapM` list + BDFSeparator -> + return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = VerticalSpacingParSome 0 + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVs <- rec sameLine + mIndSp <- rec indented + return + $ [ VerticalSpacing lsp pspResult parFlagResult + | VerticalSpacing lsp mPsp _ <- mVs + , indSp <- mIndSp + , lineMax <- getMaxVS $ mIndSp + , let pspResult = case mPsp of + VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax + VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax + VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax + , let parFlagResult = mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ] + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + BDFAlt (alt:_) -> rec alt + BDFForceMultiline bd -> rec bd + BDFForceSingleline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> mVs + _ -> LineModeInvalid + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of + [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False + _ -> VerticalSpacing 999 VerticalSpacingParNone False + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFLines [] -> return + $ LineModeValid + $ VerticalSpacing 0 VerticalSpacingParNone False + BDFLines ls@(_:_) -> do + lSps@(mVs:_) <- rec `mapM` ls + return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False + | VerticalSpacing lsp _ _ <- mVs + , lineMax <- getMaxVS $ maxVs $ lSps + ] + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp pf) -> + VerticalSpacing (lsp + addInd) psp pf + BDFNonBottomSpacing bd -> do + mVs <- rec bd + return + $ mVs + <|> LineModeValid (VerticalSpacing 0 + (VerticalSpacingParAlways colMax) + False) + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r + return r +#if INSERTTRACESGETSPACING + tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result +#endif + return result + maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + maxVs = foldl' + (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing (max x1 y1) (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome j, VerticalSpacingParAlways i) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) False)) + (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing + sumVs sps = foldl' (liftM2 go) initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ x + y) + x3 + singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone + singleline _ = False + isPar (LineModeValid x) = _vs_parFlag x + isPar _ = False + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int + getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + +getSpacings + :: forall m + . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) + => Int + -> BriDocNumbered + -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] +getSpacings limit bridoc = preFilterLimit <$> rec bridoc + where + -- when we do `take K . filter someCondition` on a list of spacings, we + -- need to first (also) limit the size of the input list, otherwise a + -- _large_ input with a similarly _large_ prefix not passing our filtering + -- process could lead to exponential runtime behaviour. + -- TODO: 3 is arbitrary. + preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] + preFilterLimit = take (3*limit) + memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v + memoWithKey k v = Memo.memo (const v) k + rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] + rec (brDcId, brdc) = memoWithKey brDcId $ do + config <- mAsk + let colMax = config & _conf_layout & _lconfig_cols & confUnpack + let hasOkColCount (VerticalSpacing lsp psp _) = + lsp <= colMax && case psp of + VerticalSpacingParNone -> True + VerticalSpacingParSome i -> i <= colMax + VerticalSpacingParAlways{} -> True + let -- the standard function used to enforce a constant upper bound + -- on the number of elements returned for each node. Should be + -- applied whenever in a parent the combination of spacings from + -- its children might cause excess of the upper bound. + filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] + filterAndLimit = take limit + -- prune so we always consider a constant + -- amount of spacings per node of the BriDoc. + . filter hasOkColCount + -- throw out any spacings (i.e. children) that + -- already use more columns than available in + -- total. + . List.nub + -- In the end we want to know if there is at least + -- one valid spacing for any alternative. + -- If there are duplicates in the list, then these + -- will either all be valid (so having more than the + -- first is pointless) or all invalid (in which + -- case having any of them is pointless). + -- Nonetheless I think the order of spacings should + -- be preserved as it provides a deterministic + -- choice for which spacings to prune (which is + -- an argument against simply using a Set). + -- I have also considered `fmap head . group` which + -- seems to work similarly well for common cases + -- and which might behave even better when it comes + -- to determinism of the algorithm. But determinism + -- should not be overrated here either - in the end + -- this is about deterministic behaviour of the + -- pruning we do that potentially results in + -- non-optimal layouts, and we'd rather take optimal + -- layouts when we can than take non-optimal layouts + -- just to be consistent with other cases where + -- we'd choose non-optimal layouts. + . preFilterLimit + result <- case brdc of + -- BDWrapAnnKey _annKey bd -> rec bd + BDFEmpty -> + return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLit t -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFSeq list -> + fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list + BDFCols _sig list -> + fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list + BDFSeparator -> + return $ [VerticalSpacing 1 VerticalSpacingParNone False] + BDFAddBaseY indent bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of + BrIndentNone -> i + BrIndentRegular -> i + ( confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + ) + BrIndentSpecial j -> i + j + } + BDFBaseYPushCur bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs + -- We leave par as-is, even though it technically is not + -- accurate (in general). + -- the reason is that we really want to _keep_ it Just if it is + -- just so we properly communicate the is-multiline fact. + -- An alternative would be setting to (Just 0). + { _vs_sameLine = max (_vs_sameLine vs) + (case _vs_paragraph vs of + VerticalSpacingParNone -> 0 + VerticalSpacingParSome i -> i + VerticalSpacingParAlways i -> min colMax i) + , _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParSome i -> VerticalSpacingParSome i + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + } + BDFBaseYPop bd -> rec bd + BDFIndentLevelPushCur bd -> rec bd + BDFIndentLevelPop bd -> rec bd + BDFPar BrIndentNone sameLine indented -> do + mVss <- filterAndLimit <$> rec sameLine + indSps <- filterAndLimit <$> rec indented + let mVsIndSp = take limit + $ [ (x,y) + | x<-mVss + , y<-indSps + ] + return $ mVsIndSp <&> + \(VerticalSpacing lsp mPsp _, indSp) -> + VerticalSpacing + lsp + (case mPsp of + VerticalSpacingParSome psp -> + VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO + VerticalSpacingParNone -> spMakePar indSp + VerticalSpacingParAlways psp -> + VerticalSpacingParAlways $ max psp $ getMaxVS indSp) + ( mPsp == VerticalSpacingParNone + && _vs_paragraph indSp == VerticalSpacingParNone + && _vs_parFlag indSp + ) + + BDFPar{} -> error "BDPar with indent in getSpacing" + BDFAlt [] -> error "empty BDAlt" + -- BDAlt (alt:_) -> rec alt + BDFAlt alts -> do + r <- rec `mapM` alts + return $ filterAndLimit =<< r + BDFForceMultiline bd -> rec bd + BDFForceSingleline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs + BDFForwardLineMode bd -> rec bd + BDFExternal _ _ _ txt | [t] <- Text.lines txt -> + return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] + BDFExternal{} -> + return $ [] -- yes, we just assume that we cannot properly layout + -- this. + BDFAnnotationPrior _annKey bd -> rec bd + BDFAnnotationKW _annKey _kw bd -> rec bd + BDFAnnotationRest _annKey bd -> rec bd + BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] + BDFLines ls@(_:_) -> do + -- we simply assume that lines is only used "properly", i.e. in + -- such a way that the first line can be treated "as a part of the + -- paragraph". That most importantly means that Lines should never + -- be inserted anywhere but at the start of the line. A + -- counterexample would be anything like Seq[Lit "foo", Lines]. + lSpss <- fmap filterAndLimit <$> rec `mapM` ls + let worbled = fmap reverse + $ sequence + $ reverse + $ lSpss + summed = worbled <&> \lSps@(lSp1:_) -> + VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + return $ summed + -- lSpss@(mVs:_) <- rec `mapM` ls + -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only + -- -- consider the first alternative for the + -- -- line's spacings. + -- -- also i am not sure if always including + -- -- the first line length in the paragraph + -- -- length gives the desired results. + -- -- it is the safe path though, for now. + -- [] -> [] + -- (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) -> + -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps + BDFEnsureIndent indent bd -> do + mVs <- rec bd + let addInd = case indent of + BrIndentNone -> 0 + BrIndentRegular -> confUnpack + $ _lconfig_indentAmount + $ _conf_layout + $ config + BrIndentSpecial i -> i + return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> + VerticalSpacing (lsp + addInd) psp parFlag + BDFNonBottomSpacing bd -> do + mVs <- rec bd + return $ if null mVs + then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] + else mVs <&> \vs -> vs + { _vs_paragraph = case _vs_paragraph vs of + VerticalSpacingParNone -> VerticalSpacingParNone + VerticalSpacingParAlways i -> VerticalSpacingParAlways i + VerticalSpacingParSome i -> VerticalSpacingParAlways i + } + BDFSetParSpacing bd -> do + mVs <- rec bd + return $ mVs <&> \vs -> vs { _vs_parFlag = True } + BDFForceParSpacing bd -> do + mVs <- preFilterLimit <$> rec bd + return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] + BDFDebug s bd -> do + r <- rec bd + tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) + return r +#if INSERTTRACESGETSPACING + case brdc of + BDFAnnotationPrior{} -> return () + BDFAnnotationRest{} -> return () + _ -> mTell $ Seq.fromList ["getSpacings: visiting: " + ++ show (toConstr $ brdc) -- (briDocToDoc $ unwrapBriDocNumbered (0, brdc)) + , " -> " + ++ show (take 9 result) + ] +#endif + return result + maxVs :: [VerticalSpacing] -> VerticalSpacing + maxVs = foldl' + (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + VerticalSpacing + (max x1 y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ max i j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + VerticalSpacingParSome $ max x y) + False) + (VerticalSpacing 0 VerticalSpacingParNone False) + sumVs :: [VerticalSpacing] -> VerticalSpacing + sumVs sps = foldl' go initial sps + where + go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing + (x1 + y1) + (case (x2, y2) of + (x, VerticalSpacingParNone) -> x + (VerticalSpacingParNone, x) -> x + (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + VerticalSpacingParAlways $ i+j + (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) + x3 + singleline x = _vs_paragraph x == VerticalSpacingParNone + isPar x = _vs_parFlag x + parFlag = case sps of + [] -> True + _ -> all singleline (List.init sps) && isPar (List.last sps) + initial = VerticalSpacing 0 VerticalSpacingParNone parFlag + getMaxVS :: VerticalSpacing -> Int + getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of + VerticalSpacingParSome i -> i + VerticalSpacingParNone -> 0 + VerticalSpacingParAlways i -> i + spMakePar :: VerticalSpacing -> VerticalSpacingPar + spMakePar (VerticalSpacing x1 x2 _) = case x2 of + VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i + VerticalSpacingParNone -> VerticalSpacingParSome $ x1 + VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs new file mode 100644 index 0000000..071028a --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -0,0 +1,135 @@ +module Language.Haskell.Brittany.Internal.Transformations.Columns + ( transformSimplifyColumns + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + + +transformSimplifyColumns :: BriDoc -> BriDoc +transformSimplifyColumns = Uniplate.rewrite $ \case + -- BDWrapAnnKey annKey bd -> + -- BDWrapAnnKey annKey $ transformSimplify bd + BDEmpty -> Nothing + BDLit{} -> Nothing + BDSeq list | any (\case BDSeq{} -> True + BDEmpty{} -> True + _ -> False) list -> Just $ BDSeq $ + filter isNotEmpty list >>= \case + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) -> + Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) + BDLines lines | any (\case BDLines{} -> True + BDEmpty{} -> True + _ -> False) lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines l -> l + x -> [x] + -- prior floating in + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + -- post floating in + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + -- ensureIndent float-in + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- matching col special transformation + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDCols sig1 cols1@(_:_) + | BDLines lines@(_:_:_) <- List.last cols1 + , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] + , BDCols sig2 cols2 + ] + BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines [col1, col2]) + BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) + | sig1==sig2 -> + Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) + BDPar ind (BDLines lines1) col2@(BDCols sig2 _) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) + BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) + | BDCols sig1 _ <- List.last lines1 + , sig1==sig2 -> + Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) + -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) + -- | sig1==sig2 -> + -- Just $ BDPar + -- ind1 + -- (BDLines [BDCols sig1 cols1, BDCols sig]) + BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 (List.init cols ++ [line]) + , BDCols sig2 cols2 + ] + BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols + , BDCols sig2 cols2 <- List.last lines + , sig1==sig2 -> + Just $ BDLines + [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] + , BDCols sig2 cols2 + ] + BDLines [x] -> Just $ x + BDLines [] -> Just $ BDEmpty + BDSeq{} -> Nothing + BDCols{} -> Nothing + BDSeparator -> Nothing + BDAddBaseY{} -> Nothing + BDBaseYPushCur{} -> Nothing + BDBaseYPop{} -> Nothing + BDIndentLevelPushCur{} -> Nothing + BDIndentLevelPop{} -> Nothing + BDPar{} -> Nothing + BDAlt{} -> Nothing + BDForceMultiline{} -> Nothing + BDForceSingleline{} -> Nothing + BDForwardLineMode{} -> Nothing + BDExternal{} -> Nothing + BDLines{} -> Nothing + BDAnnotationPrior{} -> Nothing + BDAnnotationKW{} -> Nothing + BDAnnotationRest{} -> Nothing + BDEnsureIndent{} -> Nothing + BDSetParSpacing{} -> Nothing + BDForceParSpacing{} -> Nothing + BDDebug{} -> Nothing + BDNonBottomSpacing x -> Just x diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs new file mode 100644 index 0000000..e36a545 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -0,0 +1,192 @@ +module Language.Haskell.Brittany.Internal.Transformations.Floating + ( transformSimplifyFloating + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate + + + +-- note that this is not total, and cannot be with that exact signature. +mergeIndents :: BrIndent -> BrIndent -> BrIndent +mergeIndents BrIndentNone x = x +mergeIndents x BrIndentNone = x +mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) +mergeIndents _ _ = error "mergeIndents" + + +transformSimplifyFloating :: BriDoc -> BriDoc +transformSimplifyFloating = stepBO .> stepFull + -- note that semantically, stepFull is completely sufficient. + -- but the bottom-up switch-to-top-down-on-match transformation has much + -- better complexity. + -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence + -- the push/pop cases would need to be copied over + where + descendPrior = transformDownMay $ \case + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) + BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x + BDAnnotationPrior annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationPrior annKey1 x + _ -> Nothing + descendRest = transformDownMay $ \case + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + BDAnnotationRest annKey1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x + BDAnnotationRest annKey1 (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationRest annKey1 x + _ -> Nothing + descendKW = transformDownMay $ \case + -- post floating in + BDAnnotationKW annKey1 kw (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented + BDAnnotationKW annKey1 kw (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] + BDAnnotationKW annKey1 kw (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] + BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x + BDAnnotationKW annKey1 kw (BDDebug s x) -> + Just $ BDDebug s $ BDAnnotationKW annKey1 kw x + _ -> Nothing + descendBYPush = transformDownMay $ \case + BDBaseYPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) + BDBaseYPushCur (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPushCur x) + _ -> Nothing + descendBYPop = transformDownMay $ \case + BDBaseYPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) + BDBaseYPop (BDDebug s x) -> + Just $ BDDebug s (BDBaseYPop x) + _ -> Nothing + descendILPush = transformDownMay $ \case + BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) + BDIndentLevelPushCur (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPushCur x) + _ -> Nothing + descendILPop = transformDownMay $ \case + BDIndentLevelPop (BDCols sig cols@(_:_)) -> + Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) + BDIndentLevelPop (BDDebug s x) -> + Just $ BDDebug s (BDIndentLevelPop x) + _ -> Nothing + descendAddB = transformDownMay $ \case + -- AddIndent floats into Lines. + BDAddBaseY BrIndentNone x -> + Just x + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> + Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationRest annKey1 x) -> + Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) + BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> + Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + BDAddBaseY ind (BDDebug s x) -> + Just $ BDDebug s (BDAddBaseY ind x) + _ -> Nothing + stepBO :: BriDoc -> BriDoc + stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + transformUp f + where + f = \case + x@BDAnnotationPrior{} -> descendPrior x + x@BDAnnotationKW{} -> descendKW x + x@BDAnnotationRest{} -> descendRest x + x@BDAddBaseY{} -> descendAddB x + x@BDBaseYPushCur{} -> descendBYPush x + x@BDBaseYPop{} -> descendBYPop x + x@BDIndentLevelPushCur{} -> descendILPush x + x@BDIndentLevelPop{} -> descendILPop x + x -> x + stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ + Uniplate.rewrite $ \case + -- AddIndent floats into Lines. + BDAddBaseY BrIndentNone x -> + Just $ x + BDAddBaseY indent (BDLines lines) -> + Just $ BDLines $ BDAddBaseY indent <$> lines + -- AddIndent floats into last column + BDAddBaseY indent (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] + BDAddBaseY ind (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] + -- merge AddIndent and Par + BDAddBaseY ind1 (BDPar ind2 line indented) -> + Just $ BDPar (mergeIndents ind1 ind2) line indented + BDAddBaseY _ lit@BDLit{} -> + Just $ lit + BDAddBaseY ind (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDBaseYPop x) -> + Just $ BDBaseYPop (BDAddBaseY ind x) + -- prior floating in + BDAnnotationPrior annKey1 (BDPar ind line indented) -> + Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented + BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> + Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDLines (l:lr)) -> + Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) + BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> + Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) + -- EnsureIndent float-in + -- BDEnsureIndent indent (BDCols sig (col:colr)) -> + -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) + -- not sure if the following rule is necessary; tests currently are + -- unaffected. + -- BDEnsureIndent indent (BDLines lines) -> + -- Just $ BDLines $ BDEnsureIndent indent <$> lines + -- post floating in + BDAnnotationRest annKey1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDAnnotationRest annKey1 indented + BDAnnotationRest annKey1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] + BDAnnotationRest annKey1 (BDCols sig cols) -> + Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs similarity index 71% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs rename to src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs index 613c5f0..b3d7709 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -1,12 +1,17 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +module Language.Haskell.Brittany.Internal.Transformations.Indent + ( transformSimplifyIndent + ) +where -module Language.Haskell.Brittany.Internal.Transformations.Indent where + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified GHC.OldList as List -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types @@ -27,17 +32,15 @@ transformSimplifyIndent = Uniplate.rewrite $ \case -- [ BDAddBaseY ind x -- , BDEnsureIndent ind indented -- ] - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> + Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDLines l -> l - x -> [x] + x -> [x] BDLines [l] -> Just l BDAddBaseY i (BDAnnotationPrior k x) -> Just $ BDAnnotationPrior k (BDAddBaseY i x) @@ -51,4 +54,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY _ lit@BDLit{} -> Just lit - _ -> Nothing + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs similarity index 52% rename from source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs rename to src/Language/Haskell/Brittany/Internal/Transformations/Par.hs index 6fe374a..e048584 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -1,11 +1,17 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} +module Language.Haskell.Brittany.Internal.Transformations.Par + ( transformSimplifyPar + ) +where -module Language.Haskell.Brittany.Internal.Transformations.Par where -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal.Utils + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate @@ -21,28 +27,25 @@ transformSimplifyPar = transformUp $ \case BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) - BDLines lines - | any - (\case - BDLines{} -> True - BDEmpty{} -> True - _ -> False - ) - lines - -> case go lines of - [] -> BDEmpty - [x] -> x - xs -> BDLines xs + BDLines lines | any ( \case + BDLines{} -> True + BDEmpty{} -> True + _ -> False + ) + lines -> case go lines of + [] -> BDEmpty + [x] -> x + xs -> BDLines xs where go = (=<<) $ \case BDLines l -> go l - BDEmpty -> [] - x -> [x] - BDLines [] -> BDEmpty - BDLines [x] -> x + BDEmpty -> [] + x -> [x] + BDLines [] -> BDEmpty + BDLines [x] -> x -- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- BDPar BrIndentNone line indented -> -- Just $ BDLines [line, indented] BDEnsureIndent BrIndentNone x -> x - x -> x + x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs similarity index 65% rename from source/library/Language/Haskell/Brittany/Internal/Types.hs rename to src/Language/Haskell/Brittany/Internal/Types.hs index 6a2c8af..557f9b3 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -1,41 +1,35 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} -module Language.Haskell.Brittany.Internal.Types where +module Language.Haskell.Brittany.Internal.Types +where + + + +#include "prelude.inc" -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Data.Data -import Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Kind as Kind -import qualified Data.Strict.Maybe as Strict -import qualified Data.Text.Lazy.Builder as Text.Builder -import GHC (AnnKeywordId, GenLocated, Located, SrcSpan) -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import Language.Haskell.GHC.ExactPrint (AnnKey) -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Types (Anns) -import qualified Safe + +import qualified Data.Text.Lazy.Builder as Text.Builder + +import RdrName ( RdrName(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId ) + +import Language.Haskell.GHC.ExactPrint ( AnnKey, Comment ) +import Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey ) + +import Language.Haskell.Brittany.Internal.Config.Types + +import Data.Generics.Uniplate.Direct as Uniplate -data PerItemConfig = PerItemConfig - { _icd_perBinding :: Map String (CConfig Maybe) - , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) - } - deriving Data.Data.Data type PPM = MultiRWSS.MultiRWS - '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] + '[Map ExactPrint.AnnKey ExactPrint.Anns, Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] @@ -44,8 +38,6 @@ type PPMLocal = MultiRWSS.MultiRWS '[Text.Builder.Builder, [BrittanyError], Seq String] '[] -newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) - data LayoutState = LayoutState { _lstate_baseYs :: [Int] -- ^ stack of number of current indentation columns @@ -82,17 +74,6 @@ data LayoutState = LayoutState -- -- captures if the layouter currently is in a new line, i.e. if the -- -- current line only contains (indentation) spaces. -- this is mostly superseeded by curYOrAddNewline, iirc. - , _lstate_commentNewlines :: Int -- number of newlines inserted due to - -- move-to-DP at a start of a comment. - -- Necessary because some keyword DPs - -- are relative to the last non-comment - -- entity (for some reason). - -- This is not very strictly reset to 0, - -- so we might in some cases get "artifacts" - -- from previous document elements. - -- But the worst effect at the moment would - -- be that we introduce less newlines on - -- moveToKWDP, which seems harmless enough. } lstate_baseY :: LayoutState -> Int @@ -111,7 +92,6 @@ instance Show LayoutState where ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) - ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a @@ -139,12 +119,9 @@ data BrittanyError -- ^ parsing failed | ErrorUnusedComment String -- ^ internal error: some comment went missing - | ErrorMacroConfig String String - -- ^ in-source config string parsing error; first argument is the parser - -- output and second the corresponding, ill-formed input. | LayoutWarning String -- ^ some warning - | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast) + | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast -- ^ internal error: pretty-printing is not implemented for type of node -- in the syntax-tree | ErrorOutputCheck @@ -194,16 +171,13 @@ data ColSig -- expected to have exactly two columns | ColBindStmt | ColDoLet -- the non-indented variant - | ColRec | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? - | ColRecDecl | ColListComp | ColList - | ColApp Text + | ColApp | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? - | ColImport -- TODO deriving (Eq, Ord, Data.Data.Data, Show) @@ -211,21 +185,18 @@ data ColSig data BrIndent = BrIndentNone | BrIndentRegular | BrIndentSpecial Int - deriving (Eq, Ord, Data.Data.Data, Show) + deriving (Eq, Ord, Typeable, Data.Data.Data, Show) -type ToBriDocM = MultiRWSS.MultiRWS - '[Config, Anns] -- reader - '[[BrittanyError], Seq String] -- writer - '[NodeAllocIndex] -- state +type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex] -type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered -type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered -type ToBriDocC sym c = Located sym -> ToBriDocM c +type ToBriDoc (sym :: * -> *) = Located (sym RdrName) -> ToBriDocM BriDocNumbered +type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered +type ToBriDocC sym c = Located sym -> ToBriDocM c data DocMultiLine = MultiLineNo | MultiLinePossible - deriving (Eq) + deriving (Eq, Typeable) -- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot -- of transformations on `BriDocF Identity`s and it is really annoying to @@ -258,12 +229,9 @@ data BriDoc -- to be printed via exactprint Bool -- should print extra comment ? Text - | BDPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -271,7 +239,7 @@ data BriDoc -- after the alt transformation. | BDForceMultiline BriDoc | BDForceSingleline BriDoc - | BDNonBottomSpacing Bool BriDoc + | BDNonBottomSpacing BriDoc | BDSetParSpacing BriDoc | BDForceParSpacing BriDoc -- pseudo-deprecated @@ -306,17 +274,14 @@ data BriDocF f -- to be printed via exactprint Bool -- should print extra comment ? Text - | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line - -- (contrast to BDLit) | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) - | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing Bool (f (BriDocF f)) + | BDFNonBottomSpacing (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f)) | BDFDebug String (f (BriDocF f)) @@ -328,37 +293,31 @@ type BriDocFInt = BriDocF ((,) Int) type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list ) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts ) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - uniplate (BDAnnotationPrior annKey bd) = - plate BDAnnotationPrior |- annKey |* bd - uniplate (BDAnnotationKW annKey kw bd) = - plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = - plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw b bd) = - plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines ) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd - uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd + uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd + uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd + uniplate (BDLines lines) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd + uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int @@ -379,20 +338,19 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen BDFForwardLineMode bd -> BDForwardLineMode $ rec bd BDFExternal k ks c t -> BDExternal k ks c t - BDFPlain t -> BDPlain t BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where rec = unwrapBriDocNumbered + where + rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False @@ -401,33 +359,31 @@ isNotEmpty _ = True -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list + BDSeparator -> () + BDAddBaseY _ind bd -> briDocSeqSpine bd + BDBaseYPushCur bd -> briDocSeqSpine bd + BDBaseYPop bd -> briDocSeqSpine bd + BDIndentLevelPushCur bd -> briDocSeqSpine bd + BDIndentLevelPop bd -> briDocSeqSpine bd BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented - BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDPlain{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd - BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines - BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing _ bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd - BDDebug _s bd -> briDocSeqSpine bd + BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines + BDEnsureIndent _ind bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd @@ -435,7 +391,7 @@ briDocForceSpine bd = briDocSeqSpine bd `seq` bd data VerticalSpacingPar = VerticalSpacingParNone -- no indented lines - | VerticalSpacingParSome Int -- indented lines, requiring this much + | VerticalSpacingParSome Int -- indented lines, requiring this much -- vertical space at most | VerticalSpacingParAlways Int -- indented lines, requiring this much -- vertical space at most, but should diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs similarity index 70% rename from source/library/Language/Haskell/Brittany/Internal/Utils.hs rename to src/Language/Haskell/Brittany/Internal/Utils.hs index b62028f..b0896b8 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -1,34 +1,61 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.Brittany.Internal.Utils where +module Language.Haskell.Brittany.Internal.Utils + ( parDoc + , parDocW + , fromMaybeIdentity + , fromOptionIdentity + , traceIfDumpConf + , mModify + , customLayouterF + , astToDoc + , briDocToDoc + -- , displayBriDocSimpleTree + , annsDoc + , Max (..) + , tellDebugMess + , tellDebugMessShow + , briDocToDocWithAnns + , breakEither + , spanMaybe + , transformUp + , transformDownMay + , FirstLastView(..) + , splitFirstLast + , lines' + ) +where -import qualified Data.ByteString as B -import qualified Data.Coerce -import Data.Data -import Data.Generics.Aliases -import qualified Data.Generics.Uniplate.Direct as Uniplate -import qualified Data.Semigroup as Semigroup -import qualified Data.Sequence as Seq -import DataTreePrint -import qualified GHC.Data.FastString as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Hs.Extension as HsExtension -import qualified GHC.OldList as List -import GHC.Types.Name.Occurrence as OccName (occNameString) -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Utils.Outputable as GHC -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Prelude -import Language.Haskell.Brittany.Internal.PreludeUtils -import Language.Haskell.Brittany.Internal.Types + + +#include "prelude.inc" + +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils + +import Data.Data +import Data.Generics.Schemes +import Data.Generics.Aliases + import qualified Text.PrettyPrint as PP +import Text.PrettyPrint ( ($+$), (<+>) ) + +import qualified Outputable as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified SrcLoc as GHC +import OccName ( occNameString ) +import qualified Data.ByteString as B + +import DataTreePrint + +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Types + +import qualified Data.Generics.Uniplate.Direct as Uniplate @@ -42,45 +69,40 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords showSDoc_ :: GHC.SDoc -> String showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags -showOutputable :: (GHC.Outputable a) => a -> String -showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags +showGhc :: (GHC.Outputable a) => a -> String +showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y -fromOptionIdentity :: Identity a -> Maybe a -> Identity a +fromOptionIdentity :: Identity a -> Option a -> Identity a fromOptionIdentity x y = - Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y + Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y -- maximum monoid over N+0 -- or more than N, because Num is allowed. newtype Max a = Max { getMax :: a } deriving (Eq, Ord, Show, Bounded, Num) -instance (Num a, Ord a) => Semigroup (Max a) where - (<>) = Data.Coerce.coerce (max :: a -> a -> a) - instance (Num a, Ord a) => Monoid (Max a) where - mempty = Max 0 - mappend = (<>) + mempty = Max 0 + mappend = Data.Coerce.coerce (max :: a -> a -> a) newtype ShowIsId = ShowIsId String deriving Data -instance Show ShowIsId where - show (ShowIsId x) = x +instance Show ShowIsId where show (ShowIsId x) = x -data A x = A ShowIsId x - deriving Data +data A x = A ShowIsId x deriving Data customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF anns layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -88,22 +110,18 @@ customLayouterF anns layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter - srcSpan ss = - simpleLayouter + srcSpan ss = simpleLayouter -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" - $ "{" - ++ showOutputable ss - ++ "}" + $ "{" ++ showGhc ss ++ "}" located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a where @@ -115,12 +133,12 @@ customLayouterF anns layoutF = customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF layoutF = DataToLayouter - $ f - `extQ` showIsId - `extQ` fastString - `extQ` bytestring - `extQ` occName - `extQ` srcSpan + $ f + `extQ` showIsId + `extQ` fastString + `extQ` bytestring + `extQ` occName + `extQ` srcSpan `ext2Q` located where DataToLayouter f = defaultLayouterF layoutF @@ -128,15 +146,14 @@ customLayouterNoAnnsF layoutF = simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) showIsId :: ShowIsId -> NodeLayouter showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case - Left True -> PP.parens $ PP.text s - Left False -> PP.text s - Right _ -> PP.text s + Left True -> PP.parens $ PP.text s + Left False -> PP.text s + Right _ -> PP.text s fastString = - simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString + simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter - occName = - simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString + occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter @@ -200,11 +217,12 @@ traceIfDumpConf s accessor val = do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () -tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m () +tellDebugMess :: MonadMultiWriter + (Seq String) m => String -> m () tellDebugMess s = mTell $ Seq.singleton s -tellDebugMessShow - :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () +tellDebugMessShow :: forall a m . (MonadMultiWriter + (Seq String) m, Show a) => a -> m () tellDebugMessShow = tellDebugMess . show -- i should really put that into multistate.. @@ -219,28 +237,29 @@ briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDAnnotationPrior _ x -> x - BDAnnotationKW _ _ x -> x - BDAnnotationRest _ x -> x - x -> x + BDAnnotationKW _ _ x -> x + BDAnnotationRest _ x -> x + x -> x briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns = astToDoc annsDoc :: ExactPrint.Types.Anns -> PP.Doc -annsDoc = - printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) +annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) -breakEither _ [] = ([], []) -breakEither fn (a1 : aR) = case fn a1 of - Left b -> (b : bs, cs) +breakEither _ [] = ([], []) +breakEither fn (a1:aR) = case fn a1 of + Left b -> (b : bs, cs) Right c -> (bs, c : cs) - where (bs, cs) = breakEither fn aR + where + (bs, cs) = breakEither fn aR spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) -spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) - where (ys, xs) = spanMaybe f xR -spanMaybe _ xs = ([], xs) +spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) + where + (ys, xs) = spanMaybe f xR +spanMaybe _ xs = ([], xs) data FirstLastView a = FirstLastEmpty @@ -250,7 +269,7 @@ data FirstLastView a splitFirstLast :: [a] -> FirstLastView a splitFirstLast [] = FirstLastEmpty splitFirstLast [x] = FirstLastSingleton x -splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr) +splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) -- TODO: move to uniplate upstream? -- aka `transform` @@ -269,7 +288,4 @@ lines' :: String -> [String] lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] - (s1, (_ : r)) -> s1 : lines' r - -absurdExt :: HsExtension.NoExtCon -> a -absurdExt = HsExtension.noExtCon + (s1, (_:r)) -> s1 : lines' r diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc new file mode 100644 index 0000000..805b941 --- /dev/null +++ b/srcinc/prelude.inc @@ -0,0 +1,147 @@ +import qualified Data.ByteString +-- import qualified Data.ByteString.Builder +-- import qualified Data.ByteString.Builder.Extra +-- import qualified Data.ByteString.Builder.Prim +import qualified Data.ByteString.Char8 +-- import qualified Data.ByteString.Lazy.Builder +-- import qualified Data.ByteString.Lazy.Builder.ASCII +-- import qualified Data.ByteString.Lazy.Builder.Extras +-- import qualified Data.ByteString.Lazy.Char8 +-- import qualified Data.ByteString.Lazy +-- import qualified Data.ByteString.Short +-- import qualified Data.ByteString.Unsafe + +-- import qualified Data.Graph +-- import qualified Data.IntMap +-- import qualified Data.IntMap.Lazy +-- import qualified Data.IntMap.Strict +-- import qualified Data.IntSet +-- import qualified Data.Map +-- import qualified Data.Map.Lazy +-- import qualified Data.Map.Strict +-- import qualified Data.Sequence +-- import qualified Data.Set +-- import qualified Data.Tree + +import qualified System.Directory + +-- import qualified Control.Concurrent.Extra +-- import qualified Control.Exception.Extra +-- import qualified Control.Monad.Extra +-- import qualified Data.Either.Extra +-- import qualified Data.IORef.Extra +import qualified Data.List.Extra +-- import qualified Data.Tuple.Extra +-- import qualified Data.Version.Extra +-- import qualified Numeric.Extra +-- import qualified System.Directory.Extra +-- import qualified System.Environment.Extra +-- import qualified System.IO.Extra +-- import qualified System.Info.Extra +-- import qualified System.Process.Extra +-- import qualified System.Time.Extra + +-- import qualified Control.Monad.Trans.MultiRWS.Lazy +-- import qualified Control.Monad.Trans.MultiRWS.Strict +-- import qualified Control.Monad.Trans.MultiReader +-- import qualified Control.Monad.Trans.MultiReader.Class +-- import qualified Control.Monad.Trans.MultiReader.Lazy +-- import qualified Control.Monad.Trans.MultiReader.Strict +-- import qualified Control.Monad.Trans.MultiState +-- import qualified Control.Monad.Trans.MultiState.Class +-- import qualified Control.Monad.Trans.MultiState.Lazy +-- import qualified Control.Monad.Trans.MultiState.Strict +-- import qualified Control.Monad.Trans.MultiWriter +-- import qualified Control.Monad.Trans.MultiWriter.Class +-- import qualified Control.Monad.Trans.MultiWriter.Lazy +-- import qualified Control.Monad.Trans.MultiWriter.Strict + +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL + +import qualified Text.PrettyPrint + +import qualified Text.PrettyPrint.Annotated +import qualified Text.PrettyPrint.Annotated.HughesPJ +import qualified Text.PrettyPrint.Annotated.HughesPJClass + +-- import qualified Text.PrettyPrint.HughesPJ +-- import qualified Text.PrettyPrint.HughesPJClass + +-- import qualified Data.Text +-- import qualified Data.Text.Array +-- import qualified Data.Text.Encoding +-- import qualified Data.Text.Encoding.Error +-- import qualified Data.Text.Foreign +-- import qualified Data.Text.IO +-- import qualified Data.Text.Lazy +-- import qualified Data.Text.Lazy.Builder + +-- import qualified Data.Bifunctor +-- import qualified Data.Bits +-- import qualified Data.Bool +-- import qualified Data.Char +import qualified Data.Coerce +-- import qualified Data.Complex +import qualified Data.Data +-- import qualified Data.Dynamic +import qualified Data.Either +-- import qualified Data.Eq +-- import qualified Data.Fixed +import qualified Data.Foldable +-- import qualified Data.Function +-- import qualified Data.Functor +-- import qualified Data.Functor.Identity +-- import qualified Data.IORef +-- import qualified Data.Int +-- import qualified Data.Ix +-- import qualified Data.List +import qualified Data.Maybe +-- import qualified Data.Monoid +-- import qualified Data.Ord +-- import qualified Data.Proxy +-- import qualified Debug.Trace +-- import qualified Numeric +-- import qualified Numeric.Natural +import qualified System.IO +-- import qualified Unsafe.Coerce + +import qualified Data.Bool as Bool +import qualified Data.Foldable as Foldable +import qualified GHC.OldList as List + +import qualified Data.Semigroup as Semigroup + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteStringL + +import qualified Data.IntMap.Lazy as IntMapL +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set + +import qualified Control.Monad.RWS.Class as RWS.Class +import qualified Control.Monad.Reader.Class as Reader.Class +import qualified Control.Monad.State.Class as State.Class +import qualified Control.Monad.Writer.Class as Writer.Class + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.IO as Text.IO +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL.Encoding +import qualified Data.Text.Lazy.IO as TextL.IO + +import qualified Control.Monad.Trans.State as State +import qualified Control.Monad.Trans.State.Lazy as StateL +import qualified Control.Monad.Trans.State.Strict as StateS +import qualified Control.Monad.Trans.Either as EitherT + +import qualified Data.Strict.Maybe as Strict + +import qualified Safe as Safe + + +import Language.Haskell.Brittany.Internal.Prelude +import Language.Haskell.Brittany.Internal.PreludeUtils diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..4bbcc0c --- /dev/null +++ b/stack.yaml @@ -0,0 +1,11 @@ +resolver: lts-9.0 + +extra-deps: + - monad-memo-0.4.1 + - czipwith-1.0.0.0 + - butcher-1.1.0.2 + - data-tree-print-0.1.0.0 + - deque-0.2 + +packages: + - .