diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,156 +0,0 @@ -# This Travis job script has been generated by a script via -# -# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project' -# -# For more information, see https://github.com/hvr/multi-ghc-travis -# -language: c -sudo: false - -git: - submodules: false # whether to recursively clone submodules - -notifications: - irc: - channels: - - "irc.freenode.org#haskell-lens" - skip_join: true - template: - - "\x0313trifecta\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" - -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - -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 - - - rm -rfv $HOME/.cabal/packages/head.hackage - -matrix: - include: - - compiler: "ghc-8.6.1" - env: GHCHEAD=true - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}} - - compiler: "ghc-8.4.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}} - - compiler: "ghc-8.2.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.0.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}} - - compiler: "ghc-7.10.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}} - - compiler: "ghc-7.8.4" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}} - - compiler: "ghc-7.6.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}} - - compiler: "ghc-7.4.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}} - - compiler: "ghc-head" - env: GHCHEAD=true - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} - - allow_failures: - - compiler: "ghc-head" - - compiler: "ghc-8.6.1" - -before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - ROOTDIR=$(pwd) - - mkdir -p $HOME/.local/bin - - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER - -install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - UNCONSTRAINED=${UNCONSTRAINED-true} - - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false} - - GHCHEAD=${GHCHEAD-false} - - travis_retry cabal update -v - - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - - rm -fv cabal.project cabal.project.local - # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage - - | - if $GHCHEAD; then - sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config - for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done - - echo 'repository head.hackage' >> ${HOME}/.cabal/config - echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config - echo ' secure: True' >> ${HOME}/.cabal/config - echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config - echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config - echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config - echo ' key-threshold: 3' >> ${HOME}/.cabal.config - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - cabal new-update head.hackage -v - fi - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - "printf 'packages: \".\" \"./examples\"\\n' > cabal.project" - - touch cabal.project.local - - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then - (cd "." && autoreconf -i); - fi - - if [ -f "./examples/configure.ac" ]; then - (cd "./examples" && autoreconf -i); - fi - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - - rm -rf .ghc.environment.* "."/dist "./examples"/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. -script: - # test that source-distributions can be generated - - (cd "." && cabal sdist) - - (cd "./examples" && cabal sdist) - - mv "."/dist/trifecta-*.tar.gz "./examples"/dist/trifecta-examples-*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - "printf 'packages: trifecta-*/*.cabal trifecta-examples-*/*.cabal\\n' > cabal.project" - - touch cabal.project.local - - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - - cat cabal.project || true - - cat cabal.project.local || true - - # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi - - # cabal check - - (cd trifecta-* && cabal check) - - (cd trifecta-examples-* && cabal check) - - # haddock - - rm -rf ./dist-newstyle - - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi - -# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"] -# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,33 @@ +2.1.4 [2024.02.07] +------------------ +* Allow building with `ansi-terminal-1.1.*`. + +2.1.3 [2023.08.07] +------------------ +* Allow building with `deepseq-1.5.*`. + +2.1.2 [2021.11.16] +------------------ +* Add an `Eq Strand` instance. +* Allow building with `hashable-1.4.*`. +* Drop support for pre-8.0 versions of GHC. + +2.1.1 [2021.02.18] +------------------ +* Allow building with `lens-5.*`. +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests. + +2.1 [2019.09.06] +---------------- +* Support building with `base-4.13` (GHC 8.8). +* Dropped support for GHC < 7.8. +* Print line numbers in the gutter. +* Switched to `prettyprinter` from `ansi-wl-pprint` +* Switched from `INLINE` to `INLINABLE` to help fight compile time woes + while still allowing aggressive inline when you want it. +* Removed `Text.Trifecta.Util.Array`. `primitive` now exists. + 2 [2018.07.03] -------------- * `stepParser` no longer takes a `ByteString`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2010-2017 Edward Kmett +Copyright 2010-2019 Edward Kmett Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ trifecta ======== -[![Hackage](https://img.shields.io/hackage/v/trifecta.svg)](https://hackage.haskell.org/package/trifecta) [![Build Status](https://secure.travis-ci.org/ekmett/trifecta.png?branch=master)](http://travis-ci.org/ekmett/trifecta) +[![Hackage](https://img.shields.io/hackage/v/trifecta.svg)](https://hackage.haskell.org/package/trifecta) [![Build Status](https://github.com/ekmett/trifecta/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/trifecta/actions?query=workflow%3AHaskell-CI) This package provides a parser that focuses on nice diagnostics. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,34 +0,0 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -import Warning () -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain - -#endif - -\end{code} diff --git a/Warning.hs b/Warning.hs deleted file mode 100644 --- a/Warning.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Warning - {-# WARNING ["You are configuring this package without cabal-doctest installed.", - "The doctests test-suite will not work as a result.", - "To fix this, install cabal-doctest before configuring."] #-} - () where diff --git a/examples/RFC2616-malformed.txt b/examples/RFC2616-malformed.txt new file mode 100644 --- /dev/null +++ b/examples/RFC2616-malformed.txt @@ -0,0 +1,9 @@ +GET http://slashdot.org/ HTTP/1.1 +foo: this is a test + +GET http://slashdot.org/ HTTP/1.0 +foo: of the emergency broadcast system + +GET http://slashdot.org/ HTTP/1.0 +foo but I mangled the header + diff --git a/examples/rfc2616/RFC2616.hs b/examples/rfc2616/RFC2616.hs --- a/examples/rfc2616/RFC2616.hs +++ b/examples/rfc2616/RFC2616.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# language BangPatterns #-} module RFC2616 where diff --git a/examples/trifecta-examples.cabal b/examples/trifecta-examples.cabal --- a/examples/trifecta-examples.cabal +++ b/examples/trifecta-examples.cabal @@ -8,21 +8,24 @@ stability: experimental homepage: http://github.com/ekmett/trifecta/ bug-reports: http://github.com/ekmett/trifecta/issues -copyright: Copyright (C) 2010-2017 Edward A. Kmett +copyright: Copyright (C) 2010-2019 Edward A. Kmett synopsis: A modern parser combinator library with convenient diagnostics description: A modern parser combinator library with slicing and Clang-style colored diagnostics cabal-version: >= 1.10 build-type: Simple -tested-with: GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +tested-with: GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.3 - , GHC == 8.6.1 -extra-source-files: RFC2616.txt + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.4 + , GHC == 9.8.1 +extra-source-files: RFC2616.txt RFC2616-malformed.txt source-repository head type: git @@ -33,7 +36,7 @@ ghc-options: -Wall exposed-modules: RFC2616 hs-source-dirs: rfc2616 - build-depends: base >= 4.3 && <5, + build-depends: base >= 4.7 && <5, bytestring, charset, parsers, diff --git a/images/example.png b/images/example.png new file mode 100644 Binary files /dev/null and b/images/example.png differ diff --git a/src/Text/Trifecta.hs b/src/Text/Trifecta.hs --- a/src/Text/Trifecta.hs +++ b/src/Text/Trifecta.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett diff --git a/src/Text/Trifecta/Combinators.hs b/src/Text/Trifecta/Combinators.hs --- a/src/Text/Trifecta/Combinators.hs +++ b/src/Text/Trifecta/Combinators.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language CPP #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language MultiParamTypeClasses #-} +{-# language UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Combinators --- Copyright : (c) Edward Kmett 2011-2015 +-- Copyright : (c) Edward Kmett 2011-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com @@ -64,141 +64,141 @@ -- placing a 'Caret' there. rend :: m Rendering rend = rendered <$> position <*> line - {-# INLINE rend #-} + {-# inlinable rend #-} -- | Grab the remainder of the current line restOfLine :: m ByteString restOfLine = Strict.drop . fromIntegral . columnByte <$> position <*> line - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Lazy.StateT s m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (Lazy.StateT m) = Lazy.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Strict.StateT s m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (Strict.StateT m) = Strict.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (ReaderT e m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (ReaderT m) = ReaderT $ slicedWith f . m - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.WriterT w m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (Strict.WriterT m) = Strict.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.WriterT w m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (Lazy.WriterT m) = Lazy.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.RWST r w s m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (Lazy.RWST m) = Lazy.RWST $ \r s -> slicedWith (\(a,s',w) b -> (f a b, s',w)) $ m r s - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.RWST r w s m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (Strict.RWST m) = Strict.RWST $ \r s -> slicedWith (\(a,s',w) b -> (f a b, s',w)) $ m r s - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (IdentityT m) where line = lift line - {-# INLINE line #-} + {-# inlinable line #-} position = lift position - {-# INLINE position #-} + {-# inlinable position #-} slicedWith f (IdentityT m) = IdentityT $ slicedWith f m - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} rend = lift rend - {-# INLINE rend #-} + {-# inlinable rend #-} restOfLine = lift restOfLine - {-# INLINE restOfLine #-} + {-# inlinable restOfLine #-} -- | Run a parser, grabbing all of the text between its start and end points and -- discarding the original result sliced :: DeltaParsing m => m a -> m ByteString sliced = slicedWith (\_ bs -> bs) -{-# INLINE sliced #-} +{-# inlinable sliced #-} -- | Grab a 'Caret' pointing to the current location. careting :: DeltaParsing m => m Caret careting = Caret <$> position <*> line -{-# INLINE careting #-} +{-# inlinable careting #-} -- | Parse a 'Careted' result. Pointing the 'Caret' to where you start. careted :: DeltaParsing m => m a -> m (Careted a) careted p = (\m l a -> a :^ Caret m l) <$> position <*> line <*> p -{-# INLINE careted #-} +{-# inlinable careted #-} -- | Discard the result of a parse, returning a 'Span' from where we start to -- where it ended parsing. spanning :: DeltaParsing m => m a -> m Span spanning p = (\s l e -> Span s e l) <$> position <*> line <*> (p *> position) -{-# INLINE spanning #-} +{-# inlinable spanning #-} -- | Parse a 'Spanned' result. The 'Span' starts here and runs to the last -- position parsed. spanned :: DeltaParsing m => m a -> m (Spanned a) spanned p = (\s l a e -> a :~ Span s e l) <$> position <*> line <*> p <*> position -{-# INLINE spanned #-} +{-# inlinable spanned #-} -- | Grab a fixit. fixiting :: DeltaParsing m => m Strict.ByteString -> m Fixit fixiting p = (\(r :~ s) -> Fixit s r) <$> spanned p -{-# INLINE fixiting #-} +{-# inlinable fixiting #-} -- | This class is a refinement of 'DeltaParsing' that adds the ability to mark -- your position in the input and return there for further parsing later. @@ -211,48 +211,48 @@ instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Lazy.StateT s m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Strict.StateT s m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (ReaderT e m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.WriterT w m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.WriterT w m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.RWST r w s m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.RWST r w s m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (IdentityT m) where mark = lift mark - {-# INLINE mark #-} + {-# inlinable mark #-} release = lift . release - {-# INLINE release #-} + {-# inlinable release #-} diff --git a/src/Text/Trifecta/Delta.hs b/src/Text/Trifecta/Delta.hs --- a/src/Text/Trifecta/Delta.hs +++ b/src/Text/Trifecta/Delta.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# language CPP #-} +{-# language DeriveDataTypeable #-} +{-# language DeriveGeneric #-} ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -17,6 +17,7 @@ ( Delta(..) , HasDelta(..) , HasBytes(..) + , prettyDelta , nextTab , rewind , near @@ -31,17 +32,14 @@ import Data.Int import Data.Data import Data.Word -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable -#endif import Data.Function (on) import Data.FingerTree hiding (empty) import Data.ByteString as Strict hiding (empty) import qualified Data.ByteString.UTF8 as UTF8 import GHC.Generics -import Text.PrettyPrint.ANSI.Leijen hiding (column, (<>)) +import Prettyprinter hiding (column, line') -import Text.Trifecta.Instances () +import Text.Trifecta.Util.Pretty class HasBytes t where bytes :: t -> Int64 @@ -94,7 +92,7 @@ -- , number of bytes -- , number of bytes since the last newline ) -- @ - deriving (Show, Data, Typeable, Generic) + deriving (Show, Data, Generic) instance Eq Delta where (==) = (==) `on` bytes @@ -106,26 +104,23 @@ delta = either delta delta -- | Example: @file.txt:12:34@ -instance Pretty Delta where - pretty d = case d of - Columns c _ -> prettyDelta interactive 0 c - Tab x y _ -> prettyDelta interactive 0 (nextTab x + y) - Lines l c _ _ -> prettyDelta interactive l c - Directed fn l c _ _ -> prettyDelta (UTF8.toString fn) l c - where - prettyDelta - :: String -- Source description - -> Int64 -- Line - -> Int64 -- Column - -> Doc - prettyDelta source line' column' - = bold (pretty source) - <> char ':' <> bold (int64 (line'+1)) - <> char ':' <> bold (int64 (column'+1)) - interactive = "(interactive)" - -int64 :: Int64 -> Doc -int64 = pretty . show +prettyDelta :: Delta -> Doc AnsiStyle +prettyDelta d = case d of + Columns c _ -> go interactive 0 c + Tab x y _ -> go interactive 0 (nextTab x + y) + Lines l c _ _ -> go interactive l c + Directed fn l c _ _ -> go (UTF8.toString fn) l c + where + go + :: String -- Source description + -> Int64 -- Line + -> Int64 -- Column + -> Doc AnsiStyle + go source line' column' + = annotate bold (pretty source) + <> char ':' <> annotate bold (pretty (line'+1)) + <> char ':' <> annotate bold (pretty (column'+1)) + interactive = "(interactive)" -- | Retrieve the character offset within the current line from this 'Delta'. column :: HasDelta t => t -> Int64 @@ -134,7 +129,7 @@ Tab b a _ -> nextTab b + a Lines _ c _ _ -> c Directed _ _ c _ _ -> c -{-# INLINE column #-} +{-# inlinable column #-} -- | Retrieve the byte offset within the current line from this 'Delta'. columnByte :: Delta -> Int64 @@ -142,7 +137,7 @@ columnByte (Tab _ _ b) = b columnByte (Lines _ _ _ b) = b columnByte (Directed _ _ _ _ b) = b -{-# INLINE columnByte #-} +{-# inlinable columnByte #-} instance HasBytes Delta where bytes (Columns _ b) = b @@ -177,14 +172,14 @@ -- | Increment a column number to the next tabstop. nextTab :: Int64 -> Int64 nextTab x = x + (8 - mod x 8) -{-# INLINE nextTab #-} +{-# inlinable nextTab #-} -- | Rewind a 'Delta' to the beginning of the line. rewind :: Delta -> Delta rewind (Lines n _ b d) = Lines n 0 (b - d) 0 rewind (Directed p n _ b d) = Directed p n 0 (b - d) 0 rewind _ = Columns 0 0 -{-# INLINE rewind #-} +{-# inlinable rewind #-} -- | Should we show two things with a 'Delta' on the same line? -- @@ -195,7 +190,7 @@ -- False near :: (HasDelta s, HasDelta t) => s -> t -> Bool near s t = rewind (delta s) == rewind (delta t) -{-# INLINE near #-} +{-# inlinable near #-} class HasDelta t where delta :: t -> Delta diff --git a/src/Text/Trifecta/Highlight.hs b/src/Text/Trifecta/Highlight.hs --- a/src/Text/Trifecta/Highlight.hs +++ b/src/Text/Trifecta/Highlight.hs @@ -1,13 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language CPP #-} +{-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} -#ifndef MIN_VERSION_lens -#define MIN_VERSION_lens(x,y,z) 1 -#endif ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -25,43 +22,42 @@ , doc ) where -import Control.Lens -#if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710 - hiding (Empty) -#endif +import Control.Lens hiding (Empty) import Data.Foldable as F import Data.Int (Int64) import Data.List (sort) import Data.Semigroup import Data.Semigroup.Union import Prelude hiding (head) +import Prettyprinter +import Prettyprinter.Render.Terminal (color) +import qualified Prettyprinter.Render.Terminal as Pretty import Text.Blaze import Text.Blaze.Html5 hiding (a,b,i) import qualified Text.Blaze.Html5 as Html5 import Text.Blaze.Html5.Attributes hiding (title,id) import Text.Blaze.Internal (MarkupM(Empty, Leaf)) import Text.Parser.Token.Highlight -import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 -import Text.Trifecta.Util.IntervalMap as IM import Text.Trifecta.Delta import Text.Trifecta.Rope +import Text.Trifecta.Util.IntervalMap as IM +import Text.Trifecta.Util.Pretty -- | Convert a 'Highlight' into a coloration on a 'Doc'. -withHighlight :: Highlight -> Doc -> Doc -withHighlight Comment = blue -withHighlight ReservedIdentifier = magenta -withHighlight ReservedConstructor = magenta -withHighlight EscapeCode = magenta -withHighlight Operator = yellow -withHighlight CharLiteral = cyan -withHighlight StringLiteral = cyan -withHighlight Constructor = bold -withHighlight ReservedOperator = yellow -withHighlight ConstructorOperator = yellow -withHighlight ReservedConstructorOperator = yellow +withHighlight :: Highlight -> Doc AnsiStyle -> Doc AnsiStyle +withHighlight Comment = annotate (color Pretty.Blue) +withHighlight ReservedIdentifier = annotate (color Pretty.Magenta) +withHighlight ReservedConstructor = annotate (color Pretty.Magenta) +withHighlight EscapeCode = annotate (color Pretty.Magenta) +withHighlight Operator = annotate (color Pretty.Yellow) +withHighlight CharLiteral = annotate (color Pretty.Cyan) +withHighlight StringLiteral = annotate (color Pretty.Cyan) +withHighlight Constructor = annotate Pretty.bold +withHighlight ReservedOperator = annotate (color Pretty.Yellow) +withHighlight ConstructorOperator = annotate (color Pretty.Yellow) +withHighlight ReservedConstructorOperator = annotate (color Pretty.Yellow) withHighlight _ = id -- | A 'HighlightedRope' is a 'Rope' with an associated 'IntervalMap' full of highlighted regions. @@ -107,23 +103,8 @@ | otherwise = unsafeLazyByteString om >> go eb nom es where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs -#if MIN_VERSION_blaze_markup(0,8,0) emptyMarkup = Empty () leafMarkup a b c = Leaf a b c () -#else - emptyMarkup = Empty - leafMarkup a b c = Leaf a b c -#endif - -instance Pretty HighlightedRope where - pretty (HighlightedRope intervals r) = go mempty lbs boundaries where - lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)] - ints = intersections mempty (delta r) intervals - boundaries = sort [ i | (Interval lo hi, _) <- ints, i <- [ lo, hi ] ] - dominated l h = Prelude.foldr (fmap . withHighlight . snd) id (dominators l h intervals) - go l cs [] = dominated l (delta r) $ pretty (LazyUTF8.toString cs) - go l cs (h:es) = dominated l h (pretty (LazyUTF8.toString om)) <> go h nom es - where (om,nom) = L.splitAt (fromIntegral (bytes h - bytes l)) cs -- | Represents a source file like an HsColour rendered document data HighlightDoc = HighlightDoc diff --git a/src/Text/Trifecta/Instances.hs b/src/Text/Trifecta/Instances.hs deleted file mode 100644 --- a/src/Text/Trifecta/Instances.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Copyright : (c) Edward Kmett 2013-2015 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Orphan instances we need to remain sane. ------------------------------------------------------------------------------ -module Text.Trifecta.Instances () where - -#if !MIN_VERSION_ansi_wl_pprint(0,6,8) -import qualified Data.Semigroup as Data -import Text.PrettyPrint.ANSI.Leijen - -instance Data.Semigroup Doc where - (<>) = (<>) -#endif diff --git a/src/Text/Trifecta/Parser.hs b/src/Text/Trifecta/Parser.hs --- a/src/Text/Trifecta/Parser.hs +++ b/src/Text/Trifecta/Parser.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language BangPatterns #-} +{-# language CPP #-} +{-# language DeriveFoldable #-} +{-# language DeriveFunctor #-} +{-# language DeriveTraversable #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language MultiParamTypeClasses #-} +{-# language Rank2Types #-} +{-# language TemplateHaskell #-} ----------------------------------------------------------------------------- -- | --- Copyright : (c) Edward Kmett 2011-2015 +-- Copyright : (c) Edward Kmett 2011-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com @@ -51,19 +51,19 @@ import Data.Semigroup.Reducer -- import Data.Sequence as Seq hiding (empty) import Data.Set as Set hiding (empty, toList) +import Prettyprinter as Pretty hiding (line) import System.IO import Text.Parser.Combinators import Text.Parser.Char import Text.Parser.LookAhead import Text.Parser.Token -import Text.PrettyPrint.ANSI.Leijen as Pretty hiding (line, (<>), (<$>), empty) import Text.Trifecta.Combinators import Text.Trifecta.Delta as Delta -import Text.Trifecta.Instances () import Text.Trifecta.Rendering import Text.Trifecta.Result import Text.Trifecta.Rope import Text.Trifecta.Util.It +import Text.Trifecta.Util.Pretty -- | The type of a trifecta parser -- @@ -111,40 +111,40 @@ instance Functor Parser where fmap f (Parser m) = Parser $ \ eo ee co -> m (eo . f) ee (co . f) - {-# INLINE fmap #-} + {-# inlinable fmap #-} a <$ Parser m = Parser $ \ eo ee co -> m (\_ -> eo a) ee (\_ -> co a) - {-# INLINE (<$) #-} + {-# inlinable (<$) #-} instance Applicative Parser where pure a = Parser $ \ eo _ _ _ _ _ -> eo a mempty - {-# INLINE pure #-} + {-# inlinable pure #-} (<*>) = ap - {-# INLINE (<*>) #-} + {-# inlinable (<*>) #-} instance Alternative Parser where empty = Parser $ \_ ee _ _ _ _ -> ee mempty - {-# INLINE empty #-} + {-# inlinable empty #-} Parser m <|> Parser n = Parser $ \ eo ee co ce d bs -> m eo (\e -> n (\a e' -> eo a (e <> e')) (\e' -> ee (e <> e')) co ce d bs) co ce d bs - {-# INLINE (<|>) #-} + {-# inlinable (<|>) #-} many p = Prelude.reverse <$> manyAccum (:) p - {-# INLINE many #-} + {-# inlinable many #-} some p = (:) <$> p <*> Alternative.many p instance Semigroup a => Semigroup (Parser a) where (<>) = liftA2 (<>) - {-# INLINE (<>) #-} + {-# inlinable (<>) #-} instance (Semigroup a, Monoid a) => Monoid (Parser a) where mappend = (<>) - {-# INLINE mappend #-} + {-# inlinable mappend #-} mempty = pure mempty - {-# INLINE mempty #-} + {-# inlinable mempty #-} instance Monad Parser where return = pure - {-# INLINE return #-} + {-# inlinable return #-} Parser m >>= k = Parser $ \ eo ee co ce d bs -> m -- epsilon result: feed result to monadic continutaion; committed -- continuations as they were given to us; epsilon callbacks merge @@ -174,21 +174,23 @@ d' bs') -- committed error, delta, and bytestring: as given ce d bs - {-# INLINE (>>=) #-} + {-# inlinable (>>=) #-} (>>) = (*>) - {-# INLINE (>>) #-} + {-# inlinable (>>) #-} +#if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail - {-# INLINE fail #-} + {-# inlinable fail #-} +#endif instance Fail.MonadFail Parser where fail s = Parser $ \ _ ee _ _ _ _ -> ee (failed s) - {-# INLINE fail #-} + {-# inlinable fail #-} instance MonadPlus Parser where mzero = empty - {-# INLINE mzero #-} + {-# inlinable mzero #-} mplus = (<|>) - {-# INLINE mplus #-} + {-# inlinable mplus #-} manyAccum :: (a -> [a] -> [a]) -> Parser a -> Parser [a] manyAccum f (Parser p) = Parser $ \eo _ co ce d bs -> @@ -201,31 +203,31 @@ liftIt m = Parser $ \ eo _ _ _ _ _ -> do a <- m eo a mempty -{-# INLINE liftIt #-} +{-# inlinable liftIt #-} instance Parsing Parser where try (Parser m) = Parser $ \ eo ee co _ -> m eo ee co (\_ -> ee mempty) - {-# INLINE try #-} + {-# inlinable try #-} Parser m nm = Parser $ \ eo ee -> m (\a e -> eo a (if isJust (_reason e) then e { _expected = Set.singleton nm } else e)) (\e -> ee e { _expected = Set.singleton nm }) - {-# INLINE () #-} + {-# inlinable () #-} skipMany p = () <$ manyAccum (\_ _ -> []) p - {-# INLINE skipMany #-} + {-# inlinable skipMany #-} unexpected s = Parser $ \ _ ee _ _ _ _ -> ee $ failed $ "unexpected " ++ s - {-# INLINE unexpected #-} + {-# inlinable unexpected #-} eof = notFollowedBy anyChar "end of input" - {-# INLINE eof #-} + {-# inlinable eof #-} notFollowedBy p = try (optional p >>= maybe (pure ()) (unexpected . show)) - {-# INLINE notFollowedBy #-} + {-# inlinable notFollowedBy #-} instance Errable Parser where raiseErr e = Parser $ \ _ ee _ _ _ _ -> ee e - {-# INLINE raiseErr #-} + {-# inlinable raiseErr #-} instance LookAheadParsing Parser where lookAhead (Parser m) = Parser $ \eo ee _ -> m eo ee (\a _ _ _ -> eo a mempty) - {-# INLINE lookAhead #-} + {-# inlinable lookAhead #-} instance CharParsing Parser where satisfy f = Parser $ \ _ ee co _ d bs -> @@ -238,27 +240,27 @@ (co c mempty) ddc | otherwise -> co c mempty (d <> delta c) bs - {-# INLINE satisfy #-} + {-# inlinable satisfy #-} instance TokenParsing Parser instance DeltaParsing Parser where line = Parser $ \eo _ _ _ _ bs -> eo bs mempty - {-# INLINE line #-} + {-# inlinable line #-} position = Parser $ \eo _ _ _ d _ -> eo d mempty - {-# INLINE position #-} + {-# inlinable position #-} rend = Parser $ \eo _ _ _ d bs -> eo (rendered d bs) mempty - {-# INLINE rend #-} + {-# inlinable rend #-} slicedWith f p = do m <- position a <- p r <- position f a <$> liftIt (sliceIt m r) - {-# INLINE slicedWith #-} + {-# inlinable slicedWith #-} instance MarkParsing Delta Parser where mark = position - {-# INLINE mark #-} + {-# inlinable mark #-} release d' = Parser $ \_ ee co _ d bs -> do mbs <- rewindIt d' case mbs of @@ -307,7 +309,7 @@ feed t (StepDone r a) = StepDone (snoc r t) a feed t (StepFail r xs) = StepFail (snoc r t) xs feed t (StepCont r _ k) = k (snoc r t) -{-# INLINE feed #-} +{-# inlinable feed #-} -- | Assume all possible input has been given to the parser, execute it to yield -- a final result. @@ -315,19 +317,19 @@ starve (StepDone _ a) = Success a starve (StepFail _ xs) = Failure xs starve (StepCont _ z _) = z -{-# INLINE starve #-} +{-# inlinable starve #-} stepResult :: Rope -> Result a -> Step a stepResult r (Success a) = StepDone r a stepResult r (Failure xs) = StepFail r xs -{-# INLINE stepResult #-} +{-# inlinable stepResult #-} stepIt :: It Rope a -> Step a stepIt = go mempty where go r m = case simplifyIt m r of Pure a -> StepDone r a It a k -> StepCont r (pure a) $ \r' -> go r' (k r') -{-# INLINE stepIt #-} +{-# inlinable stepIt #-} data Stepping a = EO a Err @@ -363,7 +365,7 @@ joinStep (StepDone r (Failure e)) = StepFail r e joinStep (StepFail r e) = StepFail r e joinStep (StepCont r a k) = StepCont r (join a) (joinStep <$> k) - {-# INLINE joinStep #-} + {-# inlinable joinStep #-} -- | Run a 'Parser' on input that can be reduced to a 'Rope', e.g. 'String', or -- 'ByteString'. See also the monomorphic versions 'parseString' and @@ -375,7 +377,7 @@ -> t -> Result a runParser p d bs = starve $ feed bs $ stepParser p d -{-# INLINE runParser #-} +{-# inlinable runParser #-} -- | @('parseFromFile' p filePath)@ runs a parser @p@ on the input read from -- @filePath@ using 'ByteString.readFile'. All diagnostic messages emitted over @@ -392,7 +394,7 @@ case result of Success a -> return (Just a) Failure xs -> do - liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak + liftIO $ renderIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> line' return Nothing -- | @('parseFromFileEx' p filePath)@ runs a parser @p@ on the input read from @@ -432,5 +434,5 @@ parseTest :: (MonadIO m, Show a) => Parser a -> String -> m () parseTest p s = case parseByteString p mempty (UTF8.fromString s) of - Failure xs -> liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak -- TODO: retrieve columns + Failure xs -> liftIO $ renderIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> line' -- TODO: retrieve columns Success a -> liftIO (print a) diff --git a/src/Text/Trifecta/Rendering.hs b/src/Text/Trifecta/Rendering.hs --- a/src/Text/Trifecta/Rendering.hs +++ b/src/Text/Trifecta/Rendering.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# language CPP #-} +{-# language DeriveDataTypeable #-} +{-# language DeriveGeneric #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language TemplateHaskell #-} +{-# language TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -24,10 +25,12 @@ , HasRendering(..) , nullRendering , emptyRendering + , prettyRendering , Source(..) , rendered , Renderable(..) , Rendered(..) + , gutterEffects -- * Carets , Caret(..) , HasCaret(..) @@ -59,84 +62,89 @@ import Control.Comonad import Control.Lens import Data.Array -import Data.ByteString as B hiding (any, empty, groupBy) -import qualified Data.ByteString.UTF8 as UTF8 +import Data.ByteString as B hiding (any, empty, groupBy) +import qualified Data.ByteString.UTF8 as UTF8 import Data.Data import Data.Foldable -import Data.Function (on) +import Data.Function (on) import Data.Hashable -import Data.Int (Int64) -import Data.List (groupBy) +import Data.Int (Int64) +import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Semigroup import Data.Semigroup.Reducer import GHC.Generics -import Prelude as P hiding (span) +import Prelude as P hiding (span) +import Prettyprinter hiding (column, line') +import Prettyprinter.Render.Terminal (color, bgColor, colorDull, bgColorDull) +import qualified Prettyprinter.Render.Terminal as Pretty import System.Console.ANSI -import Text.PrettyPrint.ANSI.Leijen hiding (column, (<$>), (<>)) import Text.Trifecta.Delta -import Text.Trifecta.Instances () import Text.Trifecta.Util.Combinators +import Text.Trifecta.Util.Pretty -- $setup -- -- >>> :set -XOverloadedStrings --- >>> import Text.PrettyPrint.ANSI.Leijen (pretty, plain) -- >>> import Data.ByteString (ByteString) -- >>> import Data.Monoid (mempty) +-- >>> import Prettyprinter (unAnnotate) -- >>> import Text.Trifecta.Delta -- >>> let exampleRendering = rendered mempty ("int main(int argc, char ** argv) { int; }" :: ByteString) outOfRangeEffects :: [SGR] -> [SGR] outOfRangeEffects xs = SetConsoleIntensity BoldIntensity : xs -sgr :: [SGR] -> Doc -> Doc +sgr :: [SGR] -> Doc AnsiStyle -> Doc AnsiStyle sgr xs0 = go (P.reverse xs0) where go [] = id - go (SetConsoleIntensity NormalIntensity : xs) = debold . go xs - go (SetConsoleIntensity BoldIntensity : xs) = bold . go xs - go (SetUnderlining NoUnderline : xs) = deunderline . go xs - go (SetUnderlining SingleUnderline : xs) = underline . go xs + go (SetConsoleIntensity NormalIntensity : xs) = annotate debold . go xs + go (SetConsoleIntensity BoldIntensity : xs) = annotate bold . go xs + go (SetUnderlining NoUnderline : xs) = annotate deunderline . go xs + go (SetUnderlining SingleUnderline : xs) = annotate underlined . go xs go (SetColor f i c : xs) = case f of +#if MIN_VERSION_ansi_terminal(1,1,0) + Underlining -> go xs +#endif Foreground -> case i of Dull -> case c of - Black -> dullblack . go xs - Red -> dullred . go xs - Green -> dullgreen . go xs - Yellow -> dullyellow . go xs - Blue -> dullblue . go xs - Magenta -> dullmagenta . go xs - Cyan -> dullcyan . go xs - White -> dullwhite . go xs + Black -> annotate (color Pretty.Black) . go xs + Red -> annotate (color Pretty.Red) . go xs + Green -> annotate (color Pretty.Green) . go xs + Yellow -> annotate (color Pretty.Yellow) . go xs + Blue -> annotate (color Pretty.Blue) . go xs + Magenta -> annotate (color Pretty.Magenta) . go xs + Cyan -> annotate (color Pretty.Cyan) . go xs + White -> annotate (color Pretty.White) . go xs Vivid -> case c of - Black -> black . go xs - Red -> red . go xs - Green -> green . go xs - Yellow -> yellow . go xs - Blue -> blue . go xs - Magenta -> magenta . go xs - Cyan -> cyan . go xs - White -> white . go xs + Black -> annotate (colorDull Pretty.Black) . go xs + Red -> annotate (colorDull Pretty.Red) . go xs + Green -> annotate (colorDull Pretty.Green) . go xs + Yellow -> annotate (colorDull Pretty.Yellow) . go xs + Blue -> annotate (colorDull Pretty.Blue) . go xs + Magenta -> annotate (colorDull Pretty.Magenta) . go xs + Cyan -> annotate (colorDull Pretty.Cyan) . go xs + White -> annotate (colorDull Pretty.White) . go xs Background -> case i of Dull -> case c of - Black -> ondullblack . go xs - Red -> ondullred . go xs - Green -> ondullgreen . go xs - Yellow -> ondullyellow . go xs - Blue -> ondullblue . go xs - Magenta -> ondullmagenta . go xs - Cyan -> ondullcyan . go xs - White -> ondullwhite . go xs + Black -> annotate (bgColorDull Pretty.Black) . go xs + Red -> annotate (bgColorDull Pretty.Red) . go xs + Green -> annotate (bgColorDull Pretty.Green) . go xs + Yellow -> annotate (bgColorDull Pretty.Yellow) . go xs + Blue -> annotate (bgColorDull Pretty.Blue) . go xs + Magenta -> annotate (bgColorDull Pretty.Magenta) . go xs + Cyan -> annotate (bgColorDull Pretty.Cyan) . go xs + White -> annotate (bgColorDull Pretty.White) . go xs Vivid -> case c of - Black -> onblack . go xs - Red -> onred . go xs - Green -> ongreen . go xs - Yellow -> onyellow . go xs - Blue -> onblue . go xs - Magenta -> onmagenta . go xs - Cyan -> oncyan . go xs - White -> onwhite . go xs + Black -> annotate (bgColor Pretty.Black) . go xs + Red -> annotate (bgColor Pretty.Red) . go xs + Green -> annotate (bgColor Pretty.Green) . go xs + Yellow -> annotate (bgColor Pretty.Yellow) . go xs + Blue -> annotate (bgColor Pretty.Blue) . go xs + Magenta -> annotate (bgColor Pretty.Magenta) . go xs + Cyan -> annotate (bgColor Pretty.Cyan) . go xs + White -> annotate (bgColor Pretty.White) . go xs go (_ : xs) = go xs -- | A raw canvas to paint ANSI-styled characters on. @@ -206,7 +214,7 @@ -- | The empty 'Rendering', which contains nothing at all. -- --- >>> show (pretty emptyRendering) +-- >>> show (prettyRendering emptyRendering) -- "" emptyRendering :: Rendering emptyRendering = Rendering (Columns 0 0) 0 0 id (const id) @@ -271,16 +279,25 @@ (.#) :: (Delta -> Lines -> Lines) -> Rendering -> Rendering f .# Rendering d ll lb s g = Rendering d ll lb s $ \e l -> f e $ g e l -instance Pretty Rendering where - pretty (Rendering d ll _ l f) = nesting $ \k -> columns $ \mn -> go (fromIntegral (fromMaybe 80 mn - k)) where - go cols = align (vsep (P.map ln [t..b])) where - (lo, hi) = window (column d) ll (min (max (cols - 2) 30) 200) - a = f d $ l $ array ((0,lo),(-1,hi)) [] - ((t,_),(b,_)) = bounds a - ln y = hcat - $ P.map (\g -> sgr (fst (P.head g)) (pretty (P.map snd g))) - $ groupBy ((==) `on` fst) - [ a ! (y,i) | i <- [lo..hi] ] +prettyRendering :: Rendering -> Doc AnsiStyle +prettyRendering (Rendering d ll _ l f) = nesting $ \k -> columns $ \mn -> go (fromIntegral (fromMaybe 80 mn - k)) where + go cols = align (vsep (P.map ln [t..b])) where + (lo, hi) = window (column d) ll (min (max (cols - 5 - fromIntegral gutterWidth) 30) 200) + a = f d $ l $ array ((0,lo),(-1,hi)) [] + ((t,_),(b,_)) = bounds a + n = show $ case d of + Lines n' _ _ _ -> 1 + n' + Directed _ n' _ _ _ -> 1 + n' + _ -> 1 + separator = char '|' + gutterWidth = P.length n + gutter = pretty n <+> separator + margin = fill gutterWidth space <+> separator + ln y = (sgr gutterEffects (if y == 0 then gutter else margin) <+>) + $ hcat + $ P.map (\g -> sgr (fst (NE.head g)) (pretty (fmap snd g))) + $ NE.groupBy ((==) `on` fst) + [ a ! (y,i) | i <- [lo..hi] ] window :: Int64 -> Int64 -> Int64 -> (Int64, Int64) window c l w @@ -290,6 +307,10 @@ | otherwise = (c-w2, c+w2) where w2 = div w 2 +-- | ANSI terminal style for rendering the gutter. +gutterEffects :: [SGR] +gutterEffects = [SetColor Foreground Vivid Blue] + data Rendered a = a :@ Rendering deriving Show @@ -320,10 +341,10 @@ -- | A 'Caret' marks a point in the input with a simple @^@ character. -- --- >>> plain (pretty (addCaret (Columns 35 35) exampleRendering)) --- int main(int argc, char ** argv) { int; } --- ^ -data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic) +-- >>> unAnnotate (prettyRendering (addCaret (Columns 35 35) exampleRendering)) +-- 1 | int main(int argc, char ** argv) { int; } +-- | ^ +data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Generic) class HasCaret t where caret :: Lens' t Caret @@ -362,7 +383,7 @@ renderingCaret :: Delta -> ByteString -> Rendering renderingCaret d bs = addCaret d $ rendered d bs -data Careted a = a :^ Caret deriving (Eq,Ord,Show,Data,Typeable,Generic) +data Careted a = a :^ Caret deriving (Eq,Ord,Show,Data,Generic) instance HasCaret (Careted a) where caret f (a :^ c) = (a :^) <$> f c @@ -426,10 +447,10 @@ -- | A 'Span' marks a range of input characters. If 'Caret' is a point, then -- 'Span' is a line. -- --- >>> plain (pretty (addSpan (Columns 35 35) (Columns 38 38) exampleRendering)) --- int main(int argc, char ** argv) { int; } --- ~~~ -data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic) +-- >>> unAnnotate (prettyRendering (addSpan (Columns 35 35) (Columns 38 38) exampleRendering)) +-- 1 | int main(int argc, char ** argv) { int; } +-- | ~~~ +data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Generic) class HasSpan t where span :: Lens' t Span @@ -450,7 +471,7 @@ -- | Annotate an arbitrary piece of data with a 'Span', typically its -- corresponding input location. -data Spanned a = a :~ Span deriving (Eq,Ord,Show,Data,Typeable,Generic) +data Spanned a = a :~ Span deriving (Eq,Ord,Show,Data,Generic) instance HasSpan (Spanned a) where span f (a :~ c) = (a :~) <$> f c @@ -489,16 +510,16 @@ -- | A 'Fixit' is a 'Span' with a suggestion. -- --- >>> plain (pretty (addFixit (Columns 35 35) (Columns 38 38) "Fix this!" exampleRendering)) --- int main(int argc, char ** argv) { int; } --- ~~~ --- Fix this! +-- >>> unAnnotate (prettyRendering (addFixit (Columns 35 35) (Columns 38 38) "Fix this!" exampleRendering)) +-- 1 | int main(int argc, char ** argv) { int; } +-- | ~~~ +-- | Fix this! data Fixit = Fixit { _fixitSpan :: {-# UNPACK #-} !Span -- ^ 'Span' where the error occurred , _fixitReplacement :: !ByteString -- ^ Replacement suggestion - } deriving (Eq,Ord,Show,Data,Typeable,Generic) + } deriving (Eq,Ord,Show,Data,Generic) makeClassy ''Fixit diff --git a/src/Text/Trifecta/Result.hs b/src/Text/Trifecta/Result.hs --- a/src/Text/Trifecta/Result.hs +++ b/src/Text/Trifecta/Result.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} +{-# language CPP #-} +{-# language DeriveFoldable #-} +{-# language DeriveFunctor #-} +{-# language DeriveTraversable #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language MultiParamTypeClasses #-} +{-# language Rank2Types #-} +{-# language TemplateHaskell #-} +{-# language UndecidableInstances #-} ----------------------------------------------------------------------------- -- | --- Copyright : (c) Edward Kmett 2011-2015 +-- Copyright : (c) Edward Kmett 2011-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com @@ -35,34 +35,34 @@ , failed ) where -import Control.Applicative as Alternative -import Control.Lens hiding (cons, snoc) -import Control.Monad (guard) +import Control.Applicative as Alternative +import Control.Lens hiding (cons, snoc) +import Control.Monad (guard) import Data.Foldable -import qualified Data.List as List -import Data.Maybe (fromMaybe, isJust) +import qualified Data.List as List +import Data.Maybe (fromMaybe, isJust) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif -import Data.Set as Set hiding (empty, toList) -import Text.PrettyPrint.ANSI.Leijen as Pretty hiding - (empty, line, (<$>), (<>)) +import Data.Set as Set hiding (empty, toList) +import Prettyprinter as Pretty +import Prettyprinter.Render.Terminal as Pretty -import Text.Trifecta.Delta as Delta -import Text.Trifecta.Instances () +import Text.Trifecta.Delta as Delta import Text.Trifecta.Rendering +import Text.Trifecta.Util.Pretty as Pretty data ErrInfo = ErrInfo - { _errDoc :: Doc + { _errDoc :: Doc AnsiStyle , _errDeltas :: [Delta] - } deriving(Show) + } deriving (Show) -- | This is used to report an error. What went wrong, some supplemental docs -- and a set of things expected at the current location. This does not, however, -- include the actual location. data Err = Err - { _reason :: Maybe Doc - , _footnotes :: [Doc] + { _reason :: Maybe (Doc AnsiStyle) + , _footnotes :: [Doc AnsiStyle] , _expected :: Set String , _finalDeltas :: [Delta] } @@ -72,22 +72,22 @@ instance Semigroup Err where Err md mds mes delta1 <> Err nd nds nes delta2 = Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes) (delta1 <> delta2) - {-# INLINE (<>) #-} + {-# inlinable (<>) #-} instance Monoid Err where mempty = Err Nothing [] mempty mempty - {-# INLINE mempty #-} + {-# inlinable mempty #-} mappend = (<>) - {-# INLINE mappend #-} + {-# inlinable mappend #-} -- | Generate a simple 'Err' word-wrapping the supplied message. failed :: String -> Err failed m = Err (Just (fillSep (pretty <$> words m))) [] mempty mempty -{-# INLINE failed #-} +{-# inlinable failed #-} --- | Convert a 'Rendering' of auxiliary information and an 'Err' into a 'Doc', +-- | Convert a 'Rendering' of auxiliary information and an 'Err' into a 'Doc AnsiStyle', -- ready to be prettyprinted to the user. -explain :: Rendering -> Err -> Doc +explain :: Rendering -> Err -> Doc AnsiStyle explain r (Err mm as es _) | Set.null es = report (withEx mempty) | isJust mm = report $ withEx $ Pretty.char ',' <+> expecting @@ -96,10 +96,10 @@ now = spaceHack $ toList es spaceHack [""] = ["space"] spaceHack xs = List.filter (/= "") xs - withEx x = fromMaybe (fillSep $ text <$> words "unspecified error") mm <> x - expecting = text "expected:" <+> fillSep (punctuate (Pretty.char ',') (text <$> now)) - report txt = vsep $ [pretty (delta r) <> Pretty.char ':' <+> red (text "error") <> Pretty.char ':' <+> nest 4 txt] - <|> pretty r <$ guard (not (nullRendering r)) + withEx x = fromMaybe (fillSep $ pretty <$> words "unspecified error") mm <> x + expecting = pretty "expected:" <+> fillSep (punctuate (Pretty.char ',') (pretty <$> now)) + report txt = vsep $ [prettyDelta (delta r) <> Pretty.char ':' <+> annotate (Pretty.color Pretty.Red) (pretty "error") <> Pretty.char ':' <+> nest 4 txt] + <|> prettyRendering r <$ guard (not (nullRendering r)) <|> as class Errable m where @@ -130,35 +130,31 @@ instance AsResult (Result a) (Result b) a b where _Result = id - {-# INLINE _Result #-} + {-# inlinable _Result #-} -- | The 'Prism' for the 'Success' constructor of 'Result' _Success :: AsResult s t a b => Prism s t a b _Success = _Result . dimap seta (either id id) . right' . rmap (fmap Success) where seta (Success a) = Right a seta (Failure e) = Left (pure (Failure e)) -{-# INLINE _Success #-} +{-# inlinable _Success #-} -- | The 'Prism' for the 'Failure' constructor of 'Result' _Failure :: AsResult s s a a => Prism' s ErrInfo _Failure = _Result . dimap seta (either id id) . right' . rmap (fmap Failure) where seta (Failure e) = Right e seta (Success a) = Left (pure (Success a)) -{-# INLINE _Failure #-} - -instance Show a => Pretty (Result a) where - pretty (Success a) = pretty (show a) - pretty (Failure xs) = pretty (_errDoc xs) +{-# inlinable _Failure #-} instance Applicative Result where pure = Success - {-# INLINE pure #-} + {-# inlinable pure #-} Success f <*> Success a = Success (f a) Success _ <*> Failure y = Failure y Failure x <*> Success _ = Failure x Failure x <*> Failure y = Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y) - {-# INLINE (<*>) #-} + {-# inlinable (<*>) #-} instance Alternative Result where Failure x <|> Failure y = @@ -166,9 +162,9 @@ Success a <|> Success _ = Success a Success a <|> Failure _ = Success a Failure _ <|> Success a = Success a - {-# INLINE (<|>) #-} + {-# inlinable (<|>) #-} empty = Failure mempty - {-# INLINE empty #-} + {-# inlinable empty #-} instance Monad Result where return = pure diff --git a/src/Text/Trifecta/Rope.hs b/src/Text/Trifecta/Rope.hs --- a/src/Text/Trifecta/Rope.hs +++ b/src/Text/Trifecta/Rope.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} +{-# language BangPatterns #-} +{-# language CPP #-} +{-# language DeriveDataTypeable #-} +{-# language DeriveGeneric #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language TypeFamilies #-} ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -50,14 +50,16 @@ -- -- >>> :set -XOverloadedStrings -- >>> import Data.Monoid ((<>)) +-- >>> import Data.ByteString (ByteString) -- >>> import qualified Data.ByteString.UTF8 as Strict -- >>> import qualified Data.ByteString.Lazy.UTF8 as Lazy +-- >>> import Text.Trifecta.Delta -- A 'Strand' is a chunk of data; many 'Strand's together make a 'Rope'. data Strand = Strand {-# UNPACK #-} !ByteString !Delta -- ^ Data of a certain length | Skipping !Delta -- ^ Absence of data of a certain length - deriving (Show, Data, Typeable, Generic) + deriving (Eq, Show, Data, Generic) -- | Construct a single 'Strand' out of a 'ByteString'. strand :: ByteString -> Strand diff --git a/src/Text/Trifecta/Tutorial.hs b/src/Text/Trifecta/Tutorial.hs --- a/src/Text/Trifecta/Tutorial.hs +++ b/src/Text/Trifecta/Tutorial.hs @@ -20,7 +20,7 @@ -- definitions, but it’s useful to keep in mind that the documentation of -- certain functions might not be directly in the /trifecta/ package. importDocumentation :: docDummy -importDocumentation = error "Auxiliary definition to write Haddock documetation for :-)" +importDocumentation = error "Auxiliary definition to write Haddock documentation for :-)" -- | In order to keep things minimal, we define a very simple language for -- arithmetic expressions. @@ -65,7 +65,7 @@ -- @ -- -- > (interactive):1:8: error: expected: ")" --- > (1 + 2 + 3)) --- > ^ +-- > 1 | (1 + 2 + 3)) +-- > | ^ examples :: docDummy examples = error "Haddock dummy for documentation" diff --git a/src/Text/Trifecta/Util/Array.hs b/src/Text/Trifecta/Util/Array.hs deleted file mode 100644 --- a/src/Text/Trifecta/Util/Array.hs +++ /dev/null @@ -1,397 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-} ------------------------------------------------------------------------------ --- | --- Copyright : Edward Kmett 2011-2015 --- Johan Tibell 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : unknown --- --- Fast zero based arrays, based on the implementation in the HAMT-branch of --- unordered-containers ------------------------------------------------------------------------------ -module Text.Trifecta.Util.Array - ( Array - , MArray - - -- * Creation - , new - , new_ - , empty - , singleton - - -- * Basic interface - , length - , lengthM - , read - , write - , index - , index_ - , indexM_ - , update - , insert - , delete - - , unsafeFreeze - , run - , run2 - , copy - , copyM - - -- * Folds - , foldl' - , foldr - - , thaw - , map - , map' - , traverse - , filter - ) where - -import qualified Data.Traversable as Traversable -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative) -#endif -import Control.DeepSeq -import Control.Monad.ST -import GHC.Exts ( - Array#, - copyArray#, - copyMutableArray#, - indexArray#, - Int(I#), - MutableArray#, - newArray#, - readArray#, - sizeofArray#, - sizeofMutableArray#, - thawArray#, - unsafeFreezeArray#, - writeArray#) -import GHC.ST (ST(..)) - -import Prelude hiding (filter, foldr, length, map, read -#if __GLASGOW_HASKELL__ >= 710 - , traverse -#endif - ) - ------------------------------------------------------------------------- - -#if defined(ASSERTS) --- This fugly hack is brought by GHC's apparent reluctance to deal --- with MagicHash and UnboxedTuples when inferring types. Eek! -# define CHECK_BOUNDS(_func_,_len_,_k_) \ -if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else -# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \ -if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else -# define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_) -# define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_) -#else -# define CHECK_BOUNDS(_func_,_len_,_k_) -# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) -# define CHECK_GT(_func_,_lhs_,_rhs_) -# define CHECK_LE(_func_,_lhs_,_rhs_) -#endif - -data Array a = Array { - unArray :: !(Array# a) -#if __GLASGOW_HASKELL__ < 702 - , length :: {-# UNPACK #-} !Int -#endif - } - -#if __GLASGOW_HASKELL__ >= 702 -length :: Array a -> Int -length ary = I# (sizeofArray# (unArray ary)) -{-# INLINE length #-} -#endif - --- | Smart constructor -array :: Array# a -> Int -> Array a -#if __GLASGOW_HASKELL__ >= 702 -array ary _n = Array ary -#else -array = Array -#endif -{-# INLINE array #-} - -data MArray s a = MArray { - unMArray :: !(MutableArray# s a) -#if __GLASGOW_HASKELL__ < 702 - , lengthM :: {-# UNPACK #-} !Int -#endif - } - -#if __GLASGOW_HASKELL__ >= 702 -lengthM :: MArray s a -> Int -lengthM mary = I# (sizeofMutableArray# (unMArray mary)) -{-# INLINE lengthM #-} -#endif - --- | Smart constructor -marray :: MutableArray# s a -> Int -> MArray s a -#if __GLASGOW_HASKELL__ >= 702 -marray mary _n = MArray mary -#else -marray = MArray -#endif -{-# INLINE marray #-} - ------------------------------------------------------------------------- - -instance NFData a => NFData (Array a) where - rnf = rnfArray - -rnfArray :: NFData a => Array a -> () -rnfArray ary0 = go ary0 n0 0 where - n0 = length ary0 - go !ary !n !i - | i >= n = () - | otherwise = rnf (index ary i) `seq` go ary n (i+1) -{-# INLINE rnfArray #-} - --- | Create a new mutable array of specified size, in the specified --- state thread, with each element containing the specified initial --- value. -new :: Int -> a -> ST s (MArray s a) -new n@(I# n#) b = - CHECK_GT("new",n,(0 :: Int)) - ST $ \s -> case newArray# n# b s of - (# s', ary #) -> (# s', marray ary n #) -{-# INLINE new #-} - -new_ :: Int -> ST s (MArray s a) -new_ n = new n undefinedElem - -empty :: Array a -empty = run (new_ 0) - -singleton :: a -> Array a -singleton x = run (new 1 x) -{-# INLINE singleton #-} - -read :: MArray s a -> Int -> ST s a -read ary _i@(I# i#) = ST $ \ s -> - CHECK_BOUNDS("read", lengthM ary, _i) - readArray# (unMArray ary) i# s -{-# INLINE read #-} - -write :: MArray s a -> Int -> a -> ST s () -write ary _i@(I# i#) b = ST $ \ s -> - CHECK_BOUNDS("write", lengthM ary, _i) - case writeArray# (unMArray ary) i# b s of - s' -> (# s' , () #) -{-# INLINE write #-} - -index :: Array a -> Int -> a -index ary _i@(I# i#) = - CHECK_BOUNDS("index", length ary, _i) - case indexArray# (unArray ary) i# of (# b #) -> b -{-# INLINE index #-} - -index_ :: Array a -> Int -> ST s a -index_ ary _i@(I# i#) = - CHECK_BOUNDS("index_", length ary, _i) - case indexArray# (unArray ary) i# of (# b #) -> return b -{-# INLINE index_ #-} - -indexM_ :: MArray s a -> Int -> ST s a -indexM_ ary _i@(I# i#) = - CHECK_BOUNDS("index_", lengthM ary, _i) - ST $ \ s# -> readArray# (unMArray ary) i# s# -{-# INLINE indexM_ #-} - -unsafeFreeze :: MArray s a -> ST s (Array a) -unsafeFreeze mary = - ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of - (# s', ary #) -> (# s', array ary (lengthM mary) #) -{-# INLINE unsafeFreeze #-} - -run :: (forall s . ST s (MArray s e)) -> Array e -run act = runST $ act >>= unsafeFreeze -{-# INLINE run #-} - -run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a) -run2 k = runST $ do - (marr,b) <- k - arr <- unsafeFreeze marr - return (arr,b) - --- | Unsafely copy the elements of an array. Array bounds are not checked. -copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () -#if __GLASGOW_HASKELL__ >= 702 -copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = - CHECK_LE("copy", _sidx + _n, length src) - CHECK_LE("copy", _didx + _n, lengthM dst) - ST $ \ s# -> case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of - s2 -> (# s2, () #) -#else -copy !src !sidx !dst !didx n = - CHECK_LE("copy", sidx + n, length src) - CHECK_LE("copy", didx + n, lengthM dst) - copy_loop sidx didx 0 where - copy_loop !i !j !c - | c >= n = return () - | otherwise = do - b <- index_ src i - write dst j b - copy_loop (i+1) (j+1) (c+1) -#endif - --- | Unsafely copy the elements of an array. Array bounds are not checked. -copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () -#if __GLASGOW_HASKELL__ >= 702 -copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = - CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1) - CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) - ST $ \ s# -> case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of - s2 -> (# s2, () #) -#else -copyM !src !sidx !dst !didx n = - CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1) - CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1) - copy_loop sidx didx 0 where - copy_loop !i !j !c - | c >= n = return () - | otherwise = do - b <- indexM_ src i - write dst j b - copy_loop (i+1) (j+1) (c+1) -#endif - --- | /O(n)/ Insert an element at the given position in this array, --- increasing its size by one. -insert :: Array e -> Int -> e -> Array e -insert ary idx b = - CHECK_BOUNDS("insert", count + 1, idx) - run $ do - mary <- new_ (count+1) - copy ary 0 mary 0 idx - write mary idx b - copy ary idx mary (idx+1) (count-idx) - return mary - where !count = length ary -{-# INLINE insert #-} - --- | /O(n)/ Update the element at the given position in this array. -update :: Array e -> Int -> e -> Array e -update ary idx b = - CHECK_BOUNDS("update", count, idx) - run $ do - mary <- thaw ary 0 count - write mary idx b - return mary - where !count = length ary -{-# INLINE update #-} - -foldl' :: (b -> a -> b) -> b -> Array a -> b -foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where - go ary n i !z - | i >= n = z - | otherwise = go ary n (i+1) (f z (index ary i)) -{-# INLINE foldl' #-} - -foldr :: (a -> b -> b) -> b -> Array a -> b -foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where - go ary n i z - | i >= n = z - | otherwise = f (index ary i) (go ary n (i+1) z) -{-# INLINE foldr #-} - -undefinedElem :: a -undefinedElem = error "Undefined element" - -thaw :: Array e -> Int -> Int -> ST s (MArray s e) -#if __GLASGOW_HASKELL__ >= 702 -thaw !ary !_o@(I# o#) !n@(I# n#) = - CHECK_LE("thaw", _o + n, length ary) - ST $ \ s -> case thawArray# (unArray ary) o# n# s of - (# s2, mary# #) -> (# s2, marray mary# n #) -#else -thaw !ary !o !n = - CHECK_LE("thaw", o + n, length ary) - do mary <- new_ n - copy ary o mary 0 n - return mary -#endif -{-# INLINE thaw #-} - --- | /O(n)/ Delete an element at the given position in this array, --- decreasing its size by one. -delete :: Array e -> Int -> Array e -delete ary idx = run $ do - mary <- new_ (count-1) - copy ary 0 mary 0 idx - copy ary (idx+1) mary idx (count-(idx+1)) - return mary - where !count = length ary -{-# INLINE delete #-} - -map :: (a -> b) -> Array a -> Array b -map f = \ ary -> - let !n = length ary - in run $ do - mary <- new_ n - go ary mary 0 n - where - go ary mary i n - | i >= n = return mary - | otherwise = do - write mary i $ f (index ary i) - go ary mary (i+1) n -{-# INLINE map #-} - --- | Strict version of 'map'. -map' :: (a -> b) -> Array a -> Array b -map' f = \ ary -> - let !n = length ary - in run $ do - mary <- new_ n - go ary mary 0 n - where - go ary mary i n - | i >= n = return mary - | otherwise = do - write mary i $! f (index ary i) - go ary mary (i+1) n -{-# INLINE map' #-} - -fromList :: Int -> [a] -> Array a -fromList n xs0 = run $ do - mary <- new_ n - go xs0 mary 0 - where - go [] !mary !_ = return mary - go (x:xs) mary i = do write mary i x - go xs mary (i+1) - -toList :: Array a -> [a] -toList = foldr (:) [] - -traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b) -traverse f = \ ary -> - fromList (length ary) `fmap` - Traversable.traverse f (toList ary) -{-# INLINE traverse #-} - -filter :: (a -> Bool) -> Array a -> Array a -filter p = \ ary -> - let !n = length ary - in run $ do - mary <- new_ n - go ary mary 0 0 n - where - go ary mary i j n - | i >= n = if i == j - then return mary - else do mary2 <- new_ j - copyM mary 0 mary2 0 j - return mary2 - | p el = write mary j el >> go ary mary (i+1) (j+1) n - | otherwise = go ary mary (i+1) j n - where el = index ary i -{-# INLINE filter #-} diff --git a/src/Text/Trifecta/Util/Combinators.hs b/src/Text/Trifecta/Util/Combinators.hs --- a/src/Text/Trifecta/Util/Combinators.hs +++ b/src/Text/Trifecta/Util/Combinators.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett diff --git a/src/Text/Trifecta/Util/IntervalMap.hs b/src/Text/Trifecta/Util/IntervalMap.hs --- a/src/Text/Trifecta/Util/IntervalMap.hs +++ b/src/Text/Trifecta/Util/IntervalMap.hs @@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.IntervalMap --- Copyright : (c) Edward Kmett 2011-2015 +-- Copyright : (c) Edward Kmett 2011-2019 -- (c) Ross Paterson 2008 -- License : BSD-style -- Maintainer : ekmett@gmail.com @@ -52,23 +52,18 @@ , fromList ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative hiding (empty) -import Data.Foldable (Foldable (foldMap)) -#endif -#if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710 -import Control.Lens hiding ((:<), (<|), (|>)) -#else -import Control.Lens hiding ((<|), (|>)) -#endif +import qualified Data.Foldable.WithIndex as WithIndex +import Control.Lens as Lens hiding ((:<), (<|), (|>)) import Data.FingerTree (FingerTree, Measured (..), ViewL (..), (<|), (><)) import qualified Data.FingerTree as FT +import qualified Data.Functor.WithIndex as WithIndex #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Reducer import Data.Semigroup.Union +import qualified Data.Traversable.WithIndex as WithIndex ---------------------------------- -- 4.8 Application: interval trees @@ -111,20 +106,26 @@ instance Functor (Node v) where fmap f (Node i x) = Node i (f x) -instance FunctorWithIndex (Interval v) (Node v) where +instance WithIndex.FunctorWithIndex (Interval v) (Node v) where imap f (Node i x) = Node i (f i x) instance Foldable (Node v) where foldMap f (Node _ x) = f x -instance FoldableWithIndex (Interval v) (Node v) where +instance WithIndex.FoldableWithIndex (Interval v) (Node v) where ifoldMap f (Node k v) = f k v instance Traversable (Node v) where traverse f (Node i x) = Node i <$> f x -instance TraversableWithIndex (Interval v) (Node v) where +instance WithIndex.TraversableWithIndex (Interval v) (Node v) where itraverse f (Node i x) = Node i <$> f i x + +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (Interval v) (Node v) where imap = WithIndex.imap +instance Lens.FoldableWithIndex (Interval v) (Node v) where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (Interval v) (Node v) where itraverse = WithIndex.itraverse +#endif -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v diff --git a/src/Text/Trifecta/Util/It.hs b/src/Text/Trifecta/Util/It.hs --- a/src/Text/Trifecta/Util/It.hs +++ b/src/Text/Trifecta/Util/It.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -7,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.It --- Copyright : (C) 2011-2015 Edward Kmett +-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -28,16 +27,9 @@ , sliceIt ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Comonad import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif - import Data.ByteString as Strict import Data.ByteString.Lazy as Lazy import Data.Profunctor @@ -49,6 +41,7 @@ -- >>> import Control.Comonad (extract) -- >>> import Data.ByteString as Strict -- >>> import Text.Trifecta.Delta +-- >>> import Text.Trifecta.Rope -- >>> import Text.Trifecta.Util.It -- | @'It'@ is an @@ -95,7 +88,7 @@ pure = Pure Pure f <*> Pure a = Pure $ f a Pure f <*> It a ka = It (f a) $ fmap f . ka - It f kf <*> Pure a = It (f a) $ fmap ($a) . kf + It f kf <*> Pure a = It (f a) $ fmap ($ a) . kf It f kf <*> It a ka = It (f a) $ \r -> kf r <*> ka r indexIt :: It r a -> r -> a diff --git a/src/Text/Trifecta/Util/Pretty.hs b/src/Text/Trifecta/Util/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Util/Pretty.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2019 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Utility functions to augment the prettyprinter library's interface. +---------------------------------------------------------------------------- + +module Text.Trifecta.Util.Pretty + ( AnsiStyle + , renderIO + -- * Rendering + , char + -- * Styles + , bold + , debold + , underlined + , deunderline + -- * Compatibility shims + , renderPretty + , columns + ) where + + +import Prettyprinter +import Prettyprinter.Render.Terminal +import Prettyprinter.Render.Terminal.Internal (ansiBold, ansiUnderlining) + +char :: Char -> Doc a +char = pretty + +renderPretty :: Double -> Int -> Doc AnsiStyle -> SimpleDocStream AnsiStyle +renderPretty ribbonFraction page + = layoutSmart LayoutOptions { layoutPageWidth = AvailablePerLine page ribbonFraction } + +debold, deunderline :: AnsiStyle +debold = mempty { ansiBold = Nothing } +deunderline = mempty { ansiUnderlining = Nothing} + +columns :: (Maybe Int -> Doc AnsiStyle) -> Doc AnsiStyle +columns f = pageWidth (f . toMaybeInt) where + toMaybeInt (AvailablePerLine cpl _) = Just cpl + toMaybeInt Unbounded = Nothing diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs --- a/tests/QuickCheck.hs +++ b/tests/QuickCheck.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main @@ -7,14 +6,8 @@ import Control.Applicative -#if MIN_VERSION_base(4,7,0) import Data.Either -#endif -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif - import qualified Test.QuickCheck as Q import Text.Parser.Char @@ -81,11 +74,3 @@ parse p s = case parseString p mempty s of Failure e -> Left (show e) Success a -> Right a - -#if !MIN_VERSION_base(4,7,0) -isLeft :: Either a b -> Bool -isLeft = either (const True) (const False) - -isRight :: Either a b -> Bool -isRight = either (const False) (const True) -#endif diff --git a/tests/doctests.hs b/tests/doctests.hs deleted file mode 100644 --- a/tests/doctests.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources diff --git a/trifecta.cabal b/trifecta.cabal --- a/trifecta.cabal +++ b/trifecta.cabal @@ -1,8 +1,8 @@ name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging -version: 2 +version: 2.1.4 license: BSD3 -cabal-version: >= 1.10 +cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -13,38 +13,43 @@ synopsis: A modern parser combinator library with convenient diagnostics description: A modern parser combinator library with slicing and Clang-style colored diagnostics + . + For example: + . + <> + . + -build-type: Custom -tested-with: GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +build-type: Simple +tested-with: GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.3 - , GHC == 8.6.1 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.4 + , GHC == 9.8.1 +extra-doc-files: + images/*.png + extra-source-files: examples/*.hs examples/LICENSE examples/rfc2616/*.hs examples/RFC2616.txt + examples/RFC2616-malformed.txt examples/trifecta-examples.cabal - .travis.yml CHANGELOG.markdown README.markdown - Warning.hs source-repository head type: git location: https://github.com/ekmett/trifecta -custom-setup - setup-depends: - base >= 4 && < 5, - Cabal, - cabal-doctest >= 1 && < 1.1 - library exposed-modules: Text.Trifecta @@ -56,61 +61,45 @@ Text.Trifecta.Result Text.Trifecta.Rope Text.Trifecta.Tutorial - Text.Trifecta.Util.Array Text.Trifecta.Util.IntervalMap Text.Trifecta.Util.It other-modules: - Text.Trifecta.Instances Text.Trifecta.Util.Combinators + Text.Trifecta.Util.Pretty build-depends: - ansi-wl-pprint >= 0.6.6 && < 0.7, - ansi-terminal >= 0.6 && < 0.9, - array >= 0.3.0.2 && < 0.6, - base >= 4.4 && < 5, - blaze-builder >= 0.3.0.1 && < 0.5, - blaze-html >= 0.5 && < 0.10, - blaze-markup >= 0.5 && < 0.9, - bytestring >= 0.9.1 && < 0.11, - charset >= 0.3.5.1 && < 1, - comonad >= 4 && < 6, - containers >= 0.3 && < 0.7, - deepseq >= 1.2.0.1 && < 1.5, - fingertree >= 0.1 && < 0.2, + ansi-terminal >= 0.6 && < 1.2, + array >= 0.5.1.1 && < 0.6, + base >= 4.9 && < 5, + blaze-builder >= 0.3.0.1 && < 0.5, + blaze-html >= 0.9 && < 0.10, + blaze-markup >= 0.8 && < 0.9, + bytestring >= 0.9.1 && < 0.13, + charset >= 0.3.5.1 && < 1, + comonad >= 5 && < 6, + containers >= 0.5.7.0 && < 0.8, + deepseq >= 1.4.2.0 && < 1.6, + fingertree >= 0.1 && < 0.2, ghc-prim, - hashable >= 1.2.1 && < 1.3, - lens >= 4.0 && < 5, - mtl >= 2.0.1 && < 2.3, - parsers >= 0.12.1 && < 1, - profunctors >= 4.0 && < 6, - reducers >= 3.10 && < 4, - semigroups >= 0.8.3.1 && < 1, - transformers >= 0.2 && < 0.6, - unordered-containers >= 0.2.1 && < 0.3, - utf8-string >= 0.3.6 && < 1.1 + hashable >= 1.2.4 && < 1.5, + indexed-traversable >= 0.1.1 && < 0.2, + lens >= 4.14 && < 6, + mtl >= 2.2.1 && < 2.4, + parsers >= 0.12.1 && < 1, + prettyprinter >= 1.7 && < 2, + prettyprinter-ansi-terminal >= 1.1.2 && < 2, + profunctors >= 5.2 && < 6, + reducers >= 3.12.1 && < 4, + transformers >= 0.5 && < 0.7, + unordered-containers >= 0.2.1 && < 0.3, + utf8-string >= 0.3.6 && < 1.1 default-language: Haskell2010 hs-source-dirs: src - ghc-options: -O2 -Wall -fobject-code - - -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - else - build-depends: fail == 4.9.* - -test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - ghc-options: -Wall -threaded - x-doctest-options: -fobject-code - hs-source-dirs: tests - default-language: Haskell2010 - build-depends: - base, - doctest >= 0.11.1 && < 0.17, - trifecta + ghc-options: -O2 -Wall -Wcompat -Wnoncanonical-monad-instances -fobject-code + if !impl(ghc >= 8.8) + ghc-options: -Wnoncanonical-monadfail-instances test-suite quickcheck type: exitcode-stdio-1.0