trifecta 2 → 2.1.4
raw patch · 29 files changed
Files
- .travis.yml +0/−156
- CHANGELOG.markdown +30/−0
- LICENSE +1/−1
- README.markdown +1/−1
- Setup.hs +2/−0
- Setup.lhs +0/−34
- Warning.hs +0/−5
- examples/RFC2616-malformed.txt +9/−0
- examples/rfc2616/RFC2616.hs +1/−1
- examples/trifecta-examples.cabal +13/−10
- images/example.png binary
- src/Text/Trifecta.hs +1/−1
- src/Text/Trifecta/Combinators.hs +71/−71
- src/Text/Trifecta/Delta.hs +30/−35
- src/Text/Trifecta/Highlight.hs +22/−41
- src/Text/Trifecta/Instances.hs +0/−22
- src/Text/Trifecta/Parser.hs +56/−54
- src/Text/Trifecta/Rendering.hs +100/−79
- src/Text/Trifecta/Result.hs +43/−47
- src/Text/Trifecta/Rope.hs +11/−9
- src/Text/Trifecta/Tutorial.hs +3/−3
- src/Text/Trifecta/Util/Array.hs +0/−397
- src/Text/Trifecta/Util/Combinators.hs +1/−1
- src/Text/Trifecta/Util/IntervalMap.hs +14/−13
- src/Text/Trifecta/Util/It.hs +3/−10
- src/Text/Trifecta/Util/Pretty.hs +47/−0
- tests/QuickCheck.hs +0/−15
- tests/doctests.hs +0/−25
- trifecta.cabal +51/−62
− .travis.yml
@@ -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
CHANGELOG.markdown view
@@ -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`.
LICENSE view
@@ -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
README.markdown view
@@ -1,7 +1,7 @@ trifecta ======== -[](https://hackage.haskell.org/package/trifecta) [](http://travis-ci.org/ekmett/trifecta)+[](https://hackage.haskell.org/package/trifecta) [](https://github.com/ekmett/trifecta/actions?query=workflow%3AHaskell-CI) This package provides a parser that focuses on nice diagnostics.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -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}
− Warning.hs
@@ -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
+ examples/RFC2616-malformed.txt view
@@ -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+
examples/rfc2616/RFC2616.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# language BangPatterns #-} module RFC2616 where
examples/trifecta-examples.cabal view
@@ -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,
+ images/example.png view
binary file changed (absent → 29154 bytes)
src/Text/Trifecta.hs view
@@ -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 <ekmett@gmail.com>
src/Text/Trifecta/Combinators.hs view
@@ -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 #-}
src/Text/Trifecta/Delta.hs view
@@ -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 <ekmett@gmail.com>@@ -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
src/Text/Trifecta/Highlight.hs view
@@ -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 <ekmett@gmail.com>@@ -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
− src/Text/Trifecta/Instances.hs
@@ -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
src/Text/Trifecta/Parser.hs view
@@ -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)
src/Text/Trifecta/Rendering.hs view
@@ -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 <ekmett@gmail.com>@@ -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; }<EOF>--- ^-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; }<EOF>+-- | ^+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; }<EOF>--- ~~~-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; }<EOF>+-- | ~~~+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; }<EOF>--- ~~~--- Fix this!+-- >>> unAnnotate (prettyRendering (addFixit (Columns 35 35) (Columns 38 38) "Fix this!" exampleRendering))+-- 1 | int main(int argc, char ** argv) { int; }<EOF>+-- | ~~~+-- | 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
src/Text/Trifecta/Result.hs view
@@ -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
src/Text/Trifecta/Rope.hs view
@@ -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 <ekmett@gmail.com>@@ -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
src/Text/Trifecta/Tutorial.hs view
@@ -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))<EOF>--- > ^+-- > 1 | (1 + 2 + 3))<EOF>+-- > | ^ examples :: docDummy examples = error "Haddock dummy for documentation"
− src/Text/Trifecta/Util/Array.hs
@@ -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 #-}
src/Text/Trifecta/Util/Combinators.hs view
@@ -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 <ekmett@gmail.com>
src/Text/Trifecta/Util/IntervalMap.hs view
@@ -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
src/Text/Trifecta/Util/It.hs view
@@ -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 <ekmett@gmail.com>@@ -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 <https://wiki.haskell.org/Enumerator_and_iteratee Iteratee>@@ -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
+ src/Text/Trifecta/Util/Pretty.hs view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2019 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- 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
tests/QuickCheck.hs view
@@ -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
− tests/doctests.hs
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Main (doctests)--- Copyright : (C) 2012-14 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- 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
trifecta.cabal view
@@ -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 <ekmett@gmail.com>@@ -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:+ .+ <<https://i.imgur.com/ZyzUSSn.png>>+ .+ <images/example.png (Local Copy)> -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