trifecta 1.7.1.1 → 2
raw patch · 24 files changed
+1090/−412 lines, 24 filesdep ~ansi-terminaldep ~basedep ~containers
Dependency ranges changed: ansi-terminal, base, containers, hashable
Files
- .travis.yml +131/−73
- CHANGELOG.markdown +7/−1
- LICENSE +1/−1
- examples/LICENSE +33/−0
- examples/Main.hs +7/−0
- examples/RFC2616.hs +0/−71
- examples/Spec.hs +19/−0
- examples/rfc2616/RFC2616.hs +71/−0
- examples/trifecta-examples.cabal +62/−0
- src/Text/Trifecta.hs +6/−5
- src/Text/Trifecta/Combinators.hs +27/−19
- src/Text/Trifecta/Delta.hs +70/−23
- src/Text/Trifecta/Highlight.hs +3/−2
- src/Text/Trifecta/Instances.hs +2/−2
- src/Text/Trifecta/Parser.hs +110/−54
- src/Text/Trifecta/Rendering.hs +125/−62
- src/Text/Trifecta/Result.hs +45/−27
- src/Text/Trifecta/Rope.hs +96/−27
- src/Text/Trifecta/Tutorial.hs +71/−0
- src/Text/Trifecta/Util/Combinators.hs +1/−1
- src/Text/Trifecta/Util/IntervalMap.hs +15/−14
- src/Text/Trifecta/Util/It.hs +163/−17
- tests/QuickCheck.hs +1/−1
- trifecta.cabal +24/−12
.travis.yml view
@@ -1,98 +1,156 @@+# This Travis job script has been generated by a script via+#+# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project'+#+# For more information, see https://github.com/hvr/multi-ghc-travis+# language: c sudo: false +git:+ submodules: false # whether to recursively clone submodules++notifications:+ irc:+ channels:+ - "irc.freenode.org#haskell-lens"+ skip_join: true+ template:+ - "\x0313trifecta\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"+ cache: directories:- - $HOME/.cabsnap - $HOME/.cabal/packages+ - $HOME/.cabal/store before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar+ # remove files that are regenerated by 'cabal update'+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $HOME/.cabal/packages/head.hackage+ matrix: include:- - env: CABALVER=1.24 GHCVER=7.4.2- compiler: ": #GHC 7.4.2"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=7.6.3- compiler: ": #GHC 7.6.3"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=7.8.4- compiler: ": #GHC 7.8.4"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=7.10.3- compiler: ": #GHC 7.10.3"- addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.0.2- compiler: ": #GHC 8.0.2"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=2.0 GHCVER=8.2.1- compiler: ": #GHC 8.2.1"- addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}+ - compiler: "ghc-8.6.1"+ env: GHCHEAD=true+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}+ - compiler: "ghc-8.4.3"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}+ - compiler: "ghc-8.2.2"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}+ - compiler: "ghc-8.0.2"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}+ - compiler: "ghc-7.10.3"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.8.4"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}}+ - compiler: "ghc-7.6.3"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}}+ - compiler: "ghc-7.4.2"+ # env: TEST=--disable-tests BENCH=--disable-benchmarks+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}}+ - compiler: "ghc-head"+ env: GHCHEAD=true+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} + allow_failures:+ - compiler: "ghc-head"+ - compiler: "ghc-8.6.1"+ before_install:- - unset CC- - export HAPPYVER=1.19.5- - export ALEXVER=3.1.4- - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH+ - HC=${CC}+ - HCPKG=${HC/ghc/ghc-pkg}+ - unset CC+ - ROOTDIR=$(pwd)+ - mkdir -p $HOME/.local/bin+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))+ - echo $HCNUMVER install:- - cabal --version- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];- then- zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >- $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;- fi- - travis_retry cabal update- - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config"- - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt+ - cabal --version+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - BENCH=${BENCH---enable-benchmarks}+ - TEST=${TEST---enable-tests}+ - HADDOCK=${HADDOCK-true}+ - UNCONSTRAINED=${UNCONSTRAINED-true}+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}+ - GHCHEAD=${GHCHEAD-false}+ - travis_retry cabal update -v+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"+ - rm -fv cabal.project cabal.project.local+ # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage+ - |+ if $GHCHEAD; then+ sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config+ for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done -# check whether current requested install-plan matches cached package-db snapshot- - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;- then- echo "cabal build-cache HIT";- rm -rfv .ghc;- cp -a $HOME/.cabsnap/ghc $HOME/.ghc;- cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;- else- echo "cabal build-cache MISS";- rm -rf $HOME/.cabsnap;- mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;- cabal install --only-dependencies --enable-tests --enable-benchmarks;- fi+ echo 'repository head.hackage' >> ${HOME}/.cabal/config+ echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config+ echo ' secure: True' >> ${HOME}/.cabal/config+ echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config+ echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config+ echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config+ echo ' key-threshold: 3' >> ${HOME}/.cabal.config -# snapshot package-db on cache miss- - if [ ! -d $HOME/.cabsnap ];- then- echo "snapshotting package-db to build-cache";- mkdir $HOME/.cabsnap;- cp -a $HOME/.ghc $HOME/.cabsnap/ghc;- cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;- fi+ grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' + cabal new-update head.hackage -v+ fi+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+ - "printf 'packages: \".\" \"./examples\"\\n' > cabal.project"+ - touch cabal.project.local+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+ - cat cabal.project || true+ - cat cabal.project.local || true+ - if [ -f "./configure.ac" ]; then+ (cd "." && autoreconf -i);+ fi+ - if [ -f "./examples/configure.ac" ]; then+ (cd "./examples" && autoreconf -i);+ fi+ - rm -f cabal.project.freeze+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all+ - rm -rf .ghc.environment.* "."/dist "./examples"/dist+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)+ # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script:- - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging- - cabal build # this builds all libraries and executables (including tests)- - cabal test- - cabal bench || true # expected result: these will crash- - cabal sdist || true # tests that a source-distribution can be generated+ # test that source-distributions can be generated+ - (cd "." && cabal sdist)+ - (cd "./examples" && cabal sdist)+ - mv "."/dist/trifecta-*.tar.gz "./examples"/dist/trifecta-examples-*.tar.gz ${DISTDIR}/+ - cd ${DISTDIR} || false+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;+ - "printf 'packages: trifecta-*/*.cabal trifecta-examples-*/*.cabal\\n' > cabal.project"+ - touch cabal.project.local+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+ - cat cabal.project || true+ - cat cabal.project.local || true -# Check that the resulting source distribution can be built & installed.-# If there are no other `.tar.gz` files in `dist`, this can be even simpler:-# `cabal install --force-reinstalls dist/*-*.tar.gz`- - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&- (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ # build & run tests, build benchmarks+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi -notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313trifecta\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"+ # cabal check+ - (cd trifecta-* && cabal check)+ - (cd trifecta-examples-* && cabal check)++ # haddock+ - rm -rf ./dist-newstyle+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi++# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"] # EOF
CHANGELOG.markdown view
@@ -1,6 +1,12 @@+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
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2010-2015 Edward Kmett+Copyright 2010-2017 Edward Kmett Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen
+ examples/LICENSE view
@@ -0,0 +1,33 @@+Copyright 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.
+ examples/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import RFC2616 (lumpy)+import System.Environment (getArgs)++main :: IO ()+main = mapM_ lumpy =<< getArgs
− examples/RFC2616.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Main (main) where--import Control.Applicative-import Control.Exception (bracket)-import System.Environment (getArgs)-import System.IO (hClose, openFile, IOMode(ReadMode))-import Text.Trifecta hiding (token)-import Text.Parser.Token.Highlight-import Text.Parser.Token.Style-import Data.CharSet.ByteSet as S-import qualified Data.ByteString as B--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--lumpy arg = do- r <- parseFromFile (many request) arg- case r of- Nothing -> return ()- Just rs -> print (length rs)--main :: IO ()-main = mapM_ lumpy =<< getArgs
+ examples/Spec.hs view
@@ -0,0 +1,19 @@+module 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
+ examples/rfc2616/RFC2616.hs view
@@ -0,0 +1,71 @@+{-# 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
+ examples/trifecta-examples.cabal view
@@ -0,0 +1,62 @@+name: trifecta-examples+category: Text, Parsing, Diagnostics, Pretty Printer, Logging+version: 2+license: BSD3+license-file: LICENSE+author: Edward A. Kmett+maintainer: Edward A. Kmett <ekmett@gmail.com>+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+cabal-version: >= 1.10+build-type: Simple+tested-with: GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.3+ , GHC == 8.6.1+extra-source-files: RFC2616.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.3 && <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
src/Text/Trifecta.hs view
@@ -7,6 +7,7 @@ -- Stability : experimental -- Portability : non-portable --+-- For a short introduction, see the "Text.Trifecta.Tutorial" module. ---------------------------------------------------------------------------- module Text.Trifecta ( module Text.Trifecta.Rendering@@ -20,12 +21,12 @@ , module Text.Parser.Token ) where -import Text.Trifecta.Rendering+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.Combinators+import Text.Trifecta.Rendering import Text.Trifecta.Result import Text.Trifecta.Rope-import Text.Parser.Combinators-import Text.Parser.Char-import Text.Parser.Token
src/Text/Trifecta/Combinators.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Combinators@@ -24,22 +25,25 @@ ) where import Control.Applicative-import Control.Monad (MonadPlus)+import Control.Monad (MonadPlus) import Control.Monad.Trans.Class import Control.Monad.Trans.Identity-import Control.Monad.Trans.RWS.Lazy as Lazy-import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader-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.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)+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-import Prelude hiding (span) -- | This class provides parsers with easy access to: --@@ -48,7 +52,7 @@ -- 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+ line :: m ByteString -- | Retrieve the current position as a 'Delta'. position :: m Delta@@ -163,7 +167,8 @@ restOfLine = lift restOfLine {-# INLINE restOfLine #-} --- | Run a parser, grabbing all of the text between its start and end points and discarding the original result+-- | Run a parser, grabbing all of the text between its start and end points and+-- discarding the original result sliced :: DeltaParsing m => m a -> m ByteString sliced = slicedWith (\_ bs -> bs) {-# INLINE sliced #-}@@ -178,12 +183,14 @@ careted p = (\m l a -> a :^ Caret m l) <$> position <*> line <*> p {-# INLINE careted #-} --- | Discard the result of a parse, returning a 'Span' from where we start to where it ended parsing.+-- | Discard the result of a parse, returning a 'Span' from where we start to+-- where it ended parsing. spanning :: DeltaParsing m => m a -> m Span spanning p = (\s l e -> Span s e l) <$> position <*> line <*> (p *> position) {-# INLINE spanning #-} --- | Parse a 'Spanned' result. The 'Span' starts here and runs to the last position parsed.+-- | Parse a 'Spanned' result. The 'Span' starts here and runs to the last+-- position parsed. spanned :: DeltaParsing m => m a -> m (Spanned a) spanned p = (\s l a e -> a :~ Span s e l) <$> position <*> line <*> p <*> position {-# INLINE spanned #-}@@ -193,10 +200,11 @@ fixiting p = (\(r :~ s) -> Fixit s r) <$> spanned p {-# INLINE 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.+-- | 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 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 ()
src/Text/Trifecta/Delta.hs view
@@ -10,6 +10,8 @@ -- 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(..)@@ -22,7 +24,9 @@ , columnByte ) where +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup+#endif import Data.Hashable import Data.Int import Data.Data@@ -35,9 +39,10 @@ import Data.ByteString as Strict hiding (empty) import qualified Data.ByteString.UTF8 as UTF8 import GHC.Generics-import Text.Trifecta.Instances () import Text.PrettyPrint.ANSI.Leijen hiding (column, (<>)) +import Text.Trifecta.Instances ()+ class HasBytes t where bytes :: t -> Int64 @@ -47,21 +52,48 @@ 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 -- the number of characters- {-# UNPACK #-} !Int64 -- the number of bytes- | Tab {-# UNPACK #-} !Int64 -- the number of characters before the tab- {-# UNPACK #-} !Int64 -- the number of characters after the tab- {-# UNPACK #-} !Int64 -- the number of bytes- | Lines {-# UNPACK #-} !Int64 -- the number of newlines contained- {-# UNPACK #-} !Int64 -- the number of characters since the last newline- {-# UNPACK #-} !Int64 -- number of bytes- {-# UNPACK #-} !Int64 -- the number of bytes since the last newline- | Directed !ByteString -- current file name- {-# UNPACK #-} !Int64 -- the number of lines since the last line directive- {-# UNPACK #-} !Int64 -- the number of characters since the last newline- {-# UNPACK #-} !Int64 -- number of bytes- {-# UNPACK #-} !Int64 -- the number of bytes since the last newline+ = 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@@ -73,15 +105,24 @@ instance (HasDelta l, HasDelta r) => HasDelta (Either l r) where delta = either delta delta +-- | Example: @file.txt:12:34@ instance Pretty Delta where- pretty d = case d of- Columns c _ -> k f 0 c- Tab x y _ -> k f 0 (nextTab x + y)- Lines l c _ _ -> k f l c- Directed fn l c _ _ -> k (UTF8.toString fn) l c- where- k fn ln cn = bold (pretty fn) <> char ':' <> bold (int64 (ln+1)) <> char ':' <> bold (int64 (cn+1))- f = "(interactive)"+ pretty d = case d of+ Columns c _ -> prettyDelta interactive 0 c+ Tab x y _ -> prettyDelta interactive 0 (nextTab x + y)+ Lines l c _ _ -> prettyDelta interactive l c+ Directed fn l c _ _ -> prettyDelta (UTF8.toString fn) l c+ where+ prettyDelta+ :: String -- Source description+ -> Int64 -- Line+ -> Int64 -- Column+ -> Doc+ prettyDelta source line' column'+ = bold (pretty source)+ <> char ':' <> bold (int64 (line'+1))+ <> char ':' <> bold (int64 (column'+1))+ interactive = "(interactive)" int64 :: Int64 -> Doc int64 = pretty . show@@ -146,6 +187,12 @@ {-# INLINE 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) {-# INLINE near #-}
src/Text/Trifecta/Highlight.hs view
@@ -42,11 +42,12 @@ import Text.Blaze.Internal (MarkupM(Empty, Leaf)) import Text.Parser.Token.Highlight import Text.PrettyPrint.ANSI.Leijen hiding ((<>))+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8+ import Text.Trifecta.Util.IntervalMap as IM import Text.Trifecta.Delta import Text.Trifecta.Rope-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 -- | Convert a 'Highlight' into a coloration on a 'Doc'. withHighlight :: Highlight -> Doc -> Doc
src/Text/Trifecta/Instances.hs view
@@ -14,8 +14,8 @@ module Text.Trifecta.Instances () where #if !MIN_VERSION_ansi_wl_pprint(0,6,8)-import Text.PrettyPrint.ANSI.Leijen-import qualified Data.Semigroup as Data+import qualified Data.Semigroup as Data+import Text.PrettyPrint.ANSI.Leijen instance Data.Semigroup Doc where (<>) = (<>)
src/Text/Trifecta/Parser.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2015@@ -29,6 +30,7 @@ , stepResult , stepIt -- * Parsing+ , runParser , parseFromFile , parseFromFileEx , parseString@@ -42,8 +44,10 @@ import qualified Control.Monad.Fail as Fail import Data.ByteString as Strict hiding (empty, snoc) import Data.ByteString.UTF8 as UTF8-import Data.Maybe (isJust)+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)@@ -54,11 +58,11 @@ import Text.Parser.Token import Text.PrettyPrint.ANSI.Leijen as Pretty hiding (line, (<>), (<$>), empty) import Text.Trifecta.Combinators-import Text.Trifecta.Instances ()+import Text.Trifecta.Delta as Delta+import Text.Trifecta.Instances () import Text.Trifecta.Rendering import Text.Trifecta.Result import Text.Trifecta.Rope-import Text.Trifecta.Delta as Delta import Text.Trifecta.Util.It -- | The type of a trifecta parser@@ -94,14 +98,15 @@ -- 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+ (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@@ -264,10 +269,25 @@ 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) $@@ -282,12 +302,15 @@ 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) {-# INLINE 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@@ -301,8 +324,9 @@ stepIt :: It Rope a -> Step a stepIt = go mempty where- go r (Pure a) = StepDone r a- go r (It a k) = StepCont r (pure a) $ \s -> go s (k s)+ go r m = case simplifyIt m r of+ Pure a -> StepDone r a+ It a k -> StepCont r (pure a) $ \r' -> go r' (k r') {-# INLINE stepIt #-} data Stepping a@@ -311,30 +335,51 @@ | CO a (Set String) Delta ByteString | CE ErrInfo -stepParser :: Parser a -> Delta -> ByteString -> Step a-stepParser (Parser p) d0 bs0 = go mempty $ 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 r (Pure (EO a _)) = StepDone r a- go r (Pure (EE e)) = StepFail r $- let errDoc = explain (renderingCaret d0 bs0) e- in ErrInfo errDoc (_finalDeltas e)- go r (Pure (CO a _ _ _)) = StepDone r a- go r (Pure (CE d)) = StepFail r d- go r (It ma k) = StepCont r (case ma of- EO a _ -> Success a- EE e -> Failure $- ErrInfo (explain (renderingCaret d0 bs0) e) (d0 : _finalDeltas e)- CO a _ _ _ -> Success a- CE d -> Failure d- ) (go <*> k)-{-# INLINE stepParser #-}+-- | 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) --- | @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.+ 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)+ {-# INLINE 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+{-# INLINE 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"@@ -350,29 +395,40 @@ liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak 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.+-- | @('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 --- | @parseByteString p delta i@ runs a parser @p@ on @i@.--parseByteString :: Parser a -> Delta -> UTF8.ByteString -> Result a-parseByteString p d inp = starve $ feed inp $ stepParser (release d *> p) mempty mempty+-- | 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 -parseString :: Parser a -> Delta -> String -> Result a-parseString p d inp = starve $ feed inp $ stepParser (release d *> p) mempty mempty+-- | 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
src/Text/Trifecta/Rendering.hs view
@@ -1,9 +1,9 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett@@ -55,29 +55,39 @@ , (.#) ) where -import Control.Applicative-import Control.Comonad-import Control.Lens-import Data.Array-import Data.ByteString as B hiding (groupBy, empty, any)-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.Maybe-import Data.List (groupBy)-import Data.Semigroup-import Data.Semigroup.Reducer-import GHC.Generics-import Prelude as P hiding (span)-import System.Console.ANSI-import Text.PrettyPrint.ANSI.Leijen hiding (column, (<>), (<$>))+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.Semigroup+import Data.Semigroup.Reducer+import GHC.Generics+import Prelude as P hiding (span)+import System.Console.ANSI+import Text.PrettyPrint.ANSI.Leijen hiding (column, (<$>), (<>))+ import Text.Trifecta.Delta-import Text.Trifecta.Instances ()+import Text.Trifecta.Instances () import Text.Trifecta.Util.Combinators +-- $setup+--+-- >>> :set -XOverloadedStrings+-- >>> import Text.PrettyPrint.ANSI.Leijen (pretty, plain)+-- >>> 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 @@ -129,8 +139,10 @@ White -> onwhite . 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 @@ -141,10 +153,15 @@ where old@((t,lo),(b,hi)) = bounds a new = ((min t y,lo),(max b y,hi)) -draw :: [SGR] -> Int -> Int64 -> String -> Lines -> Lines-draw e y n xs a0- | P.null xs = a0- | otherwise = gt $ lt (a /// out)+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@@ -154,11 +171,19 @@ 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+ { _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 } @@ -168,10 +193,21 @@ 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 (pretty emptyRendering)+-- "" emptyRendering :: Rendering emptyRendering = Rendering (Columns 0 0) 0 0 id (const id) @@ -184,7 +220,12 @@ mappend = (<>) mempty = emptyRendering -ifNear :: Delta -> (Lines -> Lines) -> Delta -> Lines -> Lines+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 @@ -198,11 +239,16 @@ render = id class Source t where- source :: t -> (Int64, Int64, Lines -> Lines) {- the number of (padded) columns, number of bytes, and the the line -}+ 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')+ | 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 = "<EOF>"@@ -214,7 +260,6 @@ go n (x:xs) = x : go (n + 1) xs go _ [] = [] - instance Source ByteString where source = source . UTF8.toString @@ -240,8 +285,9 @@ 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)+ | c + w2 >= l = if l > w then (l-w, l)+ else (0 , w)+ | otherwise = (c-w2, c+w2) where w2 = div w 2 data Rendered a = a :@ Rendering@@ -272,12 +318,11 @@ instance Renderable (Rendered a) where render (_ :@ s) = s --- |--- > In file included from baz.c:9--- > In file included from bar.c:4--- > foo.c:8:36: note--- > int main(int argc, char ** argv) { int; }--- > ^+-- | A 'Caret' marks a point in the input with a simple @^@ character.+--+-- >>> plain (pretty (addCaret (Columns 35 35) exampleRendering))+-- int main(int argc, char ** argv) { int; }<EOF>+-- ^ data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic) class HasCaret t where@@ -288,12 +333,14 @@ 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 @@ -350,29 +397,38 @@ instance Hashable a => Hashable (Careted a) +-- | ANSI terminal style to render spans with. spanEffects :: [SGR] spanEffects = [SetColor Foreground Dull Green] -drawSpan :: Delta -> Delta -> Delta -> Lines -> Lines-drawSpan s e d a- | nl && nh = go (column l) (rep (max (column h - column l) 0) '~') a- | nl = go (column l) (rep (max (snd (snd (bounds a)) - column l + 1) 0) '~') a- | nh = go (-1) (rep (max (column h + 1) 0) '~') a- | otherwise = a+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- l = argmin bytes s e- h = argmax bytes s e- nl = near l d- nh = near h d+ lo = argmin bytes start end+ hi = argmax bytes start end+ nearLo = near lo d+ nearHi = near hi d rep = P.replicate . fromIntegral --- |--- > int main(int argc, char ** argv) { int; }--- > ^~~ 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.+--+-- >>> plain (pretty (addSpan (Columns 35 35) (Columns 38 38) exampleRendering))+-- int main(int argc, char ** argv) { int; }<EOF>+-- ~~~ data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic) class HasSpan t where@@ -392,6 +448,8 @@ 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@@ -421,9 +479,6 @@ instance Hashable a => Hashable (Spanned a) --- > int main(int argc char ** argv) { int; }--- > ^--- > , 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@@ -432,9 +487,17 @@ addFixit :: Delta -> Delta -> String -> Rendering -> Rendering addFixit s e rpl r = drawFixit s e rpl .# r +-- | A 'Fixit' is a 'Span' with a suggestion.+--+-- >>> plain (pretty (addFixit (Columns 35 35) (Columns 38 38) "Fix this!" exampleRendering))+-- int main(int argc, char ** argv) { int; }<EOF>+-- ~~~+-- Fix this! data Fixit = Fixit- { _fixitSpan :: {-# UNPACK #-} !Span+ { _fixitSpan :: {-# UNPACK #-} !Span+ -- ^ 'Span' where the error occurred , _fixitReplacement :: !ByteString+ -- ^ Replacement suggestion } deriving (Eq,Ord,Show,Data,Typeable,Generic) makeClassy ''Fixit
src/Text/Trifecta/Result.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2015@@ -25,6 +25,7 @@ -- * Parse Results Result(..) , AsResult(..)+ , foldResult , _Success , _Failure -- * Parsing Errors@@ -34,30 +35,35 @@ , failed ) where -import Control.Applicative as Alternative-import Control.Lens hiding (snoc, cons)-import Control.Monad (guard)-import Data.Foldable-import Data.Maybe (fromMaybe, isJust)-import qualified Data.List as List-import Data.Semigroup-import Data.Set as Set hiding (empty, toList)-import Text.PrettyPrint.ANSI.Leijen as Pretty hiding (line, (<>), (<$>), empty)+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 Text.PrettyPrint.ANSI.Leijen as Pretty hiding+ (empty, line, (<$>), (<>))++import Text.Trifecta.Delta as Delta import Text.Trifecta.Instances () import Text.Trifecta.Rendering-import Text.Trifecta.Delta as Delta data ErrInfo = ErrInfo { _errDoc :: Doc , _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.+-- | This is used to report an error. What went wrong, some supplemental docs+-- and a set of things expected at the current location. This does not, however,+-- include the actual location. data Err = Err- { _reason :: Maybe Doc- , _footnotes :: [Doc]- , _expected :: Set String+ { _reason :: Maybe Doc+ , _footnotes :: [Doc]+ , _expected :: Set String , _finalDeltas :: [Delta] } @@ -79,7 +85,8 @@ failed m = Err (Just (fillSep (pretty <$> words m))) [] mempty mempty {-# INLINE failed #-} --- | Convert a location and an 'Err' into a 'Doc'+-- | Convert a 'Rendering' of auxiliary information and an 'Err' into a 'Doc',+-- ready to be prettyprinted to the user. explain :: Rendering -> Err -> Doc explain r (Err mm as es _) | Set.null es = report (withEx mempty)@@ -111,6 +118,12 @@ | 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)@@ -135,7 +148,7 @@ instance Show a => Pretty (Result a) where pretty (Success a) = pretty (show a)- pretty (Failure xs) = pretty . _errDoc $ xs+ pretty (Failure xs) = pretty (_errDoc xs) instance Applicative Result where pure = Success@@ -156,3 +169,8 @@ {-# INLINE (<|>) #-} empty = Failure mempty {-# INLINE empty #-}++instance Monad Result where+ return = pure+ Success a >>= m = m a+ Failure e >>= _ = Failure e
src/Text/Trifecta/Rope.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett@@ -8,10 +14,14 @@ -- Stability : experimental -- Portability : non-portable --+-- A rope is a data strucure to efficiently store and manipulate long strings.+-- Wikipedia provides a nice overview:+-- <https://en.wikipedia.org/wiki/Rope_(data_structure)> ---------------------------------------------------------------------------- module Text.Trifecta.Rope ( Rope(..) , rope+ , ropeBS , Strand(..) , strand , strands@@ -19,25 +29,37 @@ , grabLine ) where -import Data.Semigroup-import Data.Semigroup.Reducer-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.FingerTree as FingerTree-import GHC.Generics-import Data.Foldable (toList)-import Data.Hashable-import Text.Trifecta.Util.Combinators as Util+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 Data.Data+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- | Skipping !Delta+ = 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) @@ -59,22 +81,69 @@ 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 a the contents of a rope from a given location up to a newline-grabRest :: Delta -> Rope -> r -> (Delta -> Lazy.ByteString -> r) -> r-grabRest i t kf ks = trim (delta l) (bytes i - bytes l) (toList r) where- trim j 0 (Strand h _ : xs) = go j h xs- trim _ k (Strand h _ : xs) = go i (Strict.drop (fromIntegral k) h) xs- trim j k (p : xs) = trim (j <> delta p) k xs- trim _ _ [] = kf- go j h s = ks j $ Lazy.fromChunks $ h : [ a | Strand a _ <- s ]- (l, r) = FingerTree.split (\b -> bytes b > bytes i) $ strands t+-- | 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 --- | grab a the contents of a rope from a given location up to a newline-grabLine :: Delta -> Rope -> r -> (Delta -> Strict.ByteString -> r) -> r-grabLine i t kf ks = grabRest i t kf $ \c -> ks c . Util.fromLazy . Util.takeLine+ 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
+ src/Text/Trifecta/Tutorial.hs view
@@ -0,0 +1,71 @@+-- | 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 + 2 + 3))<EOF>+-- > ^+examples :: docDummy+examples = error "Haddock dummy for documentation"
src/Text/Trifecta/Util/Combinators.hs view
@@ -18,8 +18,8 @@ , (<$!>) ) where +import Data.ByteString as Strict import Data.ByteString.Lazy as Lazy-import Data.ByteString as Strict argmin :: Ord b => (a -> b) -> a -> a -> a argmin f a b
src/Text/Trifecta/Util/IntervalMap.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} #ifndef MIN_VERSION_lens #define MIN_VERSION_lens(x,y,z) 1@@ -54,19 +54,21 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative hiding (empty)-import Data.Foldable (Foldable(foldMap))+import Data.Foldable (Foldable (foldMap)) #endif-import Control.Lens- hiding ((<|),(|>) #if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710- ,(:<)+import Control.Lens hiding ((:<), (<|), (|>))+#else+import Control.Lens hiding ((<|), (|>)) #endif- )-import qualified Data.FingerTree as FT-import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><))-import Data.Semigroup-import Data.Semigroup.Reducer-import Data.Semigroup.Union+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@@ -250,4 +252,3 @@ fromList :: Ord v => [(v, v, a)] -> IntervalMap v a fromList = foldr ins empty where ins (lo, hi, n) = insert lo hi n-
src/Text/Trifecta/Util/It.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.It@@ -21,6 +21,7 @@ , needIt , wantIt , simplifyIt+ , foldIt , runIt , fillIt , rewindIt@@ -37,16 +38,45 @@ import Data.Monoid #endif -import Data.ByteString as Strict-import Data.ByteString.Lazy as Lazy+import Data.ByteString as Strict+import Data.ByteString.Lazy as Lazy import Data.Profunctor-import Text.Trifecta.Rope 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 <https://wiki.haskell.org/Enumerator_and_iteratee Iteratee>+-- 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@@ -55,7 +85,7 @@ 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@@ -72,6 +102,7 @@ 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@@ -85,47 +116,162 @@ instance ComonadApply (It r) where (<@>) = (<*>) --- | It is a cofree comonad+-- | 'It' is a cofree comonad instance Comonad (It r) where- duplicate p@Pure{} = Pure p+ duplicate p@Pure{} = Pure p duplicate p@(It _ k) = It p (duplicate . k)- extend f p@Pure{} = Pure (f p)++ 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 -needIt :: a -> (r -> Maybe a) -> It r 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 -wantIt :: a -> (r -> (# Bool, a #)) -> It r a+-- | 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 --- scott decoding+-- | 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 text forward from that point+-- | 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))
tests/QuickCheck.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main
trifecta.cabal view
@@ -1,6 +1,6 @@ name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging-version: 1.7.1.1+version: 2 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -9,16 +9,27 @@ stability: experimental homepage: http://github.com/ekmett/trifecta/ bug-reports: http://github.com/ekmett/trifecta/issues-copyright: Copyright (C) 2010-2015 Edward A. Kmett+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 build-type: Custom+tested-with: GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.3+ , GHC == 8.6.1 extra-source-files:- examples/RFC2616.hs+ examples/*.hs+ examples/LICENSE+ examples/rfc2616/*.hs examples/RFC2616.txt+ examples/trifecta-examples.cabal .travis.yml CHANGELOG.markdown README.markdown@@ -44,6 +55,7 @@ Text.Trifecta.Rendering Text.Trifecta.Result Text.Trifecta.Rope+ Text.Trifecta.Tutorial Text.Trifecta.Util.Array Text.Trifecta.Util.IntervalMap Text.Trifecta.Util.It@@ -54,7 +66,7 @@ build-depends: ansi-wl-pprint >= 0.6.6 && < 0.7,- ansi-terminal >= 0.6 && < 0.7,+ ansi-terminal >= 0.6 && < 0.9, array >= 0.3.0.2 && < 0.6, base >= 4.4 && < 5, blaze-builder >= 0.3.0.1 && < 0.5,@@ -63,7 +75,7 @@ bytestring >= 0.9.1 && < 0.11, charset >= 0.3.5.1 && < 1, comonad >= 4 && < 6,- containers >= 0.3 && < 0.6,+ containers >= 0.3 && < 0.7, deepseq >= 1.2.0.1 && < 1.5, fingertree >= 0.1 && < 0.2, ghc-prim,@@ -89,14 +101,15 @@ build-depends: fail == 4.9.* test-suite doctests- type: exitcode-stdio-1.0- main-is: doctests.hs- ghc-options: -Wall -threaded- hs-source-dirs: tests- default-language: Haskell2010+ 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.14,+ doctest >= 0.11.1 && < 0.17, trifecta test-suite quickcheck@@ -110,4 +123,3 @@ trifecta ghc-options: -Wall -threaded hs-source-dirs: tests-