trifecta-2.1/0000755000000000000000000000000007346545000011346 5ustar0000000000000000trifecta-2.1/.travis.yml0000755000000000000000000002132207346545000013462 0ustar0000000000000000# This Travis job script has been generated by a script via # # haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' # # For more information, see https://github.com/haskell-CI/haskell-ci # # version: 0.5.20180830 # language: c dist: xenial git: # whether to recursively clone submodules submodules: false 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 $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - compiler: ghc-8.8.1 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}} - compiler: ghc-8.4.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}} - compiler: ghc-8.2.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}} - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}} - compiler: ghc-7.10.3 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-3.0"]}} - compiler: ghc-7.8.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-3.0"]}} - compiler: ghc-head addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-head","cabal-install-head"]}} allow_failures: - compiler: ghc-head before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal - CABALHOME=$HOME/.cabal - export PATH="$CABALHOME/bin:$PATH" - TOP=$(pwd) - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - echo $HCNUMVER - CABAL="$CABAL -vnormal+nowrap+markoutput" - set -o pipefail - | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk echo 'BEGIN { state = "output"; }' >> .colorful.awk echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk echo ' if (state == "cabal") {' >> .colorful.awk echo ' print blue($0)' >> .colorful.awk echo ' } else {' >> .colorful.awk echo ' print $0' >> .colorful.awk echo ' }' >> .colorful.awk echo '}' >> .colorful.awk - cat .colorful.awk - | color_cabal_output () { awk -f $TOP/.colorful.awk } - echo text | color_cabal_output install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - HEADHACKAGE=false - if [ $HCNUMVER -gt 80801 ] ; then HEADHACKAGE=true ; fi - rm -f $CABALHOME/config - | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config echo "remote-build-reporting: anonymous" >> $CABALHOME/config echo "write-ghc-environment-files: always" >> $CABALHOME/config echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config echo "world-file: $CABALHOME/world" >> $CABALHOME/config echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config echo "installdir: $CABALHOME/bin" >> $CABALHOME/config echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config echo "store-dir: $CABALHOME/store" >> $CABALHOME/config echo "install-dirs user" >> $CABALHOME/config echo " prefix: $CABALHOME" >> $CABALHOME/config echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - | if $HEADHACKAGE; then echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config echo " secure: True" >> $CABALHOME/config echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config echo " key-threshold: 3" >> $CABALHOME/config fi - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo "packages: ." >> cabal.project echo "packages: ./examples" >> cabal.project - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(trifecta|trifecta-examples)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - 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 - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - ${CABAL} v2-sdist all | color_cabal_output # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - PKGDIR_trifecta="$(find . -maxdepth 1 -type d -regex '.*/trifecta-[0-9.]*')" - PKGDIR_trifecta_examples="$(find . -maxdepth 1 -type d -regex '.*/trifecta-examples-[0-9.]*')" # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo "packages: ${PKGDIR_trifecta}" >> cabal.project echo "packages: ${PKGDIR_trifecta_examples}" >> cabal.project - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(trifecta|trifecta-examples)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true # Building with tests and benchmarks... # build & run tests, build benchmarks - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output # Testing... - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output # cabal check... - (cd ${PKGDIR_trifecta} && ${CABAL} -vnormal check) - (cd ${PKGDIR_trifecta_examples} && ${CABAL} -vnormal check) # haddock... - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output # REGENDATA ["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"] # EOF trifecta-2.1/CHANGELOG.markdown0000755000000000000000000000546007346545000014411 0ustar00000000000000002.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`. * Add a `Text.Trifecta.Tutorial` module, as well as lots of documentation. * Add a `foldResult` function to `Text.Trifecta.Result`. * Allow building with `containers-0.6`. 1.7.1.1 ------- * Support `ansi-wl-pprint-0.6.8` 1.7.1 ----- * Support `doctest-0.12` 1.7 --- * Make `trifecta` forward `-Wcompat`ible: * Adding `Semigroup` instances to correspond to every existing `Monoid` instance. This requires adding a `Semigroup` constraint to the `Monoid` instance for `Parser` to emulate the `Semigroup`-`Monoid` superclass relation that will be present in future versions of GHC. * Adding a `MonadFail` instance for `Parser` * Revamp `Setup.hs` to use `cabal-doctest`. This makes it build with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and sandboxes. 1.6.2.1 ------- * Add this changelog to the `extra-souce-files` in `trifecta.cabal` so that the changelog will appear on Hackage 1.6.2 ----- * Enable support for `blaze-html-0.9` and `blaze-markup-0.8` 1.6.1 ----- * Remove redundant constraints from `DeltaParsing`'s class methods. This is required for `trifecta` to build on GHC 8.0.2. 1.6 ----- * Version bumps to support GHC 8 * Add line/col numbers to parse results by giving a list of all deltas when errors happen. 1.5.2 ----- * `lens` 4.13 support * `It` is a `Profunctor` * Builds clean on GHC 7.10. 1.5.1.3 ------- * Support newer `utf8-string` versions and GHC 7.10 1.5.1.2 ------- * Work around lack of the old `preEscapedString` export in near-current `blaze-markup`. 1.5.1.1 ------- * Work around new exports in `blaze`. 1.5.1 ----- * Parsers 0.12.1 support. This removes many `Show` constraints introduced after 1.4 1.5 ----- * Properly PVP compliant point release for the `parsers` changes to properly handle `notFollowedBy` 1.4.3 ----- * Accidentally non-PVP compliant point release. 1.4.1 ----- * GHC 7.8.1 compatibility 1.4 --- * Simplified AsResult * `lens` 4.0 compatibility 1.2.1.1 ------- * Updated `array` dependency for compatibility with GHC 7.8 1.2.1 ----- * Bug fix for the `Monoid` instance in response to [issue #15](https://github.com/ekmett/trifecta/issues/14) * Made the `Semigroup` instance match the `Monoid` as well. 1.2 --- * Changed the `Monoid` instance for `Parser` in response to [issue #14](https://github.com/ekmett/trifecta/issues/14) * Exported `MonadErr` class for raising `Err`s trifecta-2.1/LICENSE0000644000000000000000000000301307346545000012350 0ustar0000000000000000Copyright 2010-2019 Edward Kmett Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. trifecta-2.1/README.markdown0000755000000000000000000000077607346545000014064 0ustar0000000000000000trifecta ======== [![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) This package provides a parser that focuses on nice diagnostics. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett trifecta-2.1/Setup.lhs0000644000000000000000000000124107346545000013154 0ustar0000000000000000\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} trifecta-2.1/Warning.hs0000755000000000000000000000040007346545000013304 0ustar0000000000000000module 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 trifecta-2.1/examples/0000755000000000000000000000000007346545000013164 5ustar0000000000000000trifecta-2.1/examples/LICENSE0000755000000000000000000000301307346545000014171 0ustar0000000000000000Copyright 2010-2017 Edward Kmett Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. trifecta-2.1/examples/Main.hs0000755000000000000000000000020307346545000014402 0ustar0000000000000000module Main (main) where import RFC2616 (lumpy) import System.Environment (getArgs) main :: IO () main = mapM_ lumpy =<< getArgs trifecta-2.1/examples/RFC2616.txt0000755000000000000000000000020107346545000014652 0ustar0000000000000000GET http://slashdot.org/ HTTP/1.1 foo: this is a test GET http://slashdot.org/ HTTP/1.0 foo: of the emergency broadcast system trifecta-2.1/examples/Spec.hs0000755000000000000000000000160107346545000014413 0ustar0000000000000000module Main where import qualified RFC2616 import Control.Monad.IO.Class (liftIO) import Test.Hspec import Text.Trifecta -- Just [(Request {requestMethod = "GET", requestUri = "http://slashdot.org/", requestProtocol = "1.1"},[Header {headerName = "foo", headerValue = ["this is a test"]}]),(Request {requestMethod = "GET", requestUri = "http://slashdot.org/", requestProtocol = "1.0"},[Header {headerName = "foo", headerValue = ["of the emergency broadcast system"]}])] main :: IO () main = hspec $ do describe "RFC2616.hs should be able to parse RFC2616" $ do it "parses the RFC2616.txt file successfully" $ do -- result :: Maybe [(RFC2616.Request, [RFC2616.Header])] -- Tests are intended to be run from the top level. result <- liftIO $ parseFromFile RFC2616.requests "RFC2616.txt" print result result `shouldNotBe` Nothing trifecta-2.1/examples/rfc2616/0000755000000000000000000000000007346545000014255 5ustar0000000000000000trifecta-2.1/examples/rfc2616/RFC2616.hs0000755000000000000000000000442507346545000015552 0ustar0000000000000000{-# language BangPatterns #-} module RFC2616 where import Control.Applicative import System.Environment (getArgs) import Text.Trifecta hiding (token) import Text.Parser.Token.Highlight infixl 4 <$!> (<$!>) :: Monad m => (a -> b) -> m a -> m b f <$!> ma = do a <- ma return $! f a token :: CharParsing m => m Char token = noneOf $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255'] isHSpace :: Char -> Bool isHSpace c = c == ' ' || c == '\t' skipHSpaces :: CharParsing m => m () skipHSpaces = skipSome (satisfy isHSpace) data Request = Request { requestMethod :: String , requestUri :: String , requestProtocol :: String } deriving (Eq, Ord, Show) requestLine :: (Monad m, TokenParsing m) => m Request requestLine = Request <$!> (highlight ReservedIdentifier (some token) "request method") <* skipHSpaces <*> (highlight Identifier (some (satisfy (not . isHSpace))) "url") <* skipHSpaces <*> (try (highlight ReservedIdentifier (string "HTTP/" *> many httpVersion <* endOfLine)) "protocol") where httpVersion :: (Monad m, CharParsing m) => m Char httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.' || c == '9' endOfLine :: CharParsing m => m () endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ()) data Header = Header { headerName :: String , headerValue :: [String] } deriving (Eq, Ord, Show) messageHeader :: (Monad m, TokenParsing m) => m Header messageHeader = (\h b c -> Header h (b : c)) <$!> (highlight ReservedIdentifier (some token) "header name") <* highlight Operator (char ':') <* skipHSpaces <*> (highlight Identifier (manyTill anyChar endOfLine) "header value") <*> (many (skipHSpaces *> manyTill anyChar endOfLine) "blank line") request :: (Monad m, TokenParsing m) => m (Request, [Header]) request = (,) <$> requestLine <*> many messageHeader <* endOfLine requests :: (Monad m, TokenParsing m) => m [(Request, [Header])] requests = many request lumpy :: String -> IO () lumpy arg = do r <- parseFromFile requests arg case r of Nothing -> return () Just rs -> print (length rs) main :: IO () main = mapM_ lumpy =<< getArgs trifecta-2.1/examples/trifecta-examples.cabal0000755000000000000000000000363707346545000017601 0ustar0000000000000000name: trifecta-examples category: Text, Parsing, Diagnostics, Pretty Printer, Logging version: 2 license: BSD3 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/trifecta/ bug-reports: http://github.com/ekmett/trifecta/issues 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.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.1 extra-source-files: RFC2616.txt RFC2616-malformed.txt source-repository head type: git location: https://github.com/ekmett/trifecta.git library ghc-options: -Wall exposed-modules: RFC2616 hs-source-dirs: rfc2616 build-depends: base >= 4.7 && <5, bytestring, charset, parsers, trifecta default-language: Haskell2010 executable trifecta-examples-rfc2616 main-is: Main.hs ghc-options: -Wall -threaded hs-source-dirs: . default-language: Haskell2010 build-depends: base, trifecta-examples test-suite trifecta-examples-tests type: exitcode-stdio-1.0 main-is: Spec.hs ghc-options: -Wall -threaded hs-source-dirs: . default-language: Haskell2010 build-depends: base, hspec, parsers, transformers, trifecta, trifecta-examples trifecta-2.1/images/0000755000000000000000000000000007346545000012613 5ustar0000000000000000trifecta-2.1/images/example.png0000644000000000000000000007074207346545000014766 0ustar0000000000000000PNG  IHDR6@ R=|iCCPICC Profile(c``*I,(aa``+) rwRR` ` \\À|/JyӦ|6rV%:wJjq2#R d:E%@ [>dd! vV dKIa[)@.ERבI90;@œ r0x00(030X228V:Teg(8C6U9?$HG3/YOGg?Mg;_`܃K})<~km gB_fla810$@$wikiTXtXML:com.adobe.xmp 566 64 0 @IDATx}]$!$!8C[ " ťw EE%5ĉٝ={{_!mM޳3<3{d60G|+ȣh~VS=hvɓ'7=tfΤc?~*i֪jj׮-=x-OUn;P{+|3ON 4Gt hV;F?ڴA& 1@#WE-ҟNt40m> 9ѓ?hj;{[w]h^so-M:Uh۵kb~ cءy& XziꂡtWЍN;uw35iq|sVz ]L50 c*efq!u2igʵ1v@~K+OQ荷ަ8> ιH][;t@>~5h tE9vٝFV\nY:۶(Oz+};С=BLl'ns܋&d/y=@24^Bon^ІjD(6#0hO9Ve\0i,Q9fBʙ5$ișt#vZko}6(x9;h3NRw )h8QT؄\ySSY#l5({xFPM5ŪXXL,PŠ_^ OKugeȇd֨Ak:<?dL^}iTVx+lݘ&ub;3fSVzYvb 8`q,$K36kHg4jwfUq%09g73֝@\ECgĉ4e Ƣ/ ewyn K{ob!>kvDYI]bXܠ5Hsiy*K\,0"6%a,a 4@q!ԠԱ.N ܄r#*(e(@jdο3C .+U +B:pd2X $8. Z`(HgWa )A,Y`԰* !8"j`R@ÆD%.WJ(Pӂ8PXHXSԳ5ȹ}%iSaQA]!=HrCs/X)Xhěs:NU)qf)&R&jDMP)~Vݤ͢ 2f3`u]01 U. PP˱ͪT>jІzLB2b*W+y=I5*,VCu2ըTH\ÓFaIKӐ,r%G>4 lV@Bny֗jsUMhG-Cm|Хu``76I0VZZ#>#poc84/Q8ze!.KY )-4&0J+|Iv:8*1a+l$ЩL{F0=,.sk=(R4>'N=8DrDThpu ZP8V@k])X k&臶gcjcJFag]kWXXX> VeQ6Vb3{SǎQds;5v؉:uTV T?Dƚ7bZ[z{=bZH(rtgIw~t9 Pj ӿ]5mY֞w-7cYYGҵK“g5M t]Uy>Uw֕S@R.@m92TDRcKnR!e~@TblV8Yq +*SK!Sۍ\ JBpU)|j$劼fw[8I)h _q޹tuWp~J`}kOp.;N8s+;nyXKT0Iģ_x.Ÿul4rdk&y`)*pdd!'*L gĵ0 QA1<*]htZS5\$W~ϥ:kUx W.|s#n)g>K﫹{hƌ'Z& FU"[g5i=wO^nwygDx!o^0==tӳϿ(X,bCh~hoW]CAa饖 8Mޫs]\bq:.Lgwy7<ηFe7.t:!c-~tngp{3-tGʣ=4u>K%HQ¢eҌ$rEb+U>VTF<*Gohإ *|rN . /Y4wǢ_eTAc@,k7GOeūJ 9y hx@:Cr+b% YSUS3iߋ:2p31MgGUyăopnkһJ= l츊5؁G'b+ 10ia k\IA,fi{n#`Ye*tR ۺ+YFɋg^ZrEdʫ&A?ͨQ`uxX%?Sy~4_tA$_<1WwZo_Z\c/4s<о=[Ԇ7PHA3OVX~J6h9:yEkUYJs\)&q^)杗7_nLFH|9 W#}vۅ"xu 7Quy~‘<&Q͝`;dRb$6*J@1$15I*QQR$9< g.D"'w ب"{cZ([/%*y0V=K'0o QVcuK8!M LcbOd $7^Ȣnt/LHVaڧG&$Ę߂TDi.LH=u"2˯=02^{i 3%W 3usZuv,oCI:z^gO9Vh?o˟68vzK蜋.{nFӛV]aDŽ<̳tKҼQsY_&KkwmMdR31qsih<דc!# S${}_Ӥ?;˛12,f3iH޴xc!+uHG-܋# ύD'Nw= kL񶈄{2oڶ M/ghcw$"M^zν2F:ןcXmxB=gi[[ȾH<~Ռ=w&ҳԨRKܝXdQAԳѝ%ӦS:-f_hςvm7w^r9=xCȆx˯:>fDDxnAÃs R)t-ѻ|@/*]}x=?xxytR0N .ͧE^^ˁcWA{)~ҐcIz'ŪoUs'D0O4|=j7{;%' Qx≄O^,ǯyJ+ҟvؙ5fׇz72pu/~e[ҿonn] wcFu`KP G|=<[f%X3fLvQvO@$Oi~7PO$~{S>泀O$r'<4Ѓhσexv[=x!=yMH8 _~j"eZjǗ ,qCo߅S$;Ȅe1Q0TT gN}iw?;AW,9?m֧b8Fkٙ='O|&ҍ_98\4^Wޙd|0aKtnOw,8:'IF$ƥ :1ϯx;c hpI}XAͅZ4.0]>\`H{om2އ&UnoO/=SGܡ9?&5Hݻg]xUrVy.;Nَvڏ}]g{%:}.n#a_H {. K-Ez`0w]2܏-?wc._ /žx8kv! tW|aN,Cϼ"u1ѵXN?8 j Ol&~?Z8nr8hȩKO)v&vXC/6>+՞.9LantOq k6tigC=|n(q]wpnDCwr:lnV9O?xnȗF~k.%MXͷ`p(}_>p n܊nJu)C+Qw, WğҒ4[h "d7|g.wء|@;|s |C6T|~d:Pm[1}u{aK.@+v@Np/ ?s^ŗSӞ=c8&=+}>ƜcgY`0Md6[vy`\I&8K [|{|߃<`?dn4］`Fa<œ,;/k.<'+ҳ/|s'=YL|?N}_}Y%|3Gkw˚ G"-<]W^{l&&IxmNqv&>cƒ|V]6Kmgh߾|Yp ?˯$@uVr}k D>ɍV]gù1Li'6Ag_X Σs:H[rˢSFg] Xv҅& ORޟv "+RPȃj=Fx~:jFjW x B`+V r EÂ#O k*9>N?W߸_8뀏ZF)DXHq >hyd.>|zw{|K} UJ^ųٍ":0/$coZ}Wҩc6lo —䛬^c_/*f0#;|`| _%16vL4~ĭl4 svqKn܌3 -|_D l{p<q%>7'_Bï>X "i|!p\t|Ev@i*]'Ю\WqKb>=<$~jG|J:gI/Aᣲ=r]ߏ <Sns& &Jo.9> ͗^{Dc uU.!v63Ĺ,Rxg"-֕uˡ-)*KVAo7Bp% )G1({k\W vPRP6n•, TP hc/?qM}h> 6h 4Z0V֣Շ.uVD(Tݪ"ڊJ-*dP +H=̒O&)]הE1N?S|Ib=woKZZ|?wjdۡR8lJ#yQ+GpfN(&lnUعG;2Oԥ  <2hHlq2Xlك/h0FEC~0ЩRt*9 E0AF׾fq$V >\Sqv;sLNO&?R>2oߐ#;jN;l@'ViM(޶SnaGG ǙIZcuBAMOMH|fx?Ns~|t9Mw"BY<?~?K㉏M:.V-' B}W4i#-2aKKOȁܬSL uBۈ8~L:Qe.Lpqmsؘc^?(19CMp6R~Omȓϧ=7?<* ؔ%4!M?V֙7x7IEx(/ԱX}ȩi^aOB/z[?i7TXض7%N :.bb{XV0mҫA$Av2,K%|qp >,Mxu.u˴ʀ=F.!)Q)]+]vyox]gXmLݮ?ϫ|U+.;5ɠ\< }9Y4+EQjkeEyi0@ q2P` l<唕!G+#YO!ߞ6A^K8+;}p=<r@~#-/55Y;6q~ xY;n/x g4Û'w7n}r=^8閫&]=8pO:c[pD?^dӱs/<|YizpҳB{ﺳ<3 r/;ق»tiGn'X0fxϞ,ۅʏJʩ| .>\.aL6ºRr,%VJBȕ׹<{Y߇rsy$v|&bʔ)^Dx?ι!/zkylš{Ky '~-;c؍q#~ / ۓ̒D(ߋyx}Ⱦ|#4O@m}@GtO6b9__k1Gъs3娽_lsOJ-Lsc"E|ށߟ &J2O6gfʓN1BSTHH'NGW cz;)u҅?)uucn$<69[ V937-Iܐ#FR^e~ea.Ƕc.] oU_ghÙp$l Ny4ݏM<Y -+1iuuR1d&-+KQ?Tʵz,EZ$PaQ0,/;+P`9zb"/ăw#F8õQ:IEUD\A tcˉ=cGqԹ_"wqYt x9ӼwNg*rO/xGm;,K(W5mqx‚IN{geit0Qο7]1:~o{D=%m6[JgN?|nb"å k[uHShd,ߦkoEvl_<1lg.zZ7[;tpf܅'%tSw-pOe 9x%;gޣoQ&85 Q`N8La'S}3&,MOiNPxe$ڇ:_o:hO 9Ybb݋o̗1R _.󫤞e,#RkvKN+eW U޼8x_/V):_Śg(uOb"%OdLe5 ڌ sy>~+jOT]Ky/TYiaNQA{ Ɖgͥ̋bQm8b/BCI׳""ZSlz,eTYxأ[N⬹kCXQp7~TUTT׼9b҈MRŧ31NJx$>ͪAcC_x叀 Z:~I_`cCsF57FחD (Ee\b*#*T5"3\"+(bf=O-*gܗ`Uۊ`AKj1'h:s"3Z,[SQtmQV`Ry^xmPe{&*_/Djo#k\Zµhg>X77 R{)*Y(d+񢝁eaP@9ДR]ZG]>J4ͭ=j=]^ Z*]%)5ffvYB $g0Eu yScYQ+XyޒTD A֐SV:..6- )l UU_gaAX)A@B<ŵf= YG^rq!FxXKW+- t!O.ܙ`_aW,+ -/Aae45Z8|4h6u7:zӱkP.s<2zokb"0yBjARVLZjg Evd?R7jo4ћ' - <#q}\}͓JM"i`r8A$8cTx7kmʓ'GPsQw^6|1~{Mb qB:v|3)>?z!om>/]{ӭFӽr+z d:sC߮-ѧ{P; K<}/.矧&`oYv?<|vm'1CN%|&xg`緹.o싯й\*qеjm@[;_~5ӆJQccA[nGچߤ:?1?݀kƌxo/DOh+(*oҞ8a"=پ|n52 3i饖}wsw>3} e~e[{M`uiKކ혂h 1^܇<{_>|Q]{c!27: x:8`?yc8^T~7YC [:vWګWZT~}T⫯]?wx/ɴ7 +Xt/T-_&\bE>oH{I!Xp#K#i#o4ywlpš?zy̳(pU5/dr c:C|QvtIcQ;5Îz W' UCDz'y>8œ]݆.3&FIG ߋJxutL~k:_w/ߟvykIꇘB'N/WI0$.G|Nz>,h}-̾I$~ |-ׂ/@'˻bLcGH]܇$YCcqe}M6/v_2e tօ57ouߓ47PtRu;!ˉhUюC"(s&AРA0 &6\qI6~2X%"խ8pc-D(nɓ9RCTG_MFxhѥ~E za}^Z|ZȽg= #OnߑiD ~u9C`Qyms&sҥŗ_e ;BB|c2쬺c^yUMkܘ^=zADzw{GΖ +e{hE~<5[(i1"mDXp!yoߝy'K׫Ҽ#xekoEVPzg_xI0?368>">ن枛k}~_ƿ]>Sʕy2$ϯ/F}ȢZ} i:nWSL2K-)'߱߅4-ҷ/-H:FlAQ <^睧7rPi;իcj—vܖc2 ӧӫO;XBou JשgGϼ_">vv+'YB wN~mS.XnLg&ېJK|~ }؏cA|+htni'(WvgZ/p߻!$%TLH 9o*Z!5iQAgA[J-`SYB#濹Gۯ}T{jA B>R3Ξ`Uyznp: FkBqoݺnjI. 01c5Sk{5 >/VLhtᅜ%e_:_G2(eLoЗaL7xgAz3/ CL]:vay,ݞij/9fԏP`S}HJyk#\cjc4൞ˁQWsI6T,r-%bG:(MZ?aBRb'.*cXa*oJHSZcK^}[5w=;i4ql1yAr**+$K!{!4kI 僅fAH3e3~۫\Ҙm_(\ݻCBU,n^?V̀/#spߎ& O?8g0yz-q%} +%!4?ߟcS{U{ iW\sz@6~a 3?=RO6-Lnj#f5!fR#5J~p pHRu"Ƙc:vc:zc: }v(=_C?9~\\X?WP0~/ڶl9 [UsAxT`IKV,ـa#oL}in V:@MdlA]搜y3CdFEEO땆+x`VGeRٌS''<Ā%$ =Ck`glecƎmT9x: |VgsĺZG~ >$q: ̆i֜ݺH݈:еPF9=/Ѡ#fO|{ 2dф_BB{2:+Qh hyBn>ޗTcPe\WxsvVsK,Nećh}` eЯ50eJ7CX"ZĶQiB0*7OU$TWLE8ck[ZMAcDE4+P̹#q ΢cǮԹ;!ԉ_"׶QпcwQ71/ш?"<cӢ{EIo[Ӻeܗ3 DW_{>{3Oy_C |ܚ ;3;6m,=KaR,2vdS86k?ljjd G|4o^$fV77g!xA1Kl0x\Pj\TXƋm2.Yc*|kUWoe[MO3ʐVE30yZ} 7o>38{.`M(&rIAZPZNI,\Ug5,Uajr6&;ƦŨKE딒]thjgIl9@Ya% N P楉 G\7Զ]c>Z7f $z)2:R!I-ͷMYb0 ܝoPyT`6p>0ϿXZ%zꔩ4pםyN^јcQ)GG;]kMqe?lScMI=2r,#MAbIITgDXU:O$V^={1D??7QZ kI#ǐwXwG{\¥N:ȍ(71# l4ԕ?h^T7xZef1~|5V/6PmkQfbUzjgg<%'BJV 7aq]]̳`]'usrp&,YU{n}uOW|͘FM+/AØ1Qv?J]$!}hӰ[/~A/Ibłi"mr ""Jl?]*uuDɚeYEr*^S27*Ai@lIEm5O{7@: m7s{F^R"<#s?Vnj۷kG6t _091ӡ;vrb, z_mΗ?>yzyi.w=d~[iG:x߁X:휡tY${.M{1zvi 7%]={gOC[0I/uD)\*kwu=[oW^Co)tm7zlVxzLD1Qk Ƙ[KF}7 gy"zQoEǜt2^ǎx76x~8%q袳Τ |pKevzE~ Ѻ6梁a2^_xK{*2VqlmC=^+8;6o_{}?Jn/t,]|ŵ2>1ft!3xbpŗ9q3ovV9Œ 6 P:NUf)+GxHRƩ 7PZU|pUy6=Z+x\JX`&]^U(eqZ]Y.4E`p/ >p<эEcLP cTpk4m:-8Ւ".s-ﯙOJiʢv f^~vzL@ KD E־YϹz YԢ`g9?hkqOlE?Kr \;w7-u ~ՆU$e]GX>CUg@ .ō.a=@pI/4my*)Dz> O[E\lޝȟ7& xW_ 3HKxmʪLpy ^T+Soۅ\7ZhJ&brdD V:M)p,z-g'5I7V2ZcI pd=#4Lj++3rHC].^FԔ? /ȓdQb.OqĿ}BӧNA!S98mY|areqq0ծ7LƢukVeZoR"<l]r-ePaUBe ش!-8∝2uaRQ}$RmkRY1`͋Hp@ZOTsH˚z\kGԪbZM@XsL^2c4 Z T  1|{i=v)߯ғON}gՕCr ʓ̣tgUĚ Ks3Ϣ3= QI <&6Q .Z-j'q# rQ6^O/Fn08x -@U%roy\V}g[+S`r "ދE4`:(pZrjMc*+bQ_*]H)m=+gX!xrNs2PdyUH+2KQ>I;PQ\鱣TMYFSlĊPnemC"ؔ޲LAQ>Y|ˀJyk9EIBA4i]6^ZA [0(R`"UѥifYbdk , jeKQ[~ؤ/xjB Kɭ^%;hF|]_ii9:՘zl9r*gJ[4UZj1 r,y\L{l<ɚZ@Dr3Qpn5k riT+Zs蜵J +v3 j^ q 2Z\GLn0JZv]i㤍-ʼn~o04'I D~)ZTj%S,Q=`*x Jq&KjEG%K#j7W͕y$o~DzYÔ65JCa0Ն4S]ᦺdWW35Z]:zFZܚ.~* YZK#Jui"4M"н^10wQQ*.&6Y:rhLH|2n6~y\YQ)B1F qɢ0yIwmuJ}\drE $_ƬЎ СsbT^[ӆ׭eWR5@r;inL[<*/+ȵ+z!k.婙&&X'L|ѣz*xiF\mDBrzUP6]Bو)M 銸4F2%O[,:^)w=FG6q5Ҟx,Zhnsd%A MYZI-Nk`RVETM4.Zj^H]s:W*NV:]7u?\Pέ[pKQr'@H΋$[/,[g1ʊ/U lQQqu`MW[b-#׿0}SlZ kRVm(J,zN=Yti=׭z]$9cʱp,5Ko%`MVrDQg݄L>V'5Qkԩ-uY{'4/p4yB*pSgEXU] TS[[~PNuUfŤZZeZ&\i5<4LqvGA)B̫8 fMh^vJmE+5DFنi͆6`@-؞4<l☐4YV@׈Smbb6pmAih+0DNe|)Sj6+ЪDs#d=Q젥67).?S Sͱvo8du=8aG0m {$K~ \U6M\wM(,AMc^&PGsÁS9 úp]O"P:fJFcR BԒƦ\xrT2Kƣu׏Y U:տfRTcU+D؜;uhqs)C=a2iKjn9S&6^]'cK=//q0:ފ^Pz~I ,*Chßpp~A! Pmg/ QSL&(f `MDS"ؽ‡VD ky:Mu-Bt^cѺ1pF?ׯңʥ܆3tܭQט.TQEZ'e%Z9L}b-kiTsA*F?/e  4WmEfhH hP\Eu80ajČ/ꇼTl kC"Av.vގ?tNk4MHlɲO{h/ZbU P%2M+SX{iX։]6HPS9r70}סVd % 't̀XA4rn7v3^9\/g_jO+kkE=)H뚧8p[4]W8W*#wĆGPUc6>t+-Qrrr7f_McrٴDeNӚK ]B&Z \EΌV%7c.x(nBAs Lah x1z01  6`"28渍b]1srzL퀔?[ k:+eٖ ^R2j,k,p֚Ҝ~ʭ֍5G9}[li  zaZv5Wp)^ЧF!l*-(,%kZ8y]RQe WL1'Oewq<141 MAߜ_rK5tLJ(tF}Umi8zk +:YTBDZE^ aG] +1HJ;2zX AUK]EkTScùҰ65yk[9'X݊nֲiNFdh{M :ԕmjz}}\kbbT~yPUTD"nBZ`M(,11kĖ1?Uu?Ae1PQ/z)J _)uʜ]Y \dA;5/\Ak[\J`R&zl TGpYQkvu.yF$*-<|Smۑڪ.7ш&c"5<5d~[ 9ρZXX/.u ب%~窒@ҽp.z{d5*0rQpSG4)}*F0iF:g[_ʰd|>c`^JAh>%3kA!@}-p3E'5?j[RWf2C)|~-uUqB 5U[Zfڪ-R:y1 us`r|@3X L0\+ri-GJ-)[%\̛(4aj#b\|,k;Sh9X/04#ϙ{\ G͍E,[=Y$|V\j^. l* ˶'l5,XBv_!`޶ ku#.\C&9/ ` OJfznW^N[+R)3Y%\tnwӘQ'5KƓkHQ4,s$S SFU6vbM+qʹSݶ(nn{ S(JP >4 E냠ҢOZ|l[m("UhK#,X}R|DJum9;gswޤ.ܝ93|nnp_W1[ rk4x޸4g& ւ7TL(9_՚ !SxIԂi}МlErP6mB!}0bD Fa(mj&4tucǚ'N קsBtvh}Z)v#a\kacט>mjвPItAgݫ` Z0K{c4`c{F>Nc]cJ@m&Zd/\SMPXoN^%[.W!e.Y. 6 ED(QMy@kq[>:#?*7xFbt1_Em>?~'v+4{3|x3 L+WS2$92'9*PRօOyГ-?Ӧ+cI_s!$*EM &pKA| =d5@Ag))!uǼ|Lڄ&eLem+ :߳4yj~f%og:xz9?;ߚWW`YGEJ뒕|pKAUs+7{|Q{2>uhV˜NOVAZ.ڕE|R7).8,=\䪽u64YҒJ(1Kd+ 8tzwt˼/KX+P5圏_YIgF|C _'?Hq r=t?9W+d;י_gǦ'yN(i]}L1thp]i.588b3Jgl}69&9􀠲5qíƎ#t-jڥ}=R`7z-J_,(7(A8G]y IJ[9"ː À6t}k>wɈaG"ɻa}I3#> khE5NџoM_gEg?,kKT$8.xC^tʽtȣIئC@@|\Zth9 -Ls_wyf9?}~=tib<%eCsjk4  :t}rg\ha5TgC+; ֽshjz)݌qCIENDB`trifecta-2.1/src/Text/0000755000000000000000000000000007346545000013061 5ustar0000000000000000trifecta-2.1/src/Text/Trifecta.hs0000644000000000000000000000200207346545000015150 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- For a short introduction, see the "Text.Trifecta.Tutorial" module. ---------------------------------------------------------------------------- module Text.Trifecta ( module Text.Trifecta.Rendering , module Text.Trifecta.Highlight , module Text.Trifecta.Parser , module Text.Trifecta.Combinators , module Text.Trifecta.Result , module Text.Trifecta.Rope , module Text.Parser.Combinators , module Text.Parser.Char , module Text.Parser.Token ) where import Text.Parser.Char import Text.Parser.Combinators import Text.Parser.Token import Text.Trifecta.Combinators import Text.Trifecta.Highlight import Text.Trifecta.Parser import Text.Trifecta.Rendering import Text.Trifecta.Result import Text.Trifecta.Rope trifecta-2.1/src/Text/Trifecta/0000755000000000000000000000000007346545000014622 5ustar0000000000000000trifecta-2.1/src/Text/Trifecta/Combinators.hs0000644000000000000000000002130607346545000017440 0ustar0000000000000000{-# language CPP #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language FunctionalDependencies #-} {-# language MultiParamTypeClasses #-} {-# language UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Combinators -- Copyright : (c) Edward Kmett 2011-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Text.Trifecta.Combinators ( DeltaParsing(..) , sliced , careting, careted , spanning, spanned , fixiting , MarkParsing(..) ) where import Control.Applicative import Control.Monad (MonadPlus) import Control.Monad.Trans.Class import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Data.ByteString as Strict hiding (span) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Prelude hiding (span) import Text.Parser.Token import Text.Trifecta.Delta import Text.Trifecta.Rendering -- | This class provides parsers with easy access to: -- -- 1) the current line contents. -- 2) the current position as a 'Delta'. -- 3) the ability to use 'sliced' on any parser. class (MonadPlus m, TokenParsing m) => DeltaParsing m where -- | Retrieve the contents of the current line (from the beginning of the line) line :: m ByteString -- | Retrieve the current position as a 'Delta'. position :: m Delta -- | Run a parser, grabbing all of the text between its start and end points slicedWith :: (a -> Strict.ByteString -> r) -> m a -> m r -- | Retrieve a 'Rendering' of the current line noting this position, but not -- placing a 'Caret' there. rend :: m Rendering rend = rendered <$> position <*> line {-# inlinable rend #-} -- | Grab the remainder of the current line restOfLine :: m ByteString restOfLine = Strict.drop . fromIntegral . columnByte <$> position <*> line {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Lazy.StateT s m) where line = lift line {-# inlinable line #-} position = lift position {-# inlinable position #-} slicedWith f (Lazy.StateT m) = Lazy.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift restOfLine {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Strict.StateT s m) where line = lift line {-# inlinable line #-} position = lift position {-# inlinable position #-} slicedWith f (Strict.StateT m) = Strict.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift restOfLine {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (ReaderT e m) where line = lift line {-# inlinable line #-} position = lift position {-# inlinable position #-} slicedWith f (ReaderT m) = ReaderT $ slicedWith f . m {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift restOfLine {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.WriterT w m) where line = lift line {-# inlinable line #-} position = lift position {-# inlinable position #-} slicedWith f (Strict.WriterT m) = Strict.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift restOfLine {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.WriterT w m) where line = lift line {-# inlinable line #-} position = lift position {-# inlinable position #-} slicedWith f (Lazy.WriterT m) = Lazy.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift restOfLine {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.RWST r w s m) where line = lift line {-# inlinable line #-} position = lift 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 {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift restOfLine {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.RWST r w s m) where line = lift line {-# inlinable line #-} position = lift 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 {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift restOfLine {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (IdentityT m) where line = lift line {-# inlinable line #-} position = lift position {-# inlinable position #-} slicedWith f (IdentityT m) = IdentityT $ slicedWith f m {-# inlinable slicedWith #-} rend = lift rend {-# inlinable rend #-} restOfLine = lift 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) {-# inlinable sliced #-} -- | Grab a 'Caret' pointing to the current location. careting :: DeltaParsing m => m Caret careting = Caret <$> position <*> line {-# 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 {-# 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) {-# 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 {-# inlinable spanned #-} -- | Grab a fixit. fixiting :: DeltaParsing m => m Strict.ByteString -> m Fixit fixiting p = (\(r :~ s) -> Fixit s r) <$> spanned p {-# 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. class (DeltaParsing m, HasDelta d) => MarkParsing d m | m -> d where -- | mark the current location so it can be used in constructing a span, or -- for later seeking mark :: m d -- | Seek a previously marked location release :: d -> m () instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Lazy.StateT s m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Strict.StateT s m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (ReaderT e m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.WriterT w m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.WriterT w m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.RWST r w s m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.RWST r w s m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (IdentityT m) where mark = lift mark {-# inlinable mark #-} release = lift . release {-# inlinable release #-} trifecta-2.1/src/Text/Trifecta/Delta.hs0000644000000000000000000001636507346545000016222 0ustar0000000000000000{-# language CPP #-} {-# language DeriveDataTypeable #-} {-# language DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- A 'Delta' keeps track of the cursor position of the parser, so it can be -- referred to later, for example in error messages. ---------------------------------------------------------------------------- module Text.Trifecta.Delta ( Delta(..) , HasDelta(..) , HasBytes(..) , prettyDelta , nextTab , rewind , near , column , columnByte ) where #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Hashable 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 Data.Text.Prettyprint.Doc hiding (column, line') import GHC.Generics import Text.Trifecta.Util.Pretty class HasBytes t where bytes :: t -> Int64 instance HasBytes ByteString where bytes = fromIntegral . Strict.length instance (Measured v a, HasBytes v) => HasBytes (FingerTree v a) where bytes = bytes . measure -- | Since there are multiple ways to be at a certain location, 'Delta' captures -- all these alternatives as a single type. data Delta = Columns {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 -- ^ @ -- ( number of characters -- , number of bytes ) -- @ | Tab {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 -- ^ @ -- ( number of characters before the tab -- , number of characters after the tab -- , number of bytes ) -- @ | Lines {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 -- ^ @ -- ( number of newlines contained -- , number of characters since the last newline -- , number of bytes -- , number of bytes since the last newline ) -- @ | Directed !ByteString {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 {-# UNPACK #-} !Int64 -- ^ @ -- ( current file name -- , number of lines since the last line directive -- , number of characters since the last newline -- , number of bytes -- , number of bytes since the last newline ) -- @ deriving (Show, Data, Typeable, Generic) instance Eq Delta where (==) = (==) `on` bytes instance Ord Delta where compare = compare `on` bytes instance (HasDelta l, HasDelta r) => HasDelta (Either l r) where delta = either delta delta -- | Example: @file.txt:12:34@ 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 column t = case delta t of Columns c _ -> c Tab b a _ -> nextTab b + a Lines _ c _ _ -> c Directed _ _ c _ _ -> c {-# inlinable column #-} -- | Retrieve the byte offset within the current line from this 'Delta'. columnByte :: Delta -> Int64 columnByte (Columns _ b) = b columnByte (Tab _ _ b) = b columnByte (Lines _ _ _ b) = b columnByte (Directed _ _ _ _ b) = b {-# inlinable columnByte #-} instance HasBytes Delta where bytes (Columns _ b) = b bytes (Tab _ _ b) = b bytes (Lines _ _ b _) = b bytes (Directed _ _ _ b _) = b instance Hashable Delta instance Monoid Delta where mempty = Columns 0 0 mappend = (<>) instance Semigroup Delta where Columns c a <> Columns d b = Columns (c + d) (a + b) Columns c a <> Tab x y b = Tab (c + x) y (a + b) Columns _ a <> Lines l c t a' = Lines l c (t + a) a' Columns _ a <> Directed p l c t a' = Directed p l c (t + a) a' Lines l c t a <> Columns d b = Lines l (c + d) (t + b) (a + b) Lines l c t a <> Tab x y b = Lines l (nextTab (c + x) + y) (t + b) (a + b) Lines l _ t _ <> Lines m d t' b = Lines (l + m) d (t + t') b Lines _ _ t _ <> Directed p l c t' a = Directed p l c (t + t') a Tab x y a <> Columns d b = Tab x (y + d) (a + b) Tab x y a <> Tab x' y' b = Tab x (nextTab (y + x') + y') (a + b) Tab _ _ a <> Lines l c t a' = Lines l c (t + a ) a' Tab _ _ a <> Directed p l c t a' = Directed p l c (t + a ) a' Directed p l c t a <> Columns d b = Directed p l (c + d) (t + b ) (a + b) Directed p l c t a <> Tab x y b = Directed p l (nextTab (c + x) + y) (t + b ) (a + b) Directed p l _ t _ <> Lines m d t' b = Directed p (l + m) d (t + t') b Directed _ _ _ t _ <> Directed p l c t' b = Directed p l c (t + t') b -- | Increment a column number to the next tabstop. nextTab :: Int64 -> Int64 nextTab x = x + (8 - mod x 8) {-# 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 {-# inlinable rewind #-} -- | Should we show two things with a 'Delta' on the same line? -- -- >>> near (Columns 0 0) (Columns 5 5) -- True -- -- >>> near (Lines 1 0 1 0) (Lines 2 4 4 2) -- False near :: (HasDelta s, HasDelta t) => s -> t -> Bool near s t = rewind (delta s) == rewind (delta t) {-# inlinable near #-} class HasDelta t where delta :: t -> Delta instance HasDelta Delta where delta = id instance HasDelta Char where delta '\t' = Tab 0 0 1 delta '\n' = Lines 1 0 1 0 delta c | o <= 0x7f = Columns 1 1 | o <= 0x7ff = Columns 1 2 | o <= 0xffff = Columns 1 3 | otherwise = Columns 1 4 where o = fromEnum c instance HasDelta Word8 where delta 9 = Tab 0 0 1 delta 10 = Lines 1 0 1 0 delta n | n <= 0x7f = Columns 1 1 | n >= 0xc0 && n <= 0xf4 = Columns 1 1 | otherwise = Columns 0 1 instance HasDelta ByteString where delta = foldMap delta . unpack instance (Measured v a, HasDelta v) => HasDelta (FingerTree v a) where delta = delta . measure trifecta-2.1/src/Text/Trifecta/Highlight.hs0000644000000000000000000001206607346545000017072 0ustar0000000000000000{-# language CPP #-} {-# language OverloadedStrings #-} {-# language TemplateHaskell #-} #ifndef MIN_VERSION_lens #define MIN_VERSION_lens(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Text.Trifecta.Highlight ( Highlight , HighlightedRope(HighlightedRope) , HasHighlightedRope(..) , withHighlight , HighlightDoc(HighlightDoc) , HasHighlightDoc(..) , doc ) where import Control.Lens #if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710 hiding (Empty) #endif import Data.Foldable as F import Data.Int (Int64) import Data.List (sort) import Data.Semigroup import Data.Semigroup.Union import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal (color) import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty import Prelude hiding (head) 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 qualified Data.ByteString.Lazy.Char8 as L 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 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. data HighlightedRope = HighlightedRope { _ropeHighlights :: !(IM.IntervalMap Delta Highlight) , _ropeContent :: {-# UNPACK #-} !Rope } makeClassy ''HighlightedRope instance HasDelta HighlightedRope where delta = delta . _ropeContent instance HasBytes HighlightedRope where bytes = bytes . _ropeContent instance Semigroup HighlightedRope where HighlightedRope h bs <> HighlightedRope h' bs' = HighlightedRope (h `union` IM.offset (delta bs) h') (bs <> bs') instance Monoid HighlightedRope where mappend = (<>) mempty = HighlightedRope mempty mempty data Located a = a :@ {-# UNPACK #-} !Int64 infix 5 :@ instance Eq (Located a) where _ :@ m == _ :@ n = m == n instance Ord (Located a) where compare (_ :@ m) (_ :@ n) = compare m n instance ToMarkup HighlightedRope where toMarkup (HighlightedRope intervals r) = Html5.pre $ go 0 lbs effects where lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)] ln no = Html5.a ! name (toValue $ "line-" ++ show no) $ emptyMarkup effects = sort $ [ i | (Interval lo hi, tok) <- intersections mempty (delta r) intervals , i <- [ (leafMarkup "span" "" ! class_ (toValue $ show tok)) :@ bytes lo , preEscapedToHtml ("" :: String) :@ bytes hi ] ] ++ imap (\k i -> ln k :@ i) (L.elemIndices '\n' lbs) go _ cs [] = unsafeLazyByteString cs go b cs ((eff :@ eb) : es) | eb <= b = eff >> go b cs es | 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 -- | Represents a source file like an HsColour rendered document data HighlightDoc = HighlightDoc { _docTitle :: String , _docCss :: String -- href for the css file , _docContent :: HighlightedRope } makeClassy ''HighlightDoc -- | Generate an HTML document from a title and a 'HighlightedRope'. doc :: String -> HighlightedRope -> HighlightDoc doc t r = HighlightDoc t "trifecta.css" r instance ToMarkup HighlightDoc where toMarkup (HighlightDoc t css cs) = docTypeHtml $ do head $ do preEscapedToHtml ("\n" :: String) title $ toHtml t link ! rel "stylesheet" ! type_ "text/css" ! href (toValue css) body $ toHtml cs trifecta-2.1/src/Text/Trifecta/Parser.hs0000644000000000000000000003650507346545000016423 0ustar0000000000000000{-# 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-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Text.Trifecta.Parser ( Parser(..) , manyAccum -- * Feeding a parser more more input , Step(..) , feed , starve , stepParser , stepResult , stepIt -- * Parsing , runParser , parseFromFile , parseFromFileEx , parseString , parseByteString , parseTest ) where import Control.Applicative as Alternative import Control.Monad (MonadPlus(..), ap, join) import Control.Monad.IO.Class import qualified Control.Monad.Fail as Fail import Data.ByteString as Strict hiding (empty, snoc) import Data.ByteString.UTF8 as UTF8 import Data.Maybe (fromMaybe, isJust) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Reducer -- import Data.Sequence as Seq hiding (empty) import Data.Set as Set hiding (empty, toList) import Data.Text.Prettyprint.Doc 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.Trifecta.Combinators import Text.Trifecta.Delta as Delta 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 -- -- The first four arguments are behavior continuations: -- -- * epsilon success: the parser has consumed no input and has a result -- as well as a possible Err; the position and chunk are unchanged -- (see `pure`) -- -- * epsilon failure: the parser has consumed no input and is failing -- with the given Err; the position and chunk are unchanged (see -- `empty`) -- -- * committed success: the parser has consumed input and is yielding -- the result, set of expected strings that would have permitted this -- parse to continue, new position, and residual chunk to the -- continuation. -- -- * committed failure: the parser has consumed input and is failing with -- a given ErrInfo (user-facing error message) -- -- The remaining two arguments are -- -- * the current position -- -- * the chunk of input currently under analysis -- -- `Parser` is an `Alternative`; trifecta's backtracking behavior encoded as -- `<|>` is to behave as the leftmost parser which yields a value -- (regardless of any input being consumed) or which consumes input and -- fails. That is, a choice of parsers will only yield an epsilon failure -- if *all* parsers in the choice do. If that is not the desired behavior, -- see `try`, which turns a committed parser failure into an epsilon failure -- (at the cost of error information). newtype Parser a = Parser { unparser :: forall r. (a -> Err -> It Rope r) -> (Err -> It Rope r) -> (a -> Set String -> Delta -> ByteString -> It Rope r) -- committed success -> (ErrInfo -> It Rope r) -- committed err -> Delta -> ByteString -> It Rope r } instance Functor Parser where fmap f (Parser m) = Parser $ \ eo ee co -> m (eo . f) ee (co . f) {-# inlinable fmap #-} a <$ Parser m = Parser $ \ eo ee co -> m (\_ -> eo a) ee (\_ -> co a) {-# inlinable (<$) #-} instance Applicative Parser where pure a = Parser $ \ eo _ _ _ _ _ -> eo a mempty {-# inlinable pure #-} (<*>) = ap {-# inlinable (<*>) #-} instance Alternative Parser where empty = Parser $ \_ ee _ _ _ _ -> ee mempty {-# 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 {-# inlinable (<|>) #-} many p = Prelude.reverse <$> manyAccum (:) p {-# inlinable many #-} some p = (:) <$> p <*> Alternative.many p instance Semigroup a => Semigroup (Parser a) where (<>) = liftA2 (<>) {-# inlinable (<>) #-} instance (Semigroup a, Monoid a) => Monoid (Parser a) where mappend = (<>) {-# inlinable mappend #-} mempty = pure mempty {-# inlinable mempty #-} instance Monad Parser where return = pure {-# 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 -- error information with `<>` (\a e -> unparser (k a) (\b e' -> eo b (e <> e')) (\e' -> ee (e <> e')) co ce d bs) -- epsilon error: as given ee -- committed result: feed result to monadic continuation and... (\a es d' bs' -> unparser (k a) -- epsilon results are now committed results due to m consuming. -- -- epsilon success is now committed success at the new position -- (after m), yielding the result from (k a) and merging the -- expected sets (i.e. things that could have resulted in a longer -- parse) (\b e' -> co b (es <> _expected e') d' bs') -- epsilon failure is now a committed failure at the new position -- (after m); compute the error to display to the user (\e -> let errDoc = explain (renderingCaret d' bs') e { _expected = _expected e <> es } errDelta = _finalDeltas e in ce $ ErrInfo errDoc (d' : errDelta) ) -- committed behaviors as given; nothing exciting here co ce -- new position and remaining chunk after m d' bs') -- committed error, delta, and bytestring: as given ce d bs {-# inlinable (>>=) #-} (>>) = (*>) {-# inlinable (>>) #-} #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail {-# inlinable fail #-} #endif instance Fail.MonadFail Parser where fail s = Parser $ \ _ ee _ _ _ _ -> ee (failed s) {-# inlinable fail #-} instance MonadPlus Parser where mzero = empty {-# inlinable mzero #-} mplus = (<|>) {-# inlinable mplus #-} manyAccum :: (a -> [a] -> [a]) -> Parser a -> Parser [a] manyAccum f (Parser p) = Parser $ \eo _ co ce d bs -> let walk xs x es d' bs' = p (manyErr d' bs') (\e -> co (f x xs) (_expected e <> es) d' bs') (walk (f x xs)) ce d' bs' manyErr d' bs' _ e = ce (ErrInfo errDoc [d']) where errDoc = explain (renderingCaret d' bs') (e <> failed "'many' applied to a parser that accepted an empty string") in p (manyErr d bs) (eo []) (walk []) ce d bs liftIt :: It Rope a -> Parser a liftIt m = Parser $ \ eo _ _ _ _ _ -> do a <- m eo a mempty {-# inlinable liftIt #-} instance Parsing Parser where try (Parser m) = Parser $ \ eo ee co _ -> m eo ee co (\_ -> ee mempty) {-# 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 }) {-# inlinable () #-} skipMany p = () <$ manyAccum (\_ _ -> []) p {-# inlinable skipMany #-} unexpected s = Parser $ \ _ ee _ _ _ _ -> ee $ failed $ "unexpected " ++ s {-# inlinable unexpected #-} eof = notFollowedBy anyChar "end of input" {-# inlinable eof #-} notFollowedBy p = try (optional p >>= maybe (pure ()) (unexpected . show)) {-# inlinable notFollowedBy #-} instance Errable Parser where raiseErr e = Parser $ \ _ ee _ _ _ _ -> ee e {-# inlinable raiseErr #-} instance LookAheadParsing Parser where lookAhead (Parser m) = Parser $ \eo ee _ -> m eo ee (\a _ _ _ -> eo a mempty) {-# inlinable lookAhead #-} instance CharParsing Parser where satisfy f = Parser $ \ _ ee co _ d bs -> case UTF8.uncons $ Strict.drop (fromIntegral (columnByte d)) bs of Nothing -> ee (failed "unexpected EOF") Just (c, xs) | not (f c) -> ee mempty | Strict.null xs -> let !ddc = d <> delta c in join $ fillIt (co c mempty ddc (if c == '\n' then mempty else bs)) (co c mempty) ddc | otherwise -> co c mempty (d <> delta c) bs {-# inlinable satisfy #-} instance TokenParsing Parser instance DeltaParsing Parser where line = Parser $ \eo _ _ _ _ bs -> eo bs mempty {-# inlinable line #-} position = Parser $ \eo _ _ _ d _ -> eo d mempty {-# inlinable position #-} rend = Parser $ \eo _ _ _ d bs -> eo (rendered d bs) mempty {-# inlinable rend #-} slicedWith f p = do m <- position a <- p r <- position f a <$> liftIt (sliceIt m r) {-# inlinable slicedWith #-} instance MarkParsing Delta Parser where mark = position {-# inlinable mark #-} release d' = Parser $ \_ ee co _ d bs -> do mbs <- rewindIt d' case mbs of Just bs' -> co () mempty d' bs' Nothing | bytes d' == bytes (rewind d) + fromIntegral (Strict.length bs) -> if near d d' then co () mempty d' bs else co () mempty d' mempty | otherwise -> ee mempty -- | A 'Step' allows for incremental parsing, since the parser -- -- - can be done with a final result -- - have errored -- - can have yielded a partial result with possibly more to come data Step a = StepDone !Rope a -- ^ Parsing is done and has converted the 'Rope' to a final result | StepFail !Rope ErrInfo -- ^ Parsing the 'Rope' has failed with an error | StepCont !Rope (Result a) (Rope -> Step a) -- ^ The 'Rope' has been partially consumed and already yielded a 'Result', -- and if more input is provided, more results can be produced. -- -- One common scenario for this is to parse log files: after parsing a -- single line, that data can already be worked with, but there may be more -- lines to come. instance Show a => Show (Step a) where showsPrec d (StepDone r a) = showParen (d > 10) $ showString "StepDone " . showsPrec 11 r . showChar ' ' . showsPrec 11 a showsPrec d (StepFail r xs) = showParen (d > 10) $ showString "StepFail " . showsPrec 11 r . showChar ' ' . showsPrec 11 xs showsPrec d (StepCont r fin _) = showParen (d > 10) $ showString "StepCont " . showsPrec 11 r . showChar ' ' . showsPrec 11 fin . showString " ..." instance Functor Step where fmap f (StepDone r a) = StepDone r (f a) fmap _ (StepFail r xs) = StepFail r xs fmap f (StepCont r z k) = StepCont r (fmap f z) (fmap f . k) -- | Feed some additional input to a 'Step' to continue parsing a bit further. feed :: Reducer t Rope => t -> Step r -> Step r 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) {-# inlinable feed #-} -- | Assume all possible input has been given to the parser, execute it to yield -- a final result. starve :: Step a -> Result a starve (StepDone _ a) = Success a starve (StepFail _ xs) = Failure xs starve (StepCont _ z _) = z {-# inlinable starve #-} stepResult :: Rope -> Result a -> Step a stepResult r (Success a) = StepDone r a stepResult r (Failure xs) = StepFail r xs {-# 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') {-# inlinable stepIt #-} data Stepping a = EO a Err | EE Err | CO a (Set String) Delta ByteString | CE ErrInfo -- | Incremental parsing. A 'Step' can be supplied with new input using 'feed', -- the final 'Result' is obtained using 'starve'. stepParser :: Parser a -> Delta -- ^ Starting cursor position. Usually 'mempty' for the beginning of the file. -> Step a stepParser (Parser p) d0 = joinStep $ stepIt $ do bs0 <- fromMaybe mempty <$> rewindIt d0 go bs0 <$> p eo ee co ce d0 bs0 where eo a e = Pure (EO a e) ee e = Pure (EE e) co a es d' bs = Pure (CO a es d' bs) ce errInf = Pure (CE errInf) go :: ByteString -> Stepping a -> Result a go _ (EO a _) = Success a go bs0 (EE e) = Failure $ let errDoc = explain (renderingCaret d0 bs0) e in ErrInfo errDoc (d0 : _finalDeltas e) go _ (CO a _ _ _) = Success a go _ (CE e) = Failure e joinStep :: Step (Result a) -> Step a joinStep (StepDone r (Success a)) = StepDone r a 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) {-# 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 -- 'parseByteString'. runParser :: Reducer t Rope => Parser a -> Delta -- ^ Starting cursor position. Usually 'mempty' for the beginning of the file. -> t -> Result a runParser p d bs = starve $ feed bs $ stepParser p d {-# inlinable runParser #-} -- | @('parseFromFile' p filePath)@ runs a parser @p@ on the input read from -- @filePath@ using 'ByteString.readFile'. All diagnostic messages emitted over -- the course of the parse attempt are shown to the user on the console. -- -- > main = do -- > result <- parseFromFile numbers "digits.txt" -- > case result of -- > Nothing -> return () -- > Just a -> print $ sum a parseFromFile :: MonadIO m => Parser a -> String -> m (Maybe a) parseFromFile p fn = do result <- parseFromFileEx p fn case result of Success a -> return (Just a) Failure xs -> do liftIO $ renderIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> line' return Nothing -- | @('parseFromFileEx' p filePath)@ runs a parser @p@ on the input read from -- @filePath@ using 'ByteString.readFile'. Returns all diagnostic messages -- emitted over the course of the parse and the answer if the parse was -- successful. -- -- > main = do -- > result <- parseFromFileEx (many number) "digits.txt" -- > case result of -- > Failure xs -> displayLn xs -- > Success a -> print (sum a) parseFromFileEx :: MonadIO m => Parser a -> String -> m (Result a) parseFromFileEx p fn = do s <- liftIO $ Strict.readFile fn return $ parseByteString p (Directed (UTF8.fromString fn) 0 0 0 0) s -- | Fully parse a 'UTF8.ByteString' to a 'Result'. -- -- @parseByteString p delta i@ runs a parser @p@ on @i@. parseByteString :: Parser a -> Delta -- ^ Starting cursor position. Usually 'mempty' for the beginning of the file. -> UTF8.ByteString -> Result a parseByteString = runParser -- | Fully parse a 'String' to a 'Result'. -- -- @parseByteString p delta i@ runs a parser @p@ on @i@. parseString :: Parser a -> Delta -- ^ Starting cursor position. Usually 'mempty' for the beginning of the file. -> String -> Result a parseString = runParser parseTest :: (MonadIO m, Show a) => Parser a -> String -> m () parseTest p s = case parseByteString p mempty (UTF8.fromString s) of Failure xs -> liftIO $ renderIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> line' -- TODO: retrieve columns Success a -> liftIO (print a) trifecta-2.1/src/Text/Trifecta/Rendering.hs0000644000000000000000000004174107346545000017102 0ustar0000000000000000{-# language DeriveDataTypeable #-} {-# language DeriveGeneric #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-} {-# language TemplateHaskell #-} {-# language TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- The type for Lines will very likely change over time, to enable drawing -- lit up multi-character versions of control characters for @^Z@, @^[@, -- @<0xff>@, etc. This will make for much nicer diagnostics when -- working with protocols. -- ---------------------------------------------------------------------------- module Text.Trifecta.Rendering ( Rendering(Rendering) , HasRendering(..) , nullRendering , emptyRendering , prettyRendering , Source(..) , rendered , Renderable(..) , Rendered(..) , gutterEffects -- * Carets , Caret(..) , HasCaret(..) , Careted(..) , drawCaret , addCaret , caretEffects , renderingCaret -- * Spans , Span(..) , HasSpan(..) , Spanned(..) , spanEffects , drawSpan , addSpan -- * Fixits , Fixit(..) , HasFixit(..) , drawFixit , addFixit -- * Drawing primitives , Lines , draw , ifNear , (.#) ) where import Control.Applicative 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.Data import Data.Foldable import Data.Function (on) import Data.Hashable import Data.Int (Int64) import Data.List (groupBy) import Data.Maybe import Data.Text.Prettyprint.Doc hiding (column, line') import Data.Text.Prettyprint.Doc.Render.Terminal (color, bgColor, colorDull, bgColorDull) import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty import Data.Semigroup import Data.Semigroup.Reducer import GHC.Generics import Prelude as P hiding (span) import System.Console.ANSI import Text.Trifecta.Delta import Text.Trifecta.Util.Combinators import Text.Trifecta.Util.Pretty -- $setup -- -- >>> :set -XOverloadedStrings -- >>> import Data.Text.Prettyprint.Doc (unAnnotate) -- >>> import Data.ByteString (ByteString) -- >>> import Data.Monoid (mempty) -- >>> 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 AnsiStyle -> Doc AnsiStyle sgr xs0 = go (P.reverse xs0) where go [] = id 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 Foreground -> case i of Dull -> case c of 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 -> 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 -> 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 -> 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. type Lines = Array (Int,Int64) ([SGR], Char) -- | Remove a number of @(index, element)@ values from an @'Array'@. (///) :: Ix i => Array i e -> [(i, e)] -> Array i e a /// xs = a // P.filter (inRange (bounds a) . fst) xs grow :: Int -> Lines -> Lines grow y a | inRange (t,b) y = a | otherwise = array new [ (i, if inRange old i then a ! i else ([],' ')) | i <- range new ] where old@((t,lo),(b,hi)) = bounds a new = ((min t y,lo),(max b y,hi)) draw :: [SGR] -- ^ ANSI style to use -> Int -- ^ Line; 0 is at the top -> Int64 -- ^ Column; 0 is on the left -> String -- ^ Data to be written -> Lines -- ^ Canvas to draw on -> Lines draw _ _ _ "" a0 = a0 draw e y n xs a0 = gt $ lt (a /// out) where a = grow y a0 ((_,lo),(_,hi)) = bounds a out = P.zipWith (\i c -> ((y,i),(e,c))) [n..] xs lt | P.any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))]) | otherwise = id gt | P.any (\el -> snd (fst el) > hi) out = (// [((y,hi),(outOfRangeEffects e,'>'))]) | otherwise = id -- | A 'Rendering' is a canvas of text that output can be written to. data Rendering = Rendering { _renderingDelta :: !Delta -- ^ focus, the render will keep this visible , _renderingLineLen :: {-# UNPACK #-} !Int64 -- ^ actual line length , _renderingLineBytes :: {-# UNPACK #-} !Int64 -- ^ line length in bytes , _renderingLine :: Lines -> Lines , _renderingOverlays :: Delta -> Lines -> Lines } makeClassy ''Rendering instance Show Rendering where showsPrec d (Rendering p ll lb _ _) = showParen (d > 10) $ showString "Rendering " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showChar ' ' . showsPrec 11 lb . showString " ... ..." -- | Is the 'Rendering' empty? -- -- >>> nullRendering emptyRendering -- True -- -- >>> nullRendering exampleRendering -- False nullRendering :: Rendering -> Bool nullRendering (Rendering (Columns 0 0) 0 0 _ _) = True nullRendering _ = False -- | The empty 'Rendering', which contains nothing at all. -- -- >>> show (prettyRendering emptyRendering) -- "" emptyRendering :: Rendering emptyRendering = Rendering (Columns 0 0) 0 0 id (const id) instance Semigroup Rendering where -- an unprincipled hack Rendering (Columns 0 0) 0 0 _ f <> Rendering del len lb dc g = Rendering del len lb dc $ \d l -> f d (g d l) Rendering del len lb dc f <> Rendering _ _ _ _ g = Rendering del len lb dc $ \d l -> f d (g d l) instance Monoid Rendering where mappend = (<>) mempty = emptyRendering ifNear :: Delta -- ^ Position 1 -> (Lines -> Lines) -- ^ Modify the fallback result if the positions are 'near' each other -> Delta -- ^ Position 2 -> Lines -- ^ Fallback result if the positions are not 'near' each other -> Lines ifNear d f d' l | near d d' = f l | otherwise = l instance HasDelta Rendering where delta = _renderingDelta class Renderable t where render :: t -> Rendering instance Renderable Rendering where render = id class Source t where source :: t -> (Int64, Int64, Lines -> Lines) -- ^ @ -- ( Number of (padded) columns -- , number of bytes -- , line ) -- @ instance Source String where source s | P.elem '\n' s = (ls, bs, draw [] 0 0 s') | otherwise = ( ls + fromIntegral (P.length end), bs, draw [SetColor Foreground Vivid Blue, SetConsoleIntensity BoldIntensity] 0 ls end . draw [] 0 0 s') where end = "" s' = go 0 s bs = fromIntegral $ B.length $ UTF8.fromString $ P.takeWhile (/='\n') s ls = fromIntegral $ P.length s' go n ('\t':xs) = let t = 8 - mod n 8 in P.replicate t ' ' ++ go (n + t) xs go _ ('\n':_) = [] go n (x:xs) = x : go (n + 1) xs go _ [] = [] instance Source ByteString where source = source . UTF8.toString -- | create a drawing surface rendered :: Source s => Delta -> s -> Rendering rendered del s = case source s of (len, lb, dc) -> Rendering del len lb dc (\_ l -> l) (.#) :: (Delta -> Lines -> Lines) -> Rendering -> Rendering f .# Rendering d ll lb s g = Rendering d ll lb s $ \e l -> f e $ g e l 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 (P.head g)) (pretty (P.map snd g))) $ groupBy ((==) `on` fst) [ a ! (y,i) | i <- [lo..hi] ] window :: Int64 -> Int64 -> Int64 -> (Int64, Int64) window c l w | c <= w2 = (0, min w l) | c + w2 >= l = if l > w then (l-w, l) else (0 , w) | 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 instance Functor Rendered where fmap f (a :@ s) = f a :@ s instance HasDelta (Rendered a) where delta = delta . render instance HasBytes (Rendered a) where bytes = bytes . delta instance Comonad Rendered where extend f as@(_ :@ s) = f as :@ s extract (a :@ _) = a instance ComonadApply Rendered where (f :@ s) <@> (a :@ t) = f a :@ (s <> t) instance Foldable Rendered where foldMap f (a :@ _) = f a instance Traversable Rendered where traverse f (a :@ s) = (:@ s) <$> f a instance Renderable (Rendered a) where render (_ :@ s) = s -- | A 'Caret' marks a point in the input with a simple @^@ character. -- -- >>> 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,Typeable,Generic) class HasCaret t where caret :: Lens' t Caret instance HasCaret Caret where caret = id instance Hashable Caret -- | ANSI terminal style for rendering the caret. caretEffects :: [SGR] caretEffects = [SetColor Foreground Vivid Green] drawCaret :: Delta -> Delta -> Lines -> Lines drawCaret p = ifNear p $ draw caretEffects 1 (fromIntegral (column p)) "^" -- | Render a caret at a certain position in a 'Rendering'. addCaret :: Delta -> Rendering -> Rendering addCaret p r = drawCaret p .# r instance HasBytes Caret where bytes = bytes . delta instance HasDelta Caret where delta (Caret d _) = d instance Renderable Caret where render (Caret d bs) = addCaret d $ rendered d bs instance Reducer Caret Rendering where unit = render instance Semigroup Caret where a <> _ = a renderingCaret :: Delta -> ByteString -> Rendering renderingCaret d bs = addCaret d $ rendered d bs data Careted a = a :^ Caret deriving (Eq,Ord,Show,Data,Typeable,Generic) instance HasCaret (Careted a) where caret f (a :^ c) = (a :^) <$> f c instance Functor Careted where fmap f (a :^ s) = f a :^ s instance HasDelta (Careted a) where delta (_ :^ c) = delta c instance HasBytes (Careted a) where bytes (_ :^ c) = bytes c instance Comonad Careted where extend f as@(_ :^ s) = f as :^ s extract (a :^ _) = a instance ComonadApply Careted where (a :^ c) <@> (b :^ d) = a b :^ (c <> d) instance Foldable Careted where foldMap f (a :^ _) = f a instance Traversable Careted where traverse f (a :^ s) = (:^ s) <$> f a instance Renderable (Careted a) where render (_ :^ a) = render a instance Reducer (Careted a) Rendering where unit = render instance Hashable a => Hashable (Careted a) -- | ANSI terminal style to render spans with. spanEffects :: [SGR] spanEffects = [SetColor Foreground Dull Green] drawSpan :: Delta -- ^ Start of the region of interest -> Delta -- ^ End of the region of interest -> Delta -- ^ Currrent location -> Lines -- ^ 'Lines' to add the rendering to -> Lines drawSpan start end d a | nearLo && nearHi = go (column lo) (rep (max (column hi - column lo) 0) '~') a | nearLo = go (column lo) (rep (max (snd (snd (bounds a)) - column lo + 1) 0) '~') a | nearHi = go (-1) (rep (max (column hi + 1) 0) '~') a | otherwise = a where go = draw spanEffects 1 . fromIntegral lo = argmin bytes start end hi = argmax bytes start end nearLo = near lo d nearHi = near hi d rep = P.replicate . fromIntegral addSpan :: Delta -> Delta -> Rendering -> Rendering addSpan s e r = drawSpan s e .# r -- | A 'Span' marks a range of input characters. If 'Caret' is a point, then -- 'Span' is a line. -- -- >>> 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,Typeable,Generic) class HasSpan t where span :: Lens' t Span instance HasSpan Span where span = id instance Renderable Span where render (Span s e bs) = addSpan s e $ rendered s bs instance Semigroup Span where Span s _ b <> Span _ e _ = Span s e b instance Reducer Span Rendering where unit = render instance Hashable Span -- | 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) instance HasSpan (Spanned a) where span f (a :~ c) = (a :~) <$> f c instance Functor Spanned where fmap f (a :~ s) = f a :~ s instance Comonad Spanned where extend f as@(_ :~ s) = f as :~ s extract (a :~ _) = a instance ComonadApply Spanned where (a :~ c) <@> (b :~ d) = a b :~ (c <> d) instance Foldable Spanned where foldMap f (a :~ _) = f a instance Traversable Spanned where traverse f (a :~ s) = (:~ s) <$> f a instance Reducer (Spanned a) Rendering where unit = render instance Renderable (Spanned a) where render (_ :~ s) = render s instance Hashable a => Hashable (Spanned a) drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines drawFixit s e rpl d a = ifNear l (draw [SetColor Foreground Dull Blue] 2 (fromIntegral (column l)) rpl) d $ drawSpan s e d a where l = argmin bytes s e addFixit :: Delta -> Delta -> String -> Rendering -> Rendering addFixit s e rpl r = drawFixit s e rpl .# r -- | A 'Fixit' is a 'Span' with a suggestion. -- -- >>> 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) makeClassy ''Fixit instance HasSpan Fixit where span = fixitSpan instance Hashable Fixit instance Reducer Fixit Rendering where unit = render instance Renderable Fixit where render (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ rendered s bs trifecta-2.1/src/Text/Trifecta/Result.hs0000644000000000000000000001352207346545000016437 0ustar0000000000000000{-# 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-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- -- Results and Parse Errors ----------------------------------------------------------------------------- module Text.Trifecta.Result ( -- * Parse Results Result(..) , AsResult(..) , foldResult , _Success , _Failure -- * Parsing Errors , Err(..), HasErr(..), Errable(..) , ErrInfo(..) , explain , failed ) where 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) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Set as Set hiding (empty, toList) import Data.Text.Prettyprint.Doc as Pretty import Data.Text.Prettyprint.Doc.Render.Terminal as Pretty import Text.Trifecta.Delta as Delta import Text.Trifecta.Rendering import Text.Trifecta.Util.Pretty as Pretty data ErrInfo = ErrInfo { _errDoc :: Doc AnsiStyle , _errDeltas :: [Delta] } 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 AnsiStyle) , _footnotes :: [Doc AnsiStyle] , _expected :: Set String , _finalDeltas :: [Delta] } makeClassy ''Err 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) {-# inlinable (<>) #-} instance Monoid Err where mempty = Err Nothing [] mempty mempty {-# inlinable mempty #-} 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 {-# inlinable failed #-} -- | Convert a 'Rendering' of auxiliary information and an 'Err' into a 'Doc AnsiStyle', -- ready to be prettyprinted to the user. explain :: Rendering -> Err -> Doc AnsiStyle explain r (Err mm as es _) | Set.null es = report (withEx mempty) | isJust mm = report $ withEx $ Pretty.char ',' <+> expecting | otherwise = report expecting where now = spaceHack $ toList es spaceHack [""] = ["space"] spaceHack xs = List.filter (/= "") xs 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 raiseErr :: Err -> m a instance Monoid ErrInfo where mempty = ErrInfo mempty mempty mappend = (<>) instance Semigroup ErrInfo where ErrInfo xs d1 <> ErrInfo ys d2 = ErrInfo (vsep [xs, ys]) (max d1 d2) -- | The result of parsing. Either we succeeded or something went wrong. data Result a = Success a | Failure ErrInfo deriving (Show,Functor,Foldable,Traversable) -- | Fold over a 'Result' foldResult :: (ErrInfo -> b) -> (a -> b) -> Result a -> b foldResult f g r = case r of Failure e -> f e Success a -> g a -- | A 'Prism' that lets you embed or retrieve a 'Result' in a potentially larger type. class AsResult s t a b | s -> a, t -> b, s b -> t, t a -> s where _Result :: Prism s t (Result a) (Result b) instance AsResult (Result a) (Result b) a b where _Result = id {-# 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)) {-# 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)) {-# inlinable _Failure #-} instance Applicative Result where pure = Success {-# 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) {-# inlinable (<*>) #-} instance Alternative Result where Failure x <|> Failure y = Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y) Success a <|> Success _ = Success a Success a <|> Failure _ = Success a Failure _ <|> Success a = Success a {-# inlinable (<|>) #-} empty = Failure mempty {-# inlinable empty #-} instance Monad Result where return = pure Success a >>= m = m a Failure e >>= _ = Failure e trifecta-2.1/src/Text/Trifecta/Rope.hs0000644000000000000000000001402107346545000016061 0ustar0000000000000000{-# language BangPatterns #-} {-# language CPP #-} {-# language DeriveDataTypeable #-} {-# language DeriveGeneric #-} {-# language FlexibleInstances #-} {-# language MultiParamTypeClasses #-} {-# language TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- A rope is a data strucure to efficiently store and manipulate long strings. -- Wikipedia provides a nice overview: -- ---------------------------------------------------------------------------- module Text.Trifecta.Rope ( Rope(..) , rope , ropeBS , Strand(..) , strand , strands , grabRest , grabLine ) where import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.UTF8 as UTF8 import Data.Data import Data.FingerTree as FingerTree import Data.Foldable (toList) import Data.Hashable #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Reducer import GHC.Generics import Text.Trifecta.Delta import Text.Trifecta.Util.Combinators as Util -- $setup -- -- >>> :set -XOverloadedStrings -- >>> import Data.Monoid ((<>)) -- >>> import qualified Data.ByteString.UTF8 as Strict -- >>> import qualified Data.ByteString.Lazy.UTF8 as Lazy -- 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) -- | Construct a single 'Strand' out of a 'ByteString'. strand :: ByteString -> Strand strand bs = Strand bs (delta bs) instance Measured Delta Strand where measure (Strand _ s) = delta s measure (Skipping d) = d instance Hashable Strand instance HasDelta Strand where delta = measure instance HasBytes Strand where bytes (Strand _ d) = bytes d bytes _ = 0 data Rope = Rope !Delta !(FingerTree Delta Strand) deriving Show rope :: FingerTree Delta Strand -> Rope rope r = Rope (measure r) r -- | Construct a 'Rope' out of a single 'ByteString' strand. ropeBS :: ByteString -> Rope ropeBS = rope . singleton . strand strands :: Rope -> FingerTree Delta Strand strands (Rope _ r) = r -- | Grab the entire rest of the input 'Rope', starting at an initial offset, or -- return a default if we’re already at or beyond the end. Also see 'grabLine'. -- -- Extract a suffix of a certain length from the input: -- -- >>> grabRest (delta ("Hello " :: ByteString)) (ropeBS "Hello World\nLorem") Nothing (\x y -> Just (x, Lazy.toString y)) -- Just (Columns 6 6,"World\nLorem") -- -- Same deal, but over multiple strands: -- -- >>> grabRest (delta ("Hel" :: ByteString)) (ropeBS "Hello" <> ropeBS "World") Nothing (\x y -> Just (x, Lazy.toString y)) -- Just (Columns 3 3,"loWorld") -- -- When the offset is too long, fall back to a default: -- -- >>> grabRest (delta ("OffetTooLong" :: ByteString)) (ropeBS "Hello") Nothing (\x y -> Just (x, Lazy.toString y)) -- Nothing grabRest :: Delta -- ^ Initial offset -> Rope -- ^ Input -> r -- ^ Default value if there is no input left -> (Delta -> Lazy.ByteString -> r) -- ^ If there is some input left, create an @r@ out of the data from the -- initial offset until the end -> r grabRest offset input failure success = trim (delta l) (bytes offset - bytes l) (toList r) where trim offset' 0 (Strand str _ : xs) = go offset' str xs trim _ k (Strand str _ : xs) = go offset (Strict.drop (fromIntegral k) str) xs trim offset' k (Skipping p : xs) = trim (offset' <> p) k xs trim _ _ [] = failure go offset' str strands' = success offset' (Lazy.fromChunks (str : [ a | Strand a _ <- strands' ])) (l, r) = splitRopeAt offset input -- | Split the rope in two halves, given a 'Delta' offset from the beginning. splitRopeAt :: Delta -> Rope -> (FingerTree Delta Strand, FingerTree Delta Strand) splitRopeAt splitPos = FingerTree.split (\pos -> bytes pos > bytes splitPos) . strands -- | Grab the rest of the line at a certain offset in the input 'Rope', or -- return a default if there is no newline left in the input. Also see -- 'grabRest'. -- -- >>> grabLine (delta ("Hello " :: ByteString)) (ropeBS "Hello" <> ropeBS " World\nLorem") Nothing (\x y -> Just (x, Strict.toString y)) -- Just (Columns 6 6,"World\n") grabLine :: Delta -- ^ Initial offset -> Rope -- ^ Input -> r -- ^ Default value if there is no input left -> (Delta -> Strict.ByteString -> r) -- ^ If there is some input left, create an @r@ out of the data from the -- initial offset until the end of the line -> r grabLine offset input failure success = grabRest offset input failure (\d -> success d . Util.fromLazy . Util.takeLine) instance HasBytes Rope where bytes = bytes . measure instance HasDelta Rope where delta = measure instance Measured Delta Rope where measure (Rope s _) = s instance Monoid Rope where mempty = Rope mempty mempty mappend = (<>) instance Semigroup Rope where Rope mx x <> Rope my y = Rope (mx <> my) (x `mappend` y) instance Reducer Rope Rope where unit = id instance Reducer Strand Rope where unit s = rope (FingerTree.singleton s) cons s (Rope mt t) = Rope (delta s `mappend` mt) (s <| t) snoc (Rope mt t) !s = Rope (mt `mappend` delta s) (t |> s) instance Reducer Strict.ByteString Rope where unit = unit . strand cons = cons . strand snoc r = snoc r . strand instance Reducer [Char] Rope where unit = unit . strand . UTF8.fromString cons = cons . strand . UTF8.fromString snoc r = snoc r . strand . UTF8.fromString trifecta-2.1/src/Text/Trifecta/Tutorial.hs0000644000000000000000000000541607346545000016767 0ustar0000000000000000-- | This module provides a short introduction to get users started using -- Trifecta. The key takeaway message is that it’s not harder, or even much -- different, from using other parser libraries, so for users familiar with one -- of the many Parsecs should feel right at home. -- -- __The source of this file is written in a literate style__, and can be read -- top-to-bottom. module Text.Trifecta.Tutorial where import Control.Applicative import Text.Trifecta -- | First, we import Trifecta itself. It only the core parser definitions and -- instances. Since Trifecta on its own is just the parser and a handful of -- instances; the bulk of the utility functions is actually from a separate -- package, /parsers/, that provides the usual parsing functions like -- 'manyTill', 'between', and so on. The idea behind the /parsers/ package is -- that most parser libraries define the same generic functions, so they were -- put into their own package to be shared. Trifecta reexports these -- 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 :-)" -- | In order to keep things minimal, we define a very simple language for -- arithmetic expressions. data Expr = Add Expr Expr -- ^ expr + expr | Lit Integer -- ^ 1, 2, -345, … deriving (Show) -- | The parser is straightforward: there are literal integers, and -- parenthesized additions. We require parentheses in order to keep the example -- super simple as to not worry about operator precedence. -- -- It is useful to use /tokenizing/ functions to write parsers. Roughly -- speaking, these automatically skip trailing whitespace on their own, so that -- the parser isn’t cluttered with 'skipWhitespace' calls. 'symbolic' for -- example parses a 'Char' and then skips trailing whitespace; there is also the -- more primitive 'char' function that just parses its argument and nothing -- else. parseExpr :: Parser Expr parseExpr = parseAdd <|> parseLit where parseAdd = parens $ do x <- parseExpr _ <- symbolic '+' y <- parseExpr pure (Add x y) parseLit = Lit <$> integer -- | We can now use our parser to convert a 'String' to an 'Expr', -- -- @ -- parseString parseExpr mempty "(1 + (2 + 3))" -- @ -- -- > Success (Add (Lit 1) (Add (Lit 2) (Lit 3))) -- -- When we provide ill-formed input, we get a nice error message with an arrow -- to the location where the error occurred: -- -- @ -- parseString parseExpr mempty "(1 + 2 + 3))" -- @ -- -- > (interactive):1:8: error: expected: ")" -- > 1 | (1 + 2 + 3)) -- > | ^ examples :: docDummy examples = error "Haddock dummy for documentation" trifecta-2.1/src/Text/Trifecta/Util/0000755000000000000000000000000007346545000015537 5ustar0000000000000000trifecta-2.1/src/Text/Trifecta/Util/Combinators.hs0000644000000000000000000000232307346545000020353 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Text.Trifecta.Util.Combinators ( argmin , argmax -- * ByteString conversions , fromLazy , toLazy , takeLine , (<$!>) ) where import Data.ByteString as Strict import Data.ByteString.Lazy as Lazy argmin :: Ord b => (a -> b) -> a -> a -> a argmin f a b | f a <= f b = a | otherwise = b {-# INLINE argmin #-} argmax :: Ord b => (a -> b) -> a -> a -> a argmax f a b | f a > f b = a | otherwise = b {-# INLINE argmax #-} fromLazy :: Lazy.ByteString -> Strict.ByteString fromLazy = Strict.concat . Lazy.toChunks toLazy :: Strict.ByteString -> Lazy.ByteString toLazy = Lazy.fromChunks . return takeLine :: Lazy.ByteString -> Lazy.ByteString takeLine s = case Lazy.elemIndex 10 s of Just i -> Lazy.take (i + 1) s Nothing -> s infixl 4 <$!> (<$!>) :: Monad m => (a -> b) -> m a -> m b f <$!> m = do a <- m return $! f a trifecta-2.1/src/Text/Trifecta/Util/IntervalMap.hs0000644000000000000000000002144707346545000020325 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} #ifndef MIN_VERSION_lens #define MIN_VERSION_lens(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.IntervalMap -- Copyright : (c) Edward Kmett 2011-2019 -- (c) Ross Paterson 2008 -- License : BSD-style -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable (MPTCs, type families, functional dependencies) -- -- Interval maps implemented using the 'FingerTree' type, following -- section 4.8 of -- -- * Ralf Hinze and Ross Paterson, -- \"Finger trees: a simple general-purpose data structure\", -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. -- -- -- An amortized running time is given for each operation, with /n/ -- referring to the size of the priority queue. These bounds hold even -- in a persistent (shared) setting. -- -- /Note/: Many of these operations have the same names as similar -- operations on lists in the "Prelude". The ambiguity may be resolved -- using either qualification or the @hiding@ clause. -- -- Unlike "Data.IntervalMap.FingerTree", this version sorts things so -- that the largest interval from a given point comes first. This way -- if you have nested intervals, you get the outermost interval before -- the contained intervals. ----------------------------------------------------------------------------- module Text.Trifecta.Util.IntervalMap ( -- * Intervals Interval(..) -- * Interval maps , IntervalMap(..), singleton, insert -- * Searching , search, intersections, dominators -- * Prepending an offset onto every interval in the map , offset -- * The result monoid , IntInterval(..) , 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 Data.FingerTree (FingerTree, Measured (..), ViewL (..), (<|), (><)) import qualified Data.FingerTree as FT #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Reducer import Data.Semigroup.Union ---------------------------------- -- 4.8 Application: interval trees ---------------------------------- -- | A closed interval. The lower bound should be less than or equal -- to the higher bound. data Interval v = Interval { low :: v, high :: v } deriving Show instance Ord v => Semigroup (Interval v) where Interval a b <> Interval c d = Interval (min a c) (max b d) -- assumes the monoid and ordering are compatible. instance (Ord v, Monoid v) => Reducer v (Interval v) where unit v = Interval v v cons v (Interval a b) = Interval (v `mappend` a) (v `mappend` b) snoc (Interval a b) v = Interval (a `mappend` v) (b `mappend` v) instance Eq v => Eq (Interval v) where Interval a b == Interval c d = a == c && d == b instance Ord v => Ord (Interval v) where compare (Interval a b) (Interval c d) = case compare a c of LT -> LT EQ -> compare d b -- reversed to put larger intervals first GT -> GT instance Functor Interval where fmap f (Interval a b) = Interval (f a) (f b) instance Foldable Interval where foldMap f (Interval a b) = f a `mappend` f b instance Traversable Interval where traverse f (Interval a b) = Interval <$> f a <*> f b data Node v a = Node (Interval v) a instance Functor (Node v) where fmap f (Node i x) = Node i (f x) instance 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 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 itraverse f (Node i x) = Node i <$> f i x -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v instance Ord v => Monoid (IntInterval v) where mempty = NoInterval mappend = (<>) instance Ord v => Semigroup (IntInterval v) where NoInterval <> i = i i <> NoInterval = i IntInterval _ hi1 <> IntInterval int2 hi2 = IntInterval int2 (max hi1 hi2) instance Ord v => Measured (IntInterval v) (Node v a) where measure (Node i _) = IntInterval i (high i) -- | Map of closed intervals, possibly with duplicates. -- The 'Foldable' and 'Traversable' instances process the intervals in -- lexicographical order. newtype IntervalMap v a = IntervalMap { runIntervalMap :: FingerTree (IntInterval v) (Node v a) } -- ordered lexicographically by interval instance Functor (IntervalMap v) where fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) instance FunctorWithIndex (Interval v) (IntervalMap v) where imap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (imap f) t) instance Foldable (IntervalMap v) where foldMap f (IntervalMap t) = foldMap (foldMap f) t instance FoldableWithIndex (Interval v) (IntervalMap v) where ifoldMap f (IntervalMap t) = foldMap (ifoldMap f) t instance Traversable (IntervalMap v) where traverse f (IntervalMap t) = IntervalMap <$> FT.unsafeTraverse (traverse f) t instance TraversableWithIndex (Interval v) (IntervalMap v) where itraverse f (IntervalMap t) = IntervalMap <$> FT.unsafeTraverse (itraverse f) t instance Ord v => Measured (IntInterval v) (IntervalMap v a) where measure (IntervalMap m) = measure m largerError :: a largerError = error "Text.Trifecta.IntervalMap.larger: the impossible happened" -- | /O(m log (n/\//m))/. Merge two interval maps. -- The map may contain duplicate intervals; entries with equal intervals -- are kept in the original order. instance Ord v => HasUnion (IntervalMap v a) where union (IntervalMap xs) (IntervalMap ys) = IntervalMap (merge1 xs ys) where merge1 as bs = case FT.viewl as of EmptyL -> bs a@(Node i _) :< as' -> l >< a <| merge2 as' r where (l, r) = FT.split larger bs larger (IntInterval k _) = k >= i larger _ = largerError merge2 as bs = case FT.viewl bs of EmptyL -> as b@(Node i _) :< bs' -> l >< b <| merge1 r bs' where (l, r) = FT.split larger as larger (IntInterval k _) = k >= i larger _ = largerError instance Ord v => HasUnion0 (IntervalMap v a) where empty = IntervalMap FT.empty instance Ord v => Monoid (IntervalMap v a) where mempty = empty mappend = (<>) instance Ord v => Semigroup (IntervalMap v a) where (<>) = union -- | /O(n)/. Add a delta to each interval in the map offset :: (Ord v, Monoid v) => v -> IntervalMap v a -> IntervalMap v a offset v (IntervalMap m) = IntervalMap $ FT.fmap' (\(Node (Interval lo hi) a) -> Node (Interval (mappend v lo) (mappend v hi)) a) m -- | /O(1)/. Interval map with a single entry. singleton :: Ord v => Interval v -> a -> IntervalMap v a singleton i x = IntervalMap (FT.singleton (Node i x)) -- | /O(log n)/. Insert an interval into a map. -- The map may contain duplicate intervals; the new entry will be inserted -- before any existing entries for the same interval. insert :: Ord v => v -> v -> a -> IntervalMap v a -> IntervalMap v a insert lo hi _ m | lo > hi = m insert lo hi x (IntervalMap t) = IntervalMap (l >< Node i x <| r) where i = Interval lo hi (l, r) = FT.split larger t larger (IntInterval k _) = k >= i larger _ = largerError -- | /O(k log (n/\//k))/. All intervals that contain the given interval, -- in lexicographical order. dominators :: Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)] dominators i j = intersections j i -- | /O(k log (n/\//k))/. All intervals that contain the given point, -- in lexicographical order. search :: Ord v => v -> IntervalMap v a -> [(Interval v, a)] search p = intersections p p -- | /O(k log (n/\//k))/. All intervals that intersect with the given -- interval, in lexicographical order. intersections :: Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)] intersections lo hi (IntervalMap t) = matches (FT.takeUntil (greater hi) t) where matches xs = case FT.viewl (FT.dropUntil (atleast lo) xs) of EmptyL -> [] Node i x :< xs' -> (i, x) : matches xs' atleast :: Ord v => v -> IntInterval v -> Bool atleast k (IntInterval _ hi) = k <= hi atleast _ _ = False greater :: Ord v => v -> IntInterval v -> Bool greater k (IntInterval i _) = low i > k greater _ _ = False fromList :: Ord v => [(v, v, a)] -> IntervalMap v a fromList = foldr ins empty where ins (lo, hi, n) = insert lo hi n trifecta-2.1/src/Text/Trifecta/Util/It.hs0000644000000000000000000001702307346545000016452 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.It -- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- harder, better, faster, stronger... ---------------------------------------------------------------------------- module Text.Trifecta.Util.It ( It(Pure, It) , needIt , wantIt , simplifyIt , foldIt , runIt , fillIt , rewindIt , 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 import Text.Trifecta.Delta import Text.Trifecta.Rope import Text.Trifecta.Util.Combinators as Util -- $setup -- >>> import Control.Comonad (extract) -- >>> import Data.ByteString as Strict -- >>> import Text.Trifecta.Delta -- >>> import Text.Trifecta.Util.It -- | @'It'@ is an -- that can produce partial results. -- -- @'It' r a@ consumes a feed of @r@s and produces @a@s on the way. New values -- can be fed using @'simplifyIt'@, the current (partial or final) result is -- extracted using @'extract'@. -- -- >>> let keepIt a = Pure a -- >>> let replaceIt a = It a replaceIt -- -- >>> extract (keepIt 0) -- 0 -- -- >>> extract (replaceIt 0) -- 0 -- -- >>> extract (simplifyIt (keepIt 0) 5) -- 0 -- -- >>> extract (simplifyIt (replaceIt 0) 5) -- 5 data It r a = Pure a -- ^ Final result, rest of the feed is discarded | It a (r -> It r a) -- ^ Intermediate result, consumed values produce new results instance Show a => Show (It r a) where showsPrec d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a showsPrec d (It a _) = showParen (d > 10) $ showString "It " . showsPrec 11 a . showString " ..." instance Functor (It r) where fmap f (Pure a) = Pure $ f a fmap f (It a k) = It (f a) $ fmap f . k instance Profunctor It where rmap = fmap lmap _ (Pure a) = Pure a lmap f (It a g) = It a (lmap f . g . f) instance Applicative (It r) where 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 <*> It a ka = It (f a) $ \r -> kf r <*> ka r indexIt :: It r a -> r -> a indexIt (Pure a) _ = a indexIt (It _ k) r = extract (k r) -- | Feed a value to 'It', obtaining a new (partial or final) result. simplifyIt :: It r a -> r -> It r a simplifyIt (It _ k) r = k r simplifyIt pa _ = pa instance Monad (It r) where return = pure Pure a >>= f = f a It a k >>= f = It (extract (f a)) $ \r -> case k r of It a' k' -> It (indexIt (f a') r) $ k' >=> f Pure a' -> simplifyIt (f a') r instance ComonadApply (It r) where (<@>) = (<*>) -- | 'It' is a cofree comonad instance Comonad (It r) where duplicate p@Pure{} = Pure p duplicate p@(It _ k) = It p (duplicate . k) extend f p@Pure{} = Pure (f p) extend f p@(It _ k) = It (f p) (extend f . k) extract (Pure a) = a extract (It a _) = a -- | Consumes input until a value can be produced. -- -- >>> :{ -- let needTen = needIt 0 (\n -> if n < 10 then Nothing else Just n) :: It Int Int -- :} -- -- >>> extract needTen -- 0 -- -- >>> extract (simplifyIt needTen 5) -- 0 -- -- >>> extract (simplifyIt needTen 11) -- 11 -- -- >>> extract (simplifyIt (simplifyIt (simplifyIt needTen 5) 11) 15) -- 11 needIt :: a -- ^ Initial result -> (r -> Maybe a) -- ^ Produce a result if possible -> It r a needIt z f = k where k = It z $ \r -> case f r of Just a -> Pure a Nothing -> k -- | Consumes input and produces partial results until a condition is met. -- Unlike 'needIt', partial results are already returned when the condition is -- not fulfilled yet. -- -- > >>> :{ -- > let wantTen :: It Int Int -- > wantTen = wantIt 0 (\n -> (# n >= 10, n #)) -- > :} -- -- > >>> extract wantTen -- > 0 -- -- > >>> extract (simplifyIt wantTen 5) -- > 5 -- -- > >>> extract (simplifyIt wantTen 11) -- > 11 -- -- > >>> extract (simplifyIt (simplifyIt (simplifyIt wantTen 5) 11) 15) -- > 11 wantIt :: a -- ^ Initial result -> (r -> (# Bool, a #)) -- ^ Produce a partial or final result -> It r a wantIt z f = It z k where k r = case f r of (# False, a #) -> It a k (# True, a #) -> Pure a -- | The generalized fold (Böhm-Berarducci decoding) over 'It r a'. -- -- 'foldIt' satisfies the property: -- -- @foldIt Pure It = id@ foldIt :: (a -> o) -> (a -> (r -> o) -> o) -> It r a -> o foldIt p _ (Pure a) = p a foldIt p i (It a k) = i a (\r -> foldIt p i (k r)) -- | Scott decoding of 'It r a'. -- -- The scott decoding is similar to the generalized fold over a data type, but -- leaves the recursion step to the calling function. -- -- 'runIt' satiesfies the property: -- -- @runIt Pure It = id@ -- -- See also the Scott decoding of lists: -- -- @runList :: (a -> [a] -> b) -> b -> [a] -> b@ -- -- and compare it with 'foldr' (the Böhm-Berarducci decoding for lists): -- -- @foldr :: (a -> b -> b) -> b -> [a] -> b@ runIt :: (a -> o) -> (a -> (r -> It r a) -> o) -> It r a -> o runIt p _ (Pure a) = p a runIt _ i (It a k) = i a k -- * Rope specifics -- | Given a position, go there, and grab the rest of the line forward from that -- point. -- -- >>> :set -XOverloadedStrings -- >>> let secondLine = fillIt Nothing (const Just) (delta ("foo\nb" :: Strict.ByteString)) -- -- >>> extract secondLine -- Nothing -- -- >>> extract (simplifyIt secondLine (ropeBS "foo")) -- Nothing -- -- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar")) -- Just "ar" -- -- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar\nbaz")) -- Just "ar\n" fillIt :: r -> (Delta -> Strict.ByteString -> r) -> Delta -> It Rope r fillIt kf ks n = wantIt kf $ \r -> (# bytes n < bytes (rewind (delta r)) , grabLine n r kf ks #) -- | Return the text of the line that contains a given position -- -- >>> :set -XOverloadedStrings -- >>> let secondLine = rewindIt (delta ("foo\nb" :: Strict.ByteString)) -- -- >>> extract secondLine -- Nothing -- -- >>> extract (simplifyIt secondLine (ropeBS "foo")) -- Nothing -- -- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar")) -- Just "bar" -- -- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar\nbaz")) -- Just "bar\n" rewindIt :: Delta -> It Rope (Maybe Strict.ByteString) rewindIt n = wantIt Nothing $ \r -> (# bytes n < bytes (rewind (delta r)) , grabLine (rewind n) r Nothing $ const Just #) -- | Return the text between two offsets. -- -- >>> :set -XOverloadedStrings -- >>> let secondLine = sliceIt (delta ("foo\n" :: Strict.ByteString)) (delta ("foo\nbar\n" :: Strict.ByteString)) -- -- >>> extract secondLine -- "" -- -- >>> extract (simplifyIt secondLine (ropeBS "foo")) -- "" -- -- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar")) -- "bar" -- -- >>> extract (simplifyIt secondLine (ropeBS "foo\nbar\nbaz")) -- "bar\n" sliceIt :: Delta -> Delta -> It Rope Strict.ByteString sliceIt !i !j = wantIt mempty $ \r -> (# bj < bytes (rewind (delta r)) , grabRest i r mempty $ const $ Util.fromLazy . Lazy.take (fromIntegral (bj - bi)) #) where bi = bytes i bj = bytes j trifecta-2.1/src/Text/Trifecta/Util/Pretty.hs0000644000000000000000000000265707346545000017374 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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 #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal import Data.Text.Prettyprint.Doc.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 trifecta-2.1/tests/0000755000000000000000000000000007346545000012510 5ustar0000000000000000trifecta-2.1/tests/QuickCheck.hs0000644000000000000000000000435107346545000015061 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main ( main ) where 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 import Text.Parser.Combinators import Text.Trifecta.Parser import Text.Trifecta.Result import System.Exit -- -------------------------------------------------------------------------- -- -- Main main :: IO () main = mapM Q.quickCheckResult tests >>= \x -> case filter (not . passed) x of [] -> exitSuccess _ -> exitFailure where passed Q.Success{} = True passed _ = False -- -------------------------------------------------------------------------- -- -- Tests tests :: [Q.Property] tests = [ Q.property prop_fail , Q.property prop_succeed , Q.property prop_notFollowedBy0 , Q.property prop_notFollowedBy1 , Q.property prop_notFollowedBy2 , Q.property prop_notFollowedBy3 ] -- -------------------------------------------------------------------------- -- -- Properties prop_fail :: String -> Bool prop_fail = isLeft . parse (fail "fail" :: Parser ()) prop_succeed :: String -> Bool prop_succeed = isRight . parse (mempty :: Parser ()) prop_notFollowedBy0 :: Char -> Char -> Bool prop_notFollowedBy0 x y = either (\_ -> x == y) (/= y) $ parse (notFollowedBy (char y) *> anyChar) [x] prop_notFollowedBy1 :: Char -> Bool prop_notFollowedBy1 x = either (\_ -> x == x) (/= x) $ parse (notFollowedBy (char x) *> anyChar) [x] prop_notFollowedBy2 :: String -> Char -> Bool prop_notFollowedBy2 x y = isLeft $ parse (anyChar *> notFollowedBy (char y) *> char y) x prop_notFollowedBy3 :: Char -> Bool prop_notFollowedBy3 x = isRight $ parse (notFollowedBy (char x) <|> char x *> pure ()) [x] -- -------------------------------------------------------------------------- -- -- Utils parse :: Parser a -> String -> Either String a 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 trifecta-2.1/tests/doctests.hs0000644000000000000000000000147207346545000014700 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 trifecta-2.1/trifecta.cabal0000644000000000000000000000757607346545000014152 0ustar0000000000000000name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging version: 2.1 license: BSD3 cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/trifecta/ bug-reports: http://github.com/ekmett/trifecta/issues copyright: Copyright (C) 2010-2017 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 . For example: . <> . build-type: Custom tested-with: GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.1 extra-doc-files: images/*.png extra-source-files: examples/*.hs examples/LICENSE examples/rfc2616/*.hs examples/RFC2616.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 Text.Trifecta.Combinators Text.Trifecta.Delta Text.Trifecta.Highlight Text.Trifecta.Parser Text.Trifecta.Rendering Text.Trifecta.Result Text.Trifecta.Rope Text.Trifecta.Tutorial Text.Trifecta.Util.IntervalMap Text.Trifecta.Util.It other-modules: Text.Trifecta.Util.Combinators Text.Trifecta.Util.Pretty build-depends: ansi-terminal >= 0.6 && < 0.11, array >= 0.3.0.2 && < 0.6, base >= 4.7 && < 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, ghc-prim, hashable >= 1.2.1 && < 1.4, lens >= 4.0 && < 5, mtl >= 2.0.1 && < 2.3, parsers >= 0.12.1 && < 1, prettyprinter >= 1.2 && < 2, prettyprinter-ansi-terminal >= 1.1 && < 2, 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 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 if !impl(ghc >= 8.8) ghc-options: -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 test-suite quickcheck type: exitcode-stdio-1.0 main-is: QuickCheck.hs default-language: Haskell2010 build-depends: base == 4.*, parsers, QuickCheck, trifecta ghc-options: -Wall -threaded hs-source-dirs: tests