diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/examples/LICENSE b/examples/LICENSE new file mode 100644 --- /dev/null +++ b/examples/LICENSE @@ -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. diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import RFC2616 (lumpy) +import System.Environment (getArgs) + +main :: IO () +main = mapM_ lumpy =<< getArgs diff --git a/examples/RFC2616.hs b/examples/RFC2616.hs deleted file mode 100644 --- a/examples/RFC2616.hs +++ /dev/null @@ -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 diff --git a/examples/Spec.hs b/examples/Spec.hs new file mode 100644 --- /dev/null +++ b/examples/Spec.hs @@ -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 diff --git a/examples/rfc2616/RFC2616.hs b/examples/rfc2616/RFC2616.hs new file mode 100644 --- /dev/null +++ b/examples/rfc2616/RFC2616.hs @@ -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 diff --git a/examples/trifecta-examples.cabal b/examples/trifecta-examples.cabal new file mode 100644 --- /dev/null +++ b/examples/trifecta-examples.cabal @@ -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 +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 diff --git a/src/Text/Trifecta.hs b/src/Text/Trifecta.hs --- a/src/Text/Trifecta.hs +++ b/src/Text/Trifecta.hs @@ -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 diff --git a/src/Text/Trifecta/Combinators.hs b/src/Text/Trifecta/Combinators.hs --- a/src/Text/Trifecta/Combinators.hs +++ b/src/Text/Trifecta/Combinators.hs @@ -1,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 () diff --git a/src/Text/Trifecta/Delta.hs b/src/Text/Trifecta/Delta.hs --- a/src/Text/Trifecta/Delta.hs +++ b/src/Text/Trifecta/Delta.hs @@ -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 #-} diff --git a/src/Text/Trifecta/Highlight.hs b/src/Text/Trifecta/Highlight.hs --- a/src/Text/Trifecta/Highlight.hs +++ b/src/Text/Trifecta/Highlight.hs @@ -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 diff --git a/src/Text/Trifecta/Instances.hs b/src/Text/Trifecta/Instances.hs --- a/src/Text/Trifecta/Instances.hs +++ b/src/Text/Trifecta/Instances.hs @@ -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 (<>) = (<>) diff --git a/src/Text/Trifecta/Parser.hs b/src/Text/Trifecta/Parser.hs --- a/src/Text/Trifecta/Parser.hs +++ b/src/Text/Trifecta/Parser.hs @@ -1,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 diff --git a/src/Text/Trifecta/Rendering.hs b/src/Text/Trifecta/Rendering.hs --- a/src/Text/Trifecta/Rendering.hs +++ b/src/Text/Trifecta/Rendering.hs @@ -1,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 = "" @@ -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; } +-- ^ 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; } +-- ~~~ 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; } +-- ~~~ +-- 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 diff --git a/src/Text/Trifecta/Result.hs b/src/Text/Trifecta/Result.hs --- a/src/Text/Trifecta/Result.hs +++ b/src/Text/Trifecta/Result.hs @@ -1,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 diff --git a/src/Text/Trifecta/Rope.hs b/src/Text/Trifecta/Rope.hs --- a/src/Text/Trifecta/Rope.hs +++ b/src/Text/Trifecta/Rope.hs @@ -1,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: +-- ---------------------------------------------------------------------------- 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 diff --git a/src/Text/Trifecta/Tutorial.hs b/src/Text/Trifecta/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Tutorial.hs @@ -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)) +-- > ^ +examples :: docDummy +examples = error "Haddock dummy for documentation" diff --git a/src/Text/Trifecta/Util/Combinators.hs b/src/Text/Trifecta/Util/Combinators.hs --- a/src/Text/Trifecta/Util/Combinators.hs +++ b/src/Text/Trifecta/Util/Combinators.hs @@ -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 diff --git a/src/Text/Trifecta/Util/IntervalMap.hs b/src/Text/Trifecta/Util/IntervalMap.hs --- a/src/Text/Trifecta/Util/IntervalMap.hs +++ b/src/Text/Trifecta/Util/IntervalMap.hs @@ -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 - diff --git a/src/Text/Trifecta/Util/It.hs b/src/Text/Trifecta/Util/It.hs --- a/src/Text/Trifecta/Util/It.hs +++ b/src/Text/Trifecta/Util/It.hs @@ -1,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 +-- 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)) diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs --- a/tests/QuickCheck.hs +++ b/tests/QuickCheck.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main diff --git a/trifecta.cabal b/trifecta.cabal --- a/trifecta.cabal +++ b/trifecta.cabal @@ -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 -