trifecta 1.7.1.1 → 2.1.4
raw patch · 33 files changed
Files
- .travis.yml +0/−98
- CHANGELOG.markdown +37/−1
- LICENSE +1/−1
- README.markdown +1/−1
- Setup.hs +2/−0
- Setup.lhs +0/−34
- Warning.hs +0/−5
- examples/LICENSE +33/−0
- examples/Main.hs +7/−0
- examples/RFC2616-malformed.txt +9/−0
- examples/RFC2616.hs +0/−71
- examples/Spec.hs +19/−0
- examples/rfc2616/RFC2616.hs +71/−0
- examples/trifecta-examples.cabal +65/−0
- images/example.png binary
- src/Text/Trifecta.hs +7/−6
- src/Text/Trifecta/Combinators.hs +93/−85
- src/Text/Trifecta/Delta.hs +83/−41
- src/Text/Trifecta/Highlight.hs +24/−42
- src/Text/Trifecta/Instances.hs +0/−22
- src/Text/Trifecta/Parser.hs +153/−95
- src/Text/Trifecta/Rendering.hs +200/−116
- src/Text/Trifecta/Result.hs +65/−51
- src/Text/Trifecta/Rope.hs +100/−29
- src/Text/Trifecta/Tutorial.hs +71/−0
- src/Text/Trifecta/Util/Array.hs +0/−397
- src/Text/Trifecta/Util/Combinators.hs +2/−2
- src/Text/Trifecta/Util/IntervalMap.hs +24/−22
- src/Text/Trifecta/Util/It.hs +165/−26
- src/Text/Trifecta/Util/Pretty.hs +47/−0
- tests/QuickCheck.hs +0/−15
- tests/doctests.hs +0/−25
- trifecta.cabal +58/−57
− .travis.yml
@@ -1,98 +0,0 @@-language: c-sudo: false--cache:- directories:- - $HOME/.cabsnap- - $HOME/.cabal/packages--before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar--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]}}--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--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--# 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--# 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--# 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--# 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")--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"-# EOF
CHANGELOG.markdown view
@@ -1,6 +1,42 @@+2.1.4 [2024.02.07]+------------------+* Allow building with `ansi-terminal-1.1.*`.++2.1.3 [2023.08.07]+------------------+* Allow building with `deepseq-1.5.*`.++2.1.2 [2021.11.16]+------------------+* Add an `Eq Strand` instance.+* Allow building with `hashable-1.4.*`.+* Drop support for pre-8.0 versions of GHC.++2.1.1 [2021.02.18]+------------------+* Allow building with `lens-5.*`.+* The build-type has been changed from `Custom` to `Simple`.+ To achieve this, the `doctests` test suite has been removed in favor of using [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) to run the doctests.++2.1 [2019.09.06]+----------------+* Support building with `base-4.13` (GHC 8.8).+* Dropped support for GHC < 7.8.+* Print line numbers in the gutter.+* Switched to `prettyprinter` from `ansi-wl-pprint`+* Switched from `INLINE` to `INLINABLE` to help fight compile time woes+ while still allowing aggressive inline when you want it.+* Removed `Text.Trifecta.Util.Array`. `primitive` now exists.++2 [2018.07.03]+--------------+* `stepParser` no longer takes a `ByteString`.+* 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-2019 Edward Kmett Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen
README.markdown view
@@ -1,7 +1,7 @@ trifecta ======== -[](https://hackage.haskell.org/package/trifecta) [](http://travis-ci.org/ekmett/trifecta)+[](https://hackage.haskell.org/package/trifecta) [](https://github.com/ekmett/trifecta/actions?query=workflow%3AHaskell-CI) This package provides a parser that focuses on nice diagnostics.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,34 +0,0 @@-\begin{code}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif--#if MIN_VERSION_cabal_doctest(1,0,0)--import Distribution.Extra.Doctest ( defaultMainWithDoctests )-main :: IO ()-main = defaultMainWithDoctests "doctests"--#else--#ifdef MIN_VERSION_Cabal--- If the macro is defined, we have new cabal-install,--- but for some reason we don't have cabal-doctest in package-db------ Probably we are running cabal sdist, when otherwise using new-build--- workflow-import Warning ()-#endif--import Distribution.Simple--main :: IO ()-main = defaultMain--#endif--\end{code}
− Warning.hs
@@ -1,5 +0,0 @@-module Warning- {-# WARNING ["You are configuring this package without cabal-doctest installed.",- "The doctests test-suite will not work as a result.",- "To fix this, install cabal-doctest before configuring."] #-}- () where
+ examples/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-malformed.txt view
@@ -0,0 +1,9 @@+GET http://slashdot.org/ HTTP/1.1+foo: this is a test++GET http://slashdot.org/ HTTP/1.0+foo: of the emergency broadcast system++GET http://slashdot.org/ HTTP/1.0+foo but I mangled the header+
− examples/RFC2616.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,65 @@+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-2019 Edward A. Kmett+synopsis: A modern parser combinator library with convenient diagnostics+description:+ A modern parser combinator library with slicing and Clang-style colored diagnostics+cabal-version: >= 1.10+build-type: Simple+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.4+ , GHC == 9.8.1+extra-source-files: RFC2616.txt RFC2616-malformed.txt++source-repository head+ type: git+ location: https://github.com/ekmett/trifecta.git+++library+ ghc-options: -Wall+ exposed-modules: RFC2616+ hs-source-dirs: rfc2616+ build-depends: base >= 4.7 && <5,+ bytestring,+ charset,+ parsers,+ trifecta+ default-language: Haskell2010++executable trifecta-examples-rfc2616+ main-is: Main.hs+ ghc-options: -Wall -threaded+ hs-source-dirs: .+ default-language: Haskell2010+ build-depends: base,+ trifecta-examples++test-suite trifecta-examples-tests+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ ghc-options: -Wall -threaded+ hs-source-dirs: .+ default-language: Haskell2010+ build-depends: base,+ hspec,+ parsers,+ transformers,+ trifecta,+ trifecta-examples
+ images/example.png view
binary file changed (absent → 29154 bytes)
src/Text/Trifecta.hs view
@@ -1,12 +1,13 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2011-2015 Edward Kmett+-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com> -- 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,12 +1,13 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}+{-# language CPP #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language MultiParamTypeClasses #-}+{-# language UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Combinators--- Copyright : (c) Edward Kmett 2011-2015+-- Copyright : (c) Edward Kmett 2011-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com@@ -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@@ -60,191 +64,195 @@ -- placing a 'Caret' there. rend :: m Rendering rend = rendered <$> position <*> line- {-# INLINE rend #-}+ {-# inlinable rend #-} -- | Grab the remainder of the current line restOfLine :: m ByteString restOfLine = Strict.drop . fromIntegral . columnByte <$> position <*> line- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Lazy.StateT s m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (Lazy.StateT m) = Lazy.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Strict.StateT s m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (Strict.StateT m) = Strict.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (ReaderT e m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (ReaderT m) = ReaderT $ slicedWith f . m- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.WriterT w m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (Strict.WriterT m) = Strict.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.WriterT w m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (Lazy.WriterT m) = Lazy.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.RWST r w s m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (Lazy.RWST m) = Lazy.RWST $ \r s -> slicedWith (\(a,s',w) b -> (f a b, s',w)) $ m r s- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.RWST r w s m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (Strict.RWST m) = Strict.RWST $ \r s -> slicedWith (\(a,s',w) b -> (f a b, s',w)) $ m r s- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (IdentityT m) where line = lift line- {-# INLINE line #-}+ {-# inlinable line #-} position = lift position- {-# INLINE position #-}+ {-# inlinable position #-} slicedWith f (IdentityT m) = IdentityT $ slicedWith f m- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} rend = lift rend- {-# INLINE rend #-}+ {-# inlinable rend #-} restOfLine = lift restOfLine- {-# INLINE restOfLine #-}+ {-# inlinable restOfLine #-} --- | Run a parser, grabbing all of the text between its start and end points and discarding the original result+-- | Run a parser, grabbing all of the text between its start and end points and+-- discarding the original result sliced :: DeltaParsing m => m a -> m ByteString sliced = slicedWith (\_ bs -> bs)-{-# INLINE sliced #-}+{-# inlinable sliced #-} -- | Grab a 'Caret' pointing to the current location. careting :: DeltaParsing m => m Caret careting = Caret <$> position <*> line-{-# INLINE careting #-}+{-# inlinable careting #-} -- | Parse a 'Careted' result. Pointing the 'Caret' to where you start. careted :: DeltaParsing m => m a -> m (Careted a) careted p = (\m l a -> a :^ Caret m l) <$> position <*> line <*> p-{-# INLINE careted #-}+{-# inlinable careted #-} --- | Discard the result of a parse, returning a 'Span' from where we start to where it ended parsing.+-- | Discard the result of a parse, returning a 'Span' from where we start to+-- where it ended parsing. spanning :: DeltaParsing m => m a -> m Span spanning p = (\s l e -> Span s e l) <$> position <*> line <*> (p *> position)-{-# INLINE spanning #-}+{-# inlinable spanning #-} --- | Parse a 'Spanned' result. The 'Span' starts here and runs to the last position parsed.+-- | Parse a 'Spanned' result. The 'Span' starts here and runs to the last+-- position parsed. spanned :: DeltaParsing m => m a -> m (Spanned a) spanned p = (\s l a e -> a :~ Span s e l) <$> position <*> line <*> p <*> position-{-# INLINE spanned #-}+{-# inlinable spanned #-} -- | Grab a fixit. fixiting :: DeltaParsing m => m Strict.ByteString -> m Fixit fixiting p = (\(r :~ s) -> Fixit s r) <$> spanned p-{-# INLINE fixiting #-}+{-# inlinable fixiting #-} --- | This class is a refinement of 'DeltaParsing' that adds the ability to mark your position in the input--- and return there for further parsing later.+-- | 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 () instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Lazy.StateT s m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Strict.StateT s m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (ReaderT e m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.WriterT w m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.WriterT w m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.RWST r w s m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.RWST r w s m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (IdentityT m) where mark = lift mark- {-# INLINE mark #-}+ {-# inlinable mark #-} release = lift . release- {-# INLINE release #-}+ {-# inlinable release #-}
src/Text/Trifecta/Delta.hs view
@@ -1,20 +1,23 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# language CPP #-}+{-# language DeriveDataTypeable #-}+{-# language DeriveGeneric #-} ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2011-2015 Edward Kmett+-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental -- Portability : non-portable --+-- A 'Delta' keeps track of the cursor position of the parser, so it can be+-- referred to later, for example in error messages. ---------------------------------------------------------------------------- module Text.Trifecta.Delta ( Delta(..) , HasDelta(..) , HasBytes(..)+ , prettyDelta , nextTab , rewind , near@@ -22,22 +25,22 @@ , columnByte ) where +#if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup+#endif import Data.Hashable import Data.Int import Data.Data import Data.Word-#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-#endif import Data.Function (on) import Data.FingerTree hiding (empty) import Data.ByteString as Strict hiding (empty) import qualified Data.ByteString.UTF8 as UTF8 import GHC.Generics-import Text.Trifecta.Instances ()-import Text.PrettyPrint.ANSI.Leijen hiding (column, (<>))+import Prettyprinter hiding (column, line') +import Text.Trifecta.Util.Pretty+ class HasBytes t where bytes :: t -> Int64 @@ -47,23 +50,50 @@ 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- deriving (Show, Data, Typeable, Generic)+ = 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, Generic)+ instance Eq Delta where (==) = (==) `on` bytes @@ -73,18 +103,24 @@ instance (HasDelta l, HasDelta r) => HasDelta (Either l r) where delta = either delta delta -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)"--int64 :: Int64 -> Doc-int64 = pretty . show+-- | Example: @file.txt:12:34@+prettyDelta :: Delta -> Doc AnsiStyle+prettyDelta d = case d of+ Columns c _ -> go interactive 0 c+ Tab x y _ -> go interactive 0 (nextTab x + y)+ Lines l c _ _ -> go interactive l c+ Directed fn l c _ _ -> go (UTF8.toString fn) l c+ where+ go+ :: String -- Source description+ -> Int64 -- Line+ -> Int64 -- Column+ -> Doc AnsiStyle+ go source line' column'+ = annotate bold (pretty source)+ <> char ':' <> annotate bold (pretty (line'+1))+ <> char ':' <> annotate bold (pretty (column'+1))+ interactive = "(interactive)" -- | Retrieve the character offset within the current line from this 'Delta'. column :: HasDelta t => t -> Int64@@ -93,7 +129,7 @@ Tab b a _ -> nextTab b + a Lines _ c _ _ -> c Directed _ _ c _ _ -> c-{-# INLINE column #-}+{-# inlinable column #-} -- | Retrieve the byte offset within the current line from this 'Delta'. columnByte :: Delta -> Int64@@ -101,7 +137,7 @@ columnByte (Tab _ _ b) = b columnByte (Lines _ _ _ b) = b columnByte (Directed _ _ _ _ b) = b-{-# INLINE columnByte #-}+{-# inlinable columnByte #-} instance HasBytes Delta where bytes (Columns _ b) = b@@ -136,19 +172,25 @@ -- | Increment a column number to the next tabstop. nextTab :: Int64 -> Int64 nextTab x = x + (8 - mod x 8)-{-# INLINE nextTab #-}+{-# inlinable nextTab #-} -- | Rewind a 'Delta' to the beginning of the line. rewind :: Delta -> Delta rewind (Lines n _ b d) = Lines n 0 (b - d) 0 rewind (Directed p n _ b d) = Directed p n 0 (b - d) 0 rewind _ = Columns 0 0-{-# INLINE rewind #-}+{-# inlinable rewind #-} -- | Should we show two things with a 'Delta' on the same line?+--+-- >>> 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 #-}+{-# inlinable near #-} class HasDelta t where delta :: t -> Delta
src/Text/Trifecta/Highlight.hs view
@@ -1,13 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# language CPP #-}+{-# language OverloadedStrings #-}+{-# language TemplateHaskell #-} -#ifndef MIN_VERSION_lens-#define MIN_VERSION_lens(x,y,z) 1-#endif ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2011-2015 Edward Kmett+-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com>@@ -25,42 +22,42 @@ , doc ) where -import Control.Lens-#if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710- hiding (Empty)-#endif+import Control.Lens hiding (Empty) import Data.Foldable as F import Data.Int (Int64) import Data.List (sort) import Data.Semigroup import Data.Semigroup.Union import Prelude hiding (head)+import Prettyprinter+import Prettyprinter.Render.Terminal (color)+import qualified Prettyprinter.Render.Terminal as Pretty import Text.Blaze import Text.Blaze.Html5 hiding (a,b,i) import qualified Text.Blaze.Html5 as Html5 import Text.Blaze.Html5.Attributes hiding (title,id) import Text.Blaze.Internal (MarkupM(Empty, Leaf)) import Text.Parser.Token.Highlight-import Text.PrettyPrint.ANSI.Leijen hiding ((<>))-import Text.Trifecta.Util.IntervalMap as IM+import qualified Data.ByteString.Lazy.Char8 as L+ import Text.Trifecta.Delta import Text.Trifecta.Rope-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.Util.Pretty -- | Convert a 'Highlight' into a coloration on a 'Doc'.-withHighlight :: Highlight -> Doc -> Doc-withHighlight Comment = blue-withHighlight ReservedIdentifier = magenta-withHighlight ReservedConstructor = magenta-withHighlight EscapeCode = magenta-withHighlight Operator = yellow-withHighlight CharLiteral = cyan-withHighlight StringLiteral = cyan-withHighlight Constructor = bold-withHighlight ReservedOperator = yellow-withHighlight ConstructorOperator = yellow-withHighlight ReservedConstructorOperator = yellow+withHighlight :: Highlight -> Doc AnsiStyle -> Doc AnsiStyle+withHighlight Comment = annotate (color Pretty.Blue)+withHighlight ReservedIdentifier = annotate (color Pretty.Magenta)+withHighlight ReservedConstructor = annotate (color Pretty.Magenta)+withHighlight EscapeCode = annotate (color Pretty.Magenta)+withHighlight Operator = annotate (color Pretty.Yellow)+withHighlight CharLiteral = annotate (color Pretty.Cyan)+withHighlight StringLiteral = annotate (color Pretty.Cyan)+withHighlight Constructor = annotate Pretty.bold+withHighlight ReservedOperator = annotate (color Pretty.Yellow)+withHighlight ConstructorOperator = annotate (color Pretty.Yellow)+withHighlight ReservedConstructorOperator = annotate (color Pretty.Yellow) withHighlight _ = id -- | A 'HighlightedRope' is a 'Rope' with an associated 'IntervalMap' full of highlighted regions.@@ -106,23 +103,8 @@ | otherwise = unsafeLazyByteString om >> go eb nom es where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs -#if MIN_VERSION_blaze_markup(0,8,0) emptyMarkup = Empty () leafMarkup a b c = Leaf a b c ()-#else- emptyMarkup = Empty- leafMarkup a b c = Leaf a b c-#endif--instance Pretty HighlightedRope where- pretty (HighlightedRope intervals r) = go mempty lbs boundaries where- lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)]- ints = intersections mempty (delta r) intervals- boundaries = sort [ i | (Interval lo hi, _) <- ints, i <- [ lo, hi ] ]- dominated l h = Prelude.foldr (fmap . withHighlight . snd) id (dominators l h intervals)- go l cs [] = dominated l (delta r) $ pretty (LazyUTF8.toString cs)- go l cs (h:es) = dominated l h (pretty (LazyUTF8.toString om)) <> go h nom es- where (om,nom) = L.splitAt (fromIntegral (bytes h - bytes l)) cs -- | Represents a source file like an HsColour rendered document data HighlightDoc = HighlightDoc
− src/Text/Trifecta/Instances.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Copyright : (c) Edward Kmett 2013-2015--- License : BSD3------ Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable------ Orphan instances we need to remain sane.-------------------------------------------------------------------------------module Text.Trifecta.Instances () where--#if !MIN_VERSION_ansi_wl_pprint(0,6,8)-import Text.PrettyPrint.ANSI.Leijen-import qualified Data.Semigroup as Data--instance Data.Semigroup Doc where- (<>) = (<>)-#endif
src/Text/Trifecta/Parser.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}+{-# language BangPatterns #-}+{-# language CPP #-}+{-# language DeriveFoldable #-}+{-# language DeriveFunctor #-}+{-# language DeriveTraversable #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language MultiParamTypeClasses #-}+{-# language Rank2Types #-}+{-# language TemplateHaskell #-} ----------------------------------------------------------------------------- -- |--- Copyright : (c) Edward Kmett 2011-2015+-- Copyright : (c) Edward Kmett 2011-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com@@ -29,6 +30,7 @@ , stepResult , stepIt -- * Parsing+ , runParser , parseFromFile , parseFromFileEx , parseString@@ -42,24 +44,26 @@ 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)+import Prettyprinter as Pretty hiding (line) import System.IO import Text.Parser.Combinators import Text.Parser.Char import Text.Parser.LookAhead import Text.Parser.Token-import Text.PrettyPrint.ANSI.Leijen as Pretty hiding (line, (<>), (<$>), empty) import Text.Trifecta.Combinators-import Text.Trifecta.Instances ()+import Text.Trifecta.Delta as Delta import Text.Trifecta.Rendering import Text.Trifecta.Result import Text.Trifecta.Rope-import Text.Trifecta.Delta as Delta import Text.Trifecta.Util.It+import Text.Trifecta.Util.Pretty -- | The type of a trifecta parser --@@ -94,52 +98,53 @@ -- 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 fmap f (Parser m) = Parser $ \ eo ee co -> m (eo . f) ee (co . f)- {-# INLINE fmap #-}+ {-# inlinable fmap #-} a <$ Parser m = Parser $ \ eo ee co -> m (\_ -> eo a) ee (\_ -> co a)- {-# INLINE (<$) #-}+ {-# inlinable (<$) #-} instance Applicative Parser where pure a = Parser $ \ eo _ _ _ _ _ -> eo a mempty- {-# INLINE pure #-}+ {-# inlinable pure #-} (<*>) = ap- {-# INLINE (<*>) #-}+ {-# inlinable (<*>) #-} instance Alternative Parser where empty = Parser $ \_ ee _ _ _ _ -> ee mempty- {-# INLINE empty #-}+ {-# inlinable empty #-} Parser m <|> Parser n = Parser $ \ eo ee co ce d bs -> m eo (\e -> n (\a e' -> eo a (e <> e')) (\e' -> ee (e <> e')) co ce d bs) co ce d bs- {-# INLINE (<|>) #-}+ {-# inlinable (<|>) #-} many p = Prelude.reverse <$> manyAccum (:) p- {-# INLINE many #-}+ {-# inlinable many #-} some p = (:) <$> p <*> Alternative.many p instance Semigroup a => Semigroup (Parser a) where (<>) = liftA2 (<>)- {-# INLINE (<>) #-}+ {-# inlinable (<>) #-} instance (Semigroup a, Monoid a) => Monoid (Parser a) where mappend = (<>)- {-# INLINE mappend #-}+ {-# inlinable mappend #-} mempty = pure mempty- {-# INLINE mempty #-}+ {-# inlinable mempty #-} instance Monad Parser where return = pure- {-# INLINE return #-}+ {-# inlinable return #-} Parser m >>= k = Parser $ \ eo ee co ce d bs -> m -- epsilon result: feed result to monadic continutaion; committed -- continuations as they were given to us; epsilon callbacks merge@@ -169,21 +174,23 @@ d' bs') -- committed error, delta, and bytestring: as given ce d bs- {-# INLINE (>>=) #-}+ {-# inlinable (>>=) #-} (>>) = (*>)- {-# INLINE (>>) #-}+ {-# inlinable (>>) #-}+#if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail- {-# INLINE fail #-}+ {-# inlinable fail #-}+#endif instance Fail.MonadFail Parser where fail s = Parser $ \ _ ee _ _ _ _ -> ee (failed s)- {-# INLINE fail #-}+ {-# inlinable fail #-} instance MonadPlus Parser where mzero = empty- {-# INLINE mzero #-}+ {-# inlinable mzero #-} mplus = (<|>)- {-# INLINE mplus #-}+ {-# inlinable mplus #-} manyAccum :: (a -> [a] -> [a]) -> Parser a -> Parser [a] manyAccum f (Parser p) = Parser $ \eo _ co ce d bs ->@@ -196,31 +203,31 @@ liftIt m = Parser $ \ eo _ _ _ _ _ -> do a <- m eo a mempty-{-# INLINE liftIt #-}+{-# inlinable liftIt #-} instance Parsing Parser where try (Parser m) = Parser $ \ eo ee co _ -> m eo ee co (\_ -> ee mempty)- {-# INLINE try #-}+ {-# inlinable try #-} Parser m <?> nm = Parser $ \ eo ee -> m (\a e -> eo a (if isJust (_reason e) then e { _expected = Set.singleton nm } else e)) (\e -> ee e { _expected = Set.singleton nm })- {-# INLINE (<?>) #-}+ {-# inlinable (<?>) #-} skipMany p = () <$ manyAccum (\_ _ -> []) p- {-# INLINE skipMany #-}+ {-# inlinable skipMany #-} unexpected s = Parser $ \ _ ee _ _ _ _ -> ee $ failed $ "unexpected " ++ s- {-# INLINE unexpected #-}+ {-# inlinable unexpected #-} eof = notFollowedBy anyChar <?> "end of input"- {-# INLINE eof #-}+ {-# inlinable eof #-} notFollowedBy p = try (optional p >>= maybe (pure ()) (unexpected . show))- {-# INLINE notFollowedBy #-}+ {-# inlinable notFollowedBy #-} instance Errable Parser where raiseErr e = Parser $ \ _ ee _ _ _ _ -> ee e- {-# INLINE raiseErr #-}+ {-# inlinable raiseErr #-} instance LookAheadParsing Parser where lookAhead (Parser m) = Parser $ \eo ee _ -> m eo ee (\a _ _ _ -> eo a mempty)- {-# INLINE lookAhead #-}+ {-# inlinable lookAhead #-} instance CharParsing Parser where satisfy f = Parser $ \ _ ee co _ d bs ->@@ -233,27 +240,27 @@ (co c mempty) ddc | otherwise -> co c mempty (d <> delta c) bs- {-# INLINE satisfy #-}+ {-# inlinable satisfy #-} instance TokenParsing Parser instance DeltaParsing Parser where line = Parser $ \eo _ _ _ _ bs -> eo bs mempty- {-# INLINE line #-}+ {-# inlinable line #-} position = Parser $ \eo _ _ _ d _ -> eo d mempty- {-# INLINE position #-}+ {-# inlinable position #-} rend = Parser $ \eo _ _ _ d bs -> eo (rendered d bs) mempty- {-# INLINE rend #-}+ {-# inlinable rend #-} slicedWith f p = do m <- position a <- p r <- position f a <$> liftIt (sliceIt m r)- {-# INLINE slicedWith #-}+ {-# inlinable slicedWith #-} instance MarkParsing Delta Parser where mark = position- {-# INLINE mark #-}+ {-# inlinable mark #-} release d' = Parser $ \_ ee co _ d bs -> do mbs <- rewindIt d' case mbs of@@ -264,10 +271,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,28 +304,32 @@ 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 #-}+{-# inlinable feed #-} +-- | Assume all possible input has been given to the parser, execute it to yield+-- a final result. starve :: Step a -> Result a starve (StepDone _ a) = Success a starve (StepFail _ xs) = Failure xs starve (StepCont _ z _) = z-{-# INLINE starve #-}+{-# inlinable starve #-} stepResult :: Rope -> Result a -> Step a stepResult r (Success a) = StepDone r a stepResult r (Failure xs) = StepFail r xs-{-# INLINE stepResult #-}+{-# inlinable stepResult #-} stepIt :: It Rope a -> Step a stepIt = go mempty where- go r (Pure a) = StepDone r a- go r (It a k) = StepCont r (pure a) $ \s -> go s (k s)-{-# INLINE stepIt #-}+ go r m = case simplifyIt m r of+ Pure a -> StepDone r a+ It a k -> StepCont r (pure a) $ \r' -> go r' (k r')+{-# inlinable stepIt #-} data Stepping a = EO a Err@@ -311,30 +337,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)+ {-# inlinable joinStep #-}++-- | Run a 'Parser' on input that can be reduced to a 'Rope', e.g. 'String', or+-- 'ByteString'. See also the monomorphic versions 'parseString' and+-- 'parseByteString'.+runParser+ :: Reducer t Rope+ => Parser a+ -> Delta -- ^ Starting cursor position. Usually 'mempty' for the beginning of the file.+ -> t+ -> Result a+runParser p d bs = starve $ feed bs $ stepParser p d+{-# inlinable runParser #-}++-- | @('parseFromFile' p filePath)@ runs a parser @p@ on the input read from+-- @filePath@ using 'ByteString.readFile'. All diagnostic messages emitted over+-- the course of the parse attempt are shown to the user on the console. -- -- > main = do -- > result <- parseFromFile numbers "digits.txt"@@ -347,34 +394,45 @@ case result of Success a -> return (Just a) Failure xs -> do- liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak+ liftIO $ renderIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> line' return Nothing --- | @parseFromFileEx p filePath@ runs a parser @p@ on the--- input read from @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- Failure xs -> liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak -- TODO: retrieve columns+ Failure xs -> liftIO $ renderIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> line' -- TODO: retrieve columns Success a -> liftIO (print a)
src/Text/Trifecta/Rendering.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveGeneric #-}+{-# language CPP #-}+{-# language DeriveDataTypeable #-}+{-# language DeriveGeneric #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language TemplateHaskell #-}+{-# language TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2011-2015 Edward Kmett+-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com>@@ -24,10 +25,12 @@ , HasRendering(..) , nullRendering , emptyRendering+ , prettyRendering , Source(..) , rendered , Renderable(..) , Rendered(..)+ , gutterEffects -- * Carets , Caret(..) , HasCaret(..)@@ -55,82 +58,99 @@ , (.#) ) 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 qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Semigroup+import Data.Semigroup.Reducer+import GHC.Generics+import Prelude as P hiding (span)+import Prettyprinter hiding (column, line')+import Prettyprinter.Render.Terminal (color, bgColor, colorDull, bgColorDull)+import qualified Prettyprinter.Render.Terminal as Pretty+import System.Console.ANSI+ import Text.Trifecta.Delta-import Text.Trifecta.Instances () import Text.Trifecta.Util.Combinators+import Text.Trifecta.Util.Pretty +-- $setup+--+-- >>> :set -XOverloadedStrings+-- >>> import Data.ByteString (ByteString)+-- >>> import Data.Monoid (mempty)+-- >>> import Prettyprinter (unAnnotate)+-- >>> import Text.Trifecta.Delta+-- >>> let exampleRendering = rendered mempty ("int main(int argc, char ** argv) { int; }" :: ByteString)+ outOfRangeEffects :: [SGR] -> [SGR] outOfRangeEffects xs = SetConsoleIntensity BoldIntensity : xs -sgr :: [SGR] -> Doc -> Doc+sgr :: [SGR] -> Doc AnsiStyle -> Doc AnsiStyle sgr xs0 = go (P.reverse xs0) where go [] = id- go (SetConsoleIntensity NormalIntensity : xs) = debold . go xs- go (SetConsoleIntensity BoldIntensity : xs) = bold . go xs- go (SetUnderlining NoUnderline : xs) = deunderline . go xs- go (SetUnderlining SingleUnderline : xs) = underline . go xs+ go (SetConsoleIntensity NormalIntensity : xs) = annotate debold . go xs+ go (SetConsoleIntensity BoldIntensity : xs) = annotate bold . go xs+ go (SetUnderlining NoUnderline : xs) = annotate deunderline . go xs+ go (SetUnderlining SingleUnderline : xs) = annotate underlined . go xs go (SetColor f i c : xs) = case f of+#if MIN_VERSION_ansi_terminal(1,1,0)+ Underlining -> go xs+#endif Foreground -> case i of Dull -> case c of- Black -> dullblack . go xs- Red -> dullred . go xs- Green -> dullgreen . go xs- Yellow -> dullyellow . go xs- Blue -> dullblue . go xs- Magenta -> dullmagenta . go xs- Cyan -> dullcyan . go xs- White -> dullwhite . go xs+ Black -> annotate (color Pretty.Black) . go xs+ Red -> annotate (color Pretty.Red) . go xs+ Green -> annotate (color Pretty.Green) . go xs+ Yellow -> annotate (color Pretty.Yellow) . go xs+ Blue -> annotate (color Pretty.Blue) . go xs+ Magenta -> annotate (color Pretty.Magenta) . go xs+ Cyan -> annotate (color Pretty.Cyan) . go xs+ White -> annotate (color Pretty.White) . go xs Vivid -> case c of- Black -> black . go xs- Red -> red . go xs- Green -> green . go xs- Yellow -> yellow . go xs- Blue -> blue . go xs- Magenta -> magenta . go xs- Cyan -> cyan . go xs- White -> white . go xs+ Black -> annotate (colorDull Pretty.Black) . go xs+ Red -> annotate (colorDull Pretty.Red) . go xs+ Green -> annotate (colorDull Pretty.Green) . go xs+ Yellow -> annotate (colorDull Pretty.Yellow) . go xs+ Blue -> annotate (colorDull Pretty.Blue) . go xs+ Magenta -> annotate (colorDull Pretty.Magenta) . go xs+ Cyan -> annotate (colorDull Pretty.Cyan) . go xs+ White -> annotate (colorDull Pretty.White) . go xs Background -> case i of Dull -> case c of- Black -> ondullblack . go xs- Red -> ondullred . go xs- Green -> ondullgreen . go xs- Yellow -> ondullyellow . go xs- Blue -> ondullblue . go xs- Magenta -> ondullmagenta . go xs- Cyan -> ondullcyan . go xs- White -> ondullwhite . go xs+ Black -> annotate (bgColorDull Pretty.Black) . go xs+ Red -> annotate (bgColorDull Pretty.Red) . go xs+ Green -> annotate (bgColorDull Pretty.Green) . go xs+ Yellow -> annotate (bgColorDull Pretty.Yellow) . go xs+ Blue -> annotate (bgColorDull Pretty.Blue) . go xs+ Magenta -> annotate (bgColorDull Pretty.Magenta) . go xs+ Cyan -> annotate (bgColorDull Pretty.Cyan) . go xs+ White -> annotate (bgColorDull Pretty.White) . go xs Vivid -> case c of- Black -> onblack . go xs- Red -> onred . go xs- Green -> ongreen . go xs- Yellow -> onyellow . go xs- Blue -> onblue . go xs- Magenta -> onmagenta . go xs- Cyan -> oncyan . go xs- White -> onwhite . go xs+ Black -> annotate (bgColor Pretty.Black) . go xs+ Red -> annotate (bgColor Pretty.Red) . go xs+ Green -> annotate (bgColor Pretty.Green) . go xs+ Yellow -> annotate (bgColor Pretty.Yellow) . go xs+ Blue -> annotate (bgColor Pretty.Blue) . go xs+ Magenta -> annotate (bgColor Pretty.Magenta) . go xs+ Cyan -> annotate (bgColor Pretty.Cyan) . go xs+ White -> annotate (bgColor Pretty.White) . go xs go (_ : xs) = go xs +-- | A raw canvas to paint ANSI-styled characters on. 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 +161,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 +179,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 +201,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 (prettyRendering emptyRendering)+-- "" emptyRendering :: Rendering emptyRendering = Rendering (Columns 0 0) 0 0 id (const id) @@ -184,7 +228,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 +247,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 +268,6 @@ go n (x:xs) = x : go (n + 1) xs go _ [] = [] - instance Source ByteString where source = source . UTF8.toString @@ -226,24 +279,38 @@ (.#) :: (Delta -> Lines -> Lines) -> Rendering -> Rendering f .# Rendering d ll lb s g = Rendering d ll lb s $ \e l -> f e $ g e l -instance Pretty Rendering where- pretty (Rendering d ll _ l f) = nesting $ \k -> columns $ \mn -> go (fromIntegral (fromMaybe 80 mn - k)) where- go cols = align (vsep (P.map ln [t..b])) where- (lo, hi) = window (column d) ll (min (max (cols - 2) 30) 200)- a = f d $ l $ array ((0,lo),(-1,hi)) []- ((t,_),(b,_)) = bounds a- ln y = hcat- $ P.map (\g -> sgr (fst (P.head g)) (pretty (P.map snd g)))- $ groupBy ((==) `on` fst)- [ a ! (y,i) | i <- [lo..hi] ]+prettyRendering :: Rendering -> Doc AnsiStyle+prettyRendering (Rendering d ll _ l f) = nesting $ \k -> columns $ \mn -> go (fromIntegral (fromMaybe 80 mn - k)) where+ go cols = align (vsep (P.map ln [t..b])) where+ (lo, hi) = window (column d) ll (min (max (cols - 5 - fromIntegral gutterWidth) 30) 200)+ a = f d $ l $ array ((0,lo),(-1,hi)) []+ ((t,_),(b,_)) = bounds a+ n = show $ case d of+ Lines n' _ _ _ -> 1 + n'+ Directed _ n' _ _ _ -> 1 + n'+ _ -> 1+ separator = char '|'+ gutterWidth = P.length n+ gutter = pretty n <+> separator+ margin = fill gutterWidth space <+> separator+ ln y = (sgr gutterEffects (if y == 0 then gutter else margin) <+>)+ $ hcat+ $ P.map (\g -> sgr (fst (NE.head g)) (pretty (fmap snd g)))+ $ NE.groupBy ((==) `on` fst)+ [ a ! (y,i) | i <- [lo..hi] ] window :: Int64 -> Int64 -> Int64 -> (Int64, Int64) window c l w | 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 +-- | ANSI terminal style for rendering the gutter.+gutterEffects :: [SGR]+gutterEffects = [SetColor Foreground Vivid Blue]+ data Rendered a = a :@ Rendering deriving Show @@ -272,13 +339,12 @@ 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; }--- > ^-data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic)+-- | A 'Caret' marks a point in the input with a simple @^@ character.+--+-- >>> unAnnotate (prettyRendering (addCaret (Columns 35 35) exampleRendering))+-- 1 | int main(int argc, char ** argv) { int; }<EOF>+-- | ^+data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Generic) class HasCaret t where caret :: Lens' t Caret@@ -288,12 +354,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 @@ -315,7 +383,7 @@ renderingCaret :: Delta -> ByteString -> Rendering renderingCaret d bs = addCaret d $ rendered d bs -data Careted a = a :^ Caret deriving (Eq,Ord,Show,Data,Typeable,Generic)+data Careted a = a :^ Caret deriving (Eq,Ord,Show,Data,Generic) instance HasCaret (Careted a) where caret f (a :^ c) = (a :^) <$> f c@@ -350,30 +418,39 @@ 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 -data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic)+-- | A 'Span' marks a range of input characters. If 'Caret' is a point, then+-- 'Span' is a line.+--+-- >>> unAnnotate (prettyRendering (addSpan (Columns 35 35) (Columns 38 38) exampleRendering))+-- 1 | int main(int argc, char ** argv) { int; }<EOF>+-- | ~~~+data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Generic) class HasSpan t where span :: Lens' t Span@@ -392,7 +469,9 @@ instance Hashable Span -data Spanned a = a :~ Span deriving (Eq,Ord,Show,Data,Typeable,Generic)+-- | Annotate an arbitrary piece of data with a 'Span', typically its+-- corresponding input location.+data Spanned a = a :~ Span deriving (Eq,Ord,Show,Data,Generic) instance HasSpan (Spanned a) where span f (a :~ c) = (a :~) <$> f c@@ -421,9 +500,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,10 +508,18 @@ addFixit :: Delta -> Delta -> String -> Rendering -> Rendering addFixit s e rpl r = drawFixit s e rpl .# r +-- | A 'Fixit' is a 'Span' with a suggestion.+--+-- >>> unAnnotate (prettyRendering (addFixit (Columns 35 35) (Columns 38 38) "Fix this!" exampleRendering))+-- 1 | int main(int argc, char ** argv) { int; }<EOF>+-- | ~~~+-- | Fix this! data Fixit = Fixit- { _fixitSpan :: {-# UNPACK #-} !Span+ { _fixitSpan :: {-# UNPACK #-} !Span+ -- ^ 'Span' where the error occurred , _fixitReplacement :: !ByteString- } deriving (Eq,Ord,Show,Data,Typeable,Generic)+ -- ^ Replacement suggestion+ } deriving (Eq,Ord,Show,Data,Generic) makeClassy ''Fixit
src/Text/Trifecta/Result.hs view
@@ -1,17 +1,17 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}+{-# language CPP #-}+{-# language DeriveFoldable #-}+{-# language DeriveFunctor #-}+{-# language DeriveTraversable #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language MultiParamTypeClasses #-}+{-# language Rank2Types #-}+{-# language TemplateHaskell #-}+{-# language UndecidableInstances #-} ----------------------------------------------------------------------------- -- |--- Copyright : (c) Edward Kmett 2011-2015+-- Copyright : (c) Edward Kmett 2011-2019 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com@@ -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 Text.Trifecta.Instances ()+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 Prettyprinter as Pretty+import Prettyprinter.Render.Terminal as Pretty++import Text.Trifecta.Delta as Delta import Text.Trifecta.Rendering-import Text.Trifecta.Delta as Delta+import Text.Trifecta.Util.Pretty as Pretty data ErrInfo = ErrInfo- { _errDoc :: Doc+ { _errDoc :: Doc AnsiStyle , _errDeltas :: [Delta]- } deriving(Show)+ } deriving (Show) --- | This is used to report an error. What went wrong, some supplemental docs and a set of things expected--- at the current location. This does not, however, include the actual location.+-- | 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 AnsiStyle)+ , _footnotes :: [Doc AnsiStyle]+ , _expected :: Set String , _finalDeltas :: [Delta] } @@ -66,21 +72,22 @@ instance Semigroup Err where Err md mds mes delta1 <> Err nd nds nes delta2 = Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes) (delta1 <> delta2)- {-# INLINE (<>) #-}+ {-# inlinable (<>) #-} instance Monoid Err where mempty = Err Nothing [] mempty mempty- {-# INLINE mempty #-}+ {-# inlinable mempty #-} mappend = (<>)- {-# INLINE mappend #-}+ {-# inlinable mappend #-} -- | Generate a simple 'Err' word-wrapping the supplied message. failed :: String -> Err failed m = Err (Just (fillSep (pretty <$> words m))) [] mempty mempty-{-# INLINE failed #-}+{-# inlinable failed #-} --- | Convert a location and an 'Err' into a 'Doc'-explain :: Rendering -> Err -> Doc+-- | Convert a 'Rendering' of auxiliary information and an 'Err' into a 'Doc AnsiStyle',+-- ready to be prettyprinted to the user.+explain :: Rendering -> Err -> Doc AnsiStyle explain r (Err mm as es _) | Set.null es = report (withEx mempty) | isJust mm = report $ withEx $ Pretty.char ',' <+> expecting@@ -89,10 +96,10 @@ now = spaceHack $ toList es spaceHack [""] = ["space"] spaceHack xs = List.filter (/= "") xs- withEx x = fromMaybe (fillSep $ text <$> words "unspecified error") mm <> x- expecting = text "expected:" <+> fillSep (punctuate (Pretty.char ',') (text <$> now))- report txt = vsep $ [pretty (delta r) <> Pretty.char ':' <+> red (text "error") <> Pretty.char ':' <+> nest 4 txt]- <|> pretty r <$ guard (not (nullRendering r))+ withEx x = fromMaybe (fillSep $ pretty <$> words "unspecified error") mm <> x+ expecting = pretty "expected:" <+> fillSep (punctuate (Pretty.char ',') (pretty <$> now))+ report txt = vsep $ [prettyDelta (delta r) <> Pretty.char ':' <+> annotate (Pretty.color Pretty.Red) (pretty "error") <> Pretty.char ':' <+> nest 4 txt]+ <|> prettyRendering r <$ guard (not (nullRendering r)) <|> as class Errable m where@@ -111,41 +118,43 @@ | Failure ErrInfo deriving (Show,Functor,Foldable,Traversable) +-- | Fold over a 'Result'+foldResult :: (ErrInfo -> b) -> (a -> b) -> Result a -> b+foldResult f g r = case r of+ Failure e -> f e+ Success a -> g a+ -- | A 'Prism' that lets you embed or retrieve a 'Result' in a potentially larger type. class AsResult s t a b | s -> a, t -> b, s b -> t, t a -> s where _Result :: Prism s t (Result a) (Result b) instance AsResult (Result a) (Result b) a b where _Result = id- {-# INLINE _Result #-}+ {-# inlinable _Result #-} -- | The 'Prism' for the 'Success' constructor of 'Result' _Success :: AsResult s t a b => Prism s t a b _Success = _Result . dimap seta (either id id) . right' . rmap (fmap Success) where seta (Success a) = Right a seta (Failure e) = Left (pure (Failure e))-{-# INLINE _Success #-}+{-# inlinable _Success #-} -- | The 'Prism' for the 'Failure' constructor of 'Result' _Failure :: AsResult s s a a => Prism' s ErrInfo _Failure = _Result . dimap seta (either id id) . right' . rmap (fmap Failure) where seta (Failure e) = Right e seta (Success a) = Left (pure (Success a))-{-# INLINE _Failure #-}--instance Show a => Pretty (Result a) where- pretty (Success a) = pretty (show a)- pretty (Failure xs) = pretty . _errDoc $ xs+{-# inlinable _Failure #-} instance Applicative Result where pure = Success- {-# INLINE pure #-}+ {-# inlinable pure #-} Success f <*> Success a = Success (f a) Success _ <*> Failure y = Failure y Failure x <*> Success _ = Failure x Failure x <*> Failure y = Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y)- {-# INLINE (<*>) #-}+ {-# inlinable (<*>) #-} instance Alternative Result where Failure x <|> Failure y =@@ -153,6 +162,11 @@ Success a <|> Success _ = Success a Success a <|> Failure _ = Success a Failure _ <|> Success a = Success a- {-# INLINE (<|>) #-}+ {-# inlinable (<|>) #-} empty = Failure mempty- {-# INLINE empty #-}+ {-# inlinable empty #-}++instance Monad Result where+ return = pure+ Success a >>= m = m a+ Failure e >>= _ = Failure e
src/Text/Trifecta/Rope.hs view
@@ -1,17 +1,27 @@-{-# 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+-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com> -- 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,39 @@ , 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 Data.ByteString (ByteString)+-- >>> import qualified Data.ByteString.UTF8 as Strict+-- >>> import qualified Data.ByteString.Lazy.UTF8 as Lazy+-- >>> import Text.Trifecta.Delta++-- A 'Strand' is a chunk of data; many 'Strand's together make a 'Rope'. data Strand- = Strand {-# UNPACK #-} !ByteString !Delta- | Skipping !Delta- deriving (Show, Data, Typeable, Generic)+ = Strand {-# UNPACK #-} !ByteString !Delta -- ^ Data of a certain length+ | Skipping !Delta -- ^ Absence of data of a certain length+ deriving (Eq, Show, Data, Generic) +-- | Construct a single 'Strand' out of a 'ByteString'. strand :: ByteString -> Strand strand bs = Strand bs (delta bs) @@ -59,22 +83,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 documentation for :-)"++-- | In order to keep things minimal, we define a very simple language for+-- arithmetic expressions.+data Expr+ = Add Expr Expr -- ^ expr + expr+ | Lit Integer -- ^ 1, 2, -345, …+ deriving (Show)++-- | The parser is straightforward: there are literal integers, and+-- parenthesized additions. We require parentheses in order to keep the example+-- super simple as to not worry about operator precedence.+--+-- It is useful to use /tokenizing/ functions to write parsers. Roughly+-- speaking, these automatically skip trailing whitespace on their own, so that+-- the parser isn’t cluttered with 'skipWhitespace' calls. 'symbolic' for+-- example parses a 'Char' and then skips trailing whitespace; there is also the+-- more primitive 'char' function that just parses its argument and nothing+-- else.+parseExpr :: Parser Expr+parseExpr = parseAdd <|> parseLit+ where+ parseAdd = parens $ do+ x <- parseExpr+ _ <- symbolic '+'+ y <- parseExpr+ pure (Add x y)+ parseLit = Lit <$> integer++-- | We can now use our parser to convert a 'String' to an 'Expr',+--+-- @+-- parseString parseExpr mempty "(1 + (2 + 3))"+-- @+--+-- > Success (Add (Lit 1) (Add (Lit 2) (Lit 3)))+--+-- When we provide ill-formed input, we get a nice error message with an arrow+-- to the location where the error occurred:+--+-- @+-- parseString parseExpr mempty "(1 + 2 + 3))"+-- @+--+-- > (interactive):1:8: error: expected: ")"+-- > 1 | (1 + 2 + 3))<EOF>+-- > | ^+examples :: docDummy+examples = error "Haddock dummy for documentation"
− src/Text/Trifecta/Util/Array.hs
@@ -1,397 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}--------------------------------------------------------------------------------- |--- Copyright : Edward Kmett 2011-2015--- Johan Tibell 2011--- License : BSD3------ Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : unknown------ Fast zero based arrays, based on the implementation in the HAMT-branch of--- unordered-containers-------------------------------------------------------------------------------module Text.Trifecta.Util.Array- ( Array- , MArray-- -- * Creation- , new- , new_- , empty- , singleton-- -- * Basic interface- , length- , lengthM- , read- , write- , index- , index_- , indexM_- , update- , insert- , delete-- , unsafeFreeze- , run- , run2- , copy- , copyM-- -- * Folds- , foldl'- , foldr-- , thaw- , map- , map'- , traverse- , filter- ) where--import qualified Data.Traversable as Traversable-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative)-#endif-import Control.DeepSeq-import Control.Monad.ST-import GHC.Exts (- Array#,- copyArray#,- copyMutableArray#,- indexArray#,- Int(I#),- MutableArray#,- newArray#,- readArray#,- sizeofArray#,- sizeofMutableArray#,- thawArray#,- unsafeFreezeArray#,- writeArray#)-import GHC.ST (ST(..))--import Prelude hiding (filter, foldr, length, map, read-#if __GLASGOW_HASKELL__ >= 710- , traverse-#endif- )----------------------------------------------------------------------------#if defined(ASSERTS)--- This fugly hack is brought by GHC's apparent reluctance to deal--- with MagicHash and UnboxedTuples when inferring types. Eek!-# define CHECK_BOUNDS(_func_,_len_,_k_) \-if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else-# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \-if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else-# define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_)-# define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_)-#else-# define CHECK_BOUNDS(_func_,_len_,_k_)-# define CHECK_OP(_func_,_op_,_lhs_,_rhs_)-# define CHECK_GT(_func_,_lhs_,_rhs_)-# define CHECK_LE(_func_,_lhs_,_rhs_)-#endif--data Array a = Array {- unArray :: !(Array# a)-#if __GLASGOW_HASKELL__ < 702- , length :: {-# UNPACK #-} !Int-#endif- }--#if __GLASGOW_HASKELL__ >= 702-length :: Array a -> Int-length ary = I# (sizeofArray# (unArray ary))-{-# INLINE length #-}-#endif---- | Smart constructor-array :: Array# a -> Int -> Array a-#if __GLASGOW_HASKELL__ >= 702-array ary _n = Array ary-#else-array = Array-#endif-{-# INLINE array #-}--data MArray s a = MArray {- unMArray :: !(MutableArray# s a)-#if __GLASGOW_HASKELL__ < 702- , lengthM :: {-# UNPACK #-} !Int-#endif- }--#if __GLASGOW_HASKELL__ >= 702-lengthM :: MArray s a -> Int-lengthM mary = I# (sizeofMutableArray# (unMArray mary))-{-# INLINE lengthM #-}-#endif---- | Smart constructor-marray :: MutableArray# s a -> Int -> MArray s a-#if __GLASGOW_HASKELL__ >= 702-marray mary _n = MArray mary-#else-marray = MArray-#endif-{-# INLINE marray #-}----------------------------------------------------------------------------instance NFData a => NFData (Array a) where- rnf = rnfArray--rnfArray :: NFData a => Array a -> ()-rnfArray ary0 = go ary0 n0 0 where- n0 = length ary0- go !ary !n !i- | i >= n = ()- | otherwise = rnf (index ary i) `seq` go ary n (i+1)-{-# INLINE rnfArray #-}---- | Create a new mutable array of specified size, in the specified--- state thread, with each element containing the specified initial--- value.-new :: Int -> a -> ST s (MArray s a)-new n@(I# n#) b =- CHECK_GT("new",n,(0 :: Int))- ST $ \s -> case newArray# n# b s of- (# s', ary #) -> (# s', marray ary n #)-{-# INLINE new #-}--new_ :: Int -> ST s (MArray s a)-new_ n = new n undefinedElem--empty :: Array a-empty = run (new_ 0)--singleton :: a -> Array a-singleton x = run (new 1 x)-{-# INLINE singleton #-}--read :: MArray s a -> Int -> ST s a-read ary _i@(I# i#) = ST $ \ s ->- CHECK_BOUNDS("read", lengthM ary, _i)- readArray# (unMArray ary) i# s-{-# INLINE read #-}--write :: MArray s a -> Int -> a -> ST s ()-write ary _i@(I# i#) b = ST $ \ s ->- CHECK_BOUNDS("write", lengthM ary, _i)- case writeArray# (unMArray ary) i# b s of- s' -> (# s' , () #)-{-# INLINE write #-}--index :: Array a -> Int -> a-index ary _i@(I# i#) =- CHECK_BOUNDS("index", length ary, _i)- case indexArray# (unArray ary) i# of (# b #) -> b-{-# INLINE index #-}--index_ :: Array a -> Int -> ST s a-index_ ary _i@(I# i#) =- CHECK_BOUNDS("index_", length ary, _i)- case indexArray# (unArray ary) i# of (# b #) -> return b-{-# INLINE index_ #-}--indexM_ :: MArray s a -> Int -> ST s a-indexM_ ary _i@(I# i#) =- CHECK_BOUNDS("index_", lengthM ary, _i)- ST $ \ s# -> readArray# (unMArray ary) i# s#-{-# INLINE indexM_ #-}--unsafeFreeze :: MArray s a -> ST s (Array a)-unsafeFreeze mary =- ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of- (# s', ary #) -> (# s', array ary (lengthM mary) #)-{-# INLINE unsafeFreeze #-}--run :: (forall s . ST s (MArray s e)) -> Array e-run act = runST $ act >>= unsafeFreeze-{-# INLINE run #-}--run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a)-run2 k = runST $ do- (marr,b) <- k- arr <- unsafeFreeze marr- return (arr,b)---- | Unsafely copy the elements of an array. Array bounds are not checked.-copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s ()-#if __GLASGOW_HASKELL__ >= 702-copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =- CHECK_LE("copy", _sidx + _n, length src)- CHECK_LE("copy", _didx + _n, lengthM dst)- ST $ \ s# -> case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of- s2 -> (# s2, () #)-#else-copy !src !sidx !dst !didx n =- CHECK_LE("copy", sidx + n, length src)- CHECK_LE("copy", didx + n, lengthM dst)- copy_loop sidx didx 0 where- copy_loop !i !j !c- | c >= n = return ()- | otherwise = do- b <- index_ src i- write dst j b- copy_loop (i+1) (j+1) (c+1)-#endif---- | Unsafely copy the elements of an array. Array bounds are not checked.-copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()-#if __GLASGOW_HASKELL__ >= 702-copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =- CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1)- CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1)- ST $ \ s# -> case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of- s2 -> (# s2, () #)-#else-copyM !src !sidx !dst !didx n =- CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1)- CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1)- copy_loop sidx didx 0 where- copy_loop !i !j !c- | c >= n = return ()- | otherwise = do- b <- indexM_ src i- write dst j b- copy_loop (i+1) (j+1) (c+1)-#endif---- | /O(n)/ Insert an element at the given position in this array,--- increasing its size by one.-insert :: Array e -> Int -> e -> Array e-insert ary idx b =- CHECK_BOUNDS("insert", count + 1, idx)- run $ do- mary <- new_ (count+1)- copy ary 0 mary 0 idx- write mary idx b- copy ary idx mary (idx+1) (count-idx)- return mary- where !count = length ary-{-# INLINE insert #-}---- | /O(n)/ Update the element at the given position in this array.-update :: Array e -> Int -> e -> Array e-update ary idx b =- CHECK_BOUNDS("update", count, idx)- run $ do- mary <- thaw ary 0 count- write mary idx b- return mary- where !count = length ary-{-# INLINE update #-}--foldl' :: (b -> a -> b) -> b -> Array a -> b-foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where- go ary n i !z- | i >= n = z- | otherwise = go ary n (i+1) (f z (index ary i))-{-# INLINE foldl' #-}--foldr :: (a -> b -> b) -> b -> Array a -> b-foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where- go ary n i z- | i >= n = z- | otherwise = f (index ary i) (go ary n (i+1) z)-{-# INLINE foldr #-}--undefinedElem :: a-undefinedElem = error "Undefined element"--thaw :: Array e -> Int -> Int -> ST s (MArray s e)-#if __GLASGOW_HASKELL__ >= 702-thaw !ary !_o@(I# o#) !n@(I# n#) =- CHECK_LE("thaw", _o + n, length ary)- ST $ \ s -> case thawArray# (unArray ary) o# n# s of- (# s2, mary# #) -> (# s2, marray mary# n #)-#else-thaw !ary !o !n =- CHECK_LE("thaw", o + n, length ary)- do mary <- new_ n- copy ary o mary 0 n- return mary-#endif-{-# INLINE thaw #-}---- | /O(n)/ Delete an element at the given position in this array,--- decreasing its size by one.-delete :: Array e -> Int -> Array e-delete ary idx = run $ do- mary <- new_ (count-1)- copy ary 0 mary 0 idx- copy ary (idx+1) mary idx (count-(idx+1))- return mary- where !count = length ary-{-# INLINE delete #-}--map :: (a -> b) -> Array a -> Array b-map f = \ ary ->- let !n = length ary- in run $ do- mary <- new_ n- go ary mary 0 n- where- go ary mary i n- | i >= n = return mary- | otherwise = do- write mary i $ f (index ary i)- go ary mary (i+1) n-{-# INLINE map #-}---- | Strict version of 'map'.-map' :: (a -> b) -> Array a -> Array b-map' f = \ ary ->- let !n = length ary- in run $ do- mary <- new_ n- go ary mary 0 n- where- go ary mary i n- | i >= n = return mary- | otherwise = do- write mary i $! f (index ary i)- go ary mary (i+1) n-{-# INLINE map' #-}--fromList :: Int -> [a] -> Array a-fromList n xs0 = run $ do- mary <- new_ n- go xs0 mary 0- where- go [] !mary !_ = return mary- go (x:xs) mary i = do write mary i x- go xs mary (i+1)--toList :: Array a -> [a]-toList = foldr (:) []--traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)-traverse f = \ ary ->- fromList (length ary) `fmap`- Traversable.traverse f (toList ary)-{-# INLINE traverse #-}--filter :: (a -> Bool) -> Array a -> Array a-filter p = \ ary ->- let !n = length ary- in run $ do- mary <- new_ n- go ary mary 0 0 n- where- go ary mary i j n- | i >= n = if i == j- then return mary- else do mary2 <- new_ j- copyM mary 0 mary2 0 j- return mary2- | p el = write mary j el >> go ary mary (i+1) (j+1) n- | otherwise = go ary mary (i+1) j n- where el = index ary i-{-# INLINE filter #-}
src/Text/Trifecta/Util/Combinators.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2011-2015 Edward Kmett+-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com>@@ -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@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.IntervalMap--- Copyright : (c) Edward Kmett 2011-2015+-- Copyright : (c) Edward Kmett 2011-2019 -- (c) Ross Paterson 2008 -- License : BSD-style -- Maintainer : ekmett@gmail.com@@ -52,21 +52,18 @@ , fromList ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative hiding (empty)-import Data.Foldable (Foldable(foldMap))-#endif-import Control.Lens- hiding ((<|),(|>)-#if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710- ,(:<)+import qualified Data.Foldable.WithIndex as WithIndex+import Control.Lens as Lens hiding ((:<), (<|), (|>))+import Data.FingerTree+ (FingerTree, Measured (..), ViewL (..), (<|), (><))+import qualified Data.FingerTree as FT+import qualified Data.Functor.WithIndex as WithIndex+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup #endif- )-import qualified Data.FingerTree as FT-import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><))-import Data.Semigroup-import Data.Semigroup.Reducer-import Data.Semigroup.Union+import Data.Semigroup.Reducer+import Data.Semigroup.Union+import qualified Data.Traversable.WithIndex as WithIndex ---------------------------------- -- 4.8 Application: interval trees@@ -109,21 +106,27 @@ instance Functor (Node v) where fmap f (Node i x) = Node i (f x) -instance FunctorWithIndex (Interval v) (Node v) where+instance WithIndex.FunctorWithIndex (Interval v) (Node v) where imap f (Node i x) = Node i (f i x) instance Foldable (Node v) where foldMap f (Node _ x) = f x -instance FoldableWithIndex (Interval v) (Node v) where+instance WithIndex.FoldableWithIndex (Interval v) (Node v) where ifoldMap f (Node k v) = f k v instance Traversable (Node v) where traverse f (Node i x) = Node i <$> f x -instance TraversableWithIndex (Interval v) (Node v) where+instance WithIndex.TraversableWithIndex (Interval v) (Node v) where itraverse f (Node i x) = Node i <$> f i x +#if !MIN_VERSION_lens(5,0,0)+instance Lens.FunctorWithIndex (Interval v) (Node v) where imap = WithIndex.imap+instance Lens.FoldableWithIndex (Interval v) (Node v) where ifoldMap = WithIndex.ifoldMap+instance Lens.TraversableWithIndex (Interval v) (Node v) where itraverse = WithIndex.itraverse+#endif+ -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v @@ -250,4 +253,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,13 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.It--- Copyright : (C) 2011-2015 Edward Kmett+-- Copyright : (C) 2011-2019 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com>@@ -21,32 +20,56 @@ , needIt , wantIt , simplifyIt+ , foldIt , runIt , fillIt , rewindIt , sliceIt ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import Control.Comonad import Control.Monad -#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif--import Data.ByteString as Strict-import Data.ByteString.Lazy as Lazy+import Data.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.Rope+-- >>> 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 +78,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@@ -65,13 +88,14 @@ pure = Pure Pure f <*> Pure a = Pure $ f a Pure f <*> It a ka = It (f a) $ fmap f . ka- It f kf <*> Pure a = It (f a) $ fmap ($a) . kf+ It f kf <*> Pure a = It (f a) $ fmap ($ a) . kf It f kf <*> It a ka = It (f a) $ \r -> kf r <*> ka r indexIt :: It r a -> r -> a 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 +109,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))
+ src/Text/Trifecta/Util/Pretty.hs view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2011-2019 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+-- Utility functions to augment the prettyprinter library's interface.+----------------------------------------------------------------------------++module Text.Trifecta.Util.Pretty+ ( AnsiStyle+ , renderIO+ -- * Rendering+ , char+ -- * Styles+ , bold+ , debold+ , underlined+ , deunderline+ -- * Compatibility shims+ , renderPretty+ , columns+ ) where+++import Prettyprinter+import Prettyprinter.Render.Terminal+import Prettyprinter.Render.Terminal.Internal (ansiBold, ansiUnderlining)++char :: Char -> Doc a+char = pretty++renderPretty :: Double -> Int -> Doc AnsiStyle -> SimpleDocStream AnsiStyle+renderPretty ribbonFraction page+ = layoutSmart LayoutOptions { layoutPageWidth = AvailablePerLine page ribbonFraction }++debold, deunderline :: AnsiStyle+debold = mempty { ansiBold = Nothing }+deunderline = mempty { ansiUnderlining = Nothing}++columns :: (Maybe Int -> Doc AnsiStyle) -> Doc AnsiStyle+columns f = pageWidth (f . toMaybeInt) where+ toMaybeInt (AvailablePerLine cpl _) = Just cpl+ toMaybeInt Unbounded = Nothing
tests/QuickCheck.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main@@ -7,14 +6,8 @@ import Control.Applicative -#if MIN_VERSION_base(4,7,0) import Data.Either-#endif -#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif- import qualified Test.QuickCheck as Q import Text.Parser.Char@@ -81,11 +74,3 @@ parse p s = case parseString p mempty s of Failure e -> Left (show e) Success a -> Right a--#if !MIN_VERSION_base(4,7,0)-isLeft :: Either a b -> Bool-isLeft = either (const True) (const False)--isRight :: Either a b -> Bool-isRight = either (const False) (const True)-#endif
− tests/doctests.hs
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Main (doctests)--- Copyright : (C) 2012-14 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module provides doctests for a project based on the actual versions--- of the packages it was built with. It requires a corresponding Setup.lhs--- to be added to the project-------------------------------------------------------------------------------module Main where--import Build_doctests (flags, pkgs, module_sources)-import Data.Foldable (traverse_)-import Test.DocTest--main :: IO ()-main = do- traverse_ putStrLn args- doctest args- where- args = flags ++ pkgs ++ module_sources
trifecta.cabal view
@@ -1,39 +1,55 @@ name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging-version: 1.7.1.1+version: 2.1.4 license: BSD3-cabal-version: >= 1.10+cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> 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+ .+ For example:+ .+ <<https://i.imgur.com/ZyzUSSn.png>>+ .+ <images/example.png (Local Copy)> -build-type: Custom+build-type: Simple+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.4+ , GHC == 9.8.1 +extra-doc-files:+ images/*.png+ extra-source-files:- examples/RFC2616.hs+ examples/*.hs+ examples/LICENSE+ examples/rfc2616/*.hs examples/RFC2616.txt- .travis.yml+ examples/RFC2616-malformed.txt+ examples/trifecta-examples.cabal CHANGELOG.markdown README.markdown- Warning.hs source-repository head type: git location: https://github.com/ekmett/trifecta -custom-setup- setup-depends:- base >= 4 && < 5,- Cabal,- cabal-doctest >= 1 && < 1.1- library exposed-modules: Text.Trifecta@@ -44,60 +60,46 @@ Text.Trifecta.Rendering Text.Trifecta.Result Text.Trifecta.Rope- Text.Trifecta.Util.Array+ Text.Trifecta.Tutorial Text.Trifecta.Util.IntervalMap Text.Trifecta.Util.It other-modules:- Text.Trifecta.Instances Text.Trifecta.Util.Combinators+ Text.Trifecta.Util.Pretty build-depends:- ansi-wl-pprint >= 0.6.6 && < 0.7,- ansi-terminal >= 0.6 && < 0.7,- array >= 0.3.0.2 && < 0.6,- base >= 4.4 && < 5,- blaze-builder >= 0.3.0.1 && < 0.5,- blaze-html >= 0.5 && < 0.10,- blaze-markup >= 0.5 && < 0.9,- bytestring >= 0.9.1 && < 0.11,- charset >= 0.3.5.1 && < 1,- comonad >= 4 && < 6,- containers >= 0.3 && < 0.6,- deepseq >= 1.2.0.1 && < 1.5,- fingertree >= 0.1 && < 0.2,+ ansi-terminal >= 0.6 && < 1.2,+ array >= 0.5.1.1 && < 0.6,+ base >= 4.9 && < 5,+ blaze-builder >= 0.3.0.1 && < 0.5,+ blaze-html >= 0.9 && < 0.10,+ blaze-markup >= 0.8 && < 0.9,+ bytestring >= 0.9.1 && < 0.13,+ charset >= 0.3.5.1 && < 1,+ comonad >= 5 && < 6,+ containers >= 0.5.7.0 && < 0.8,+ deepseq >= 1.4.2.0 && < 1.6,+ fingertree >= 0.1 && < 0.2, ghc-prim,- hashable >= 1.2.1 && < 1.3,- lens >= 4.0 && < 5,- mtl >= 2.0.1 && < 2.3,- parsers >= 0.12.1 && < 1,- profunctors >= 4.0 && < 6,- reducers >= 3.10 && < 4,- semigroups >= 0.8.3.1 && < 1,- transformers >= 0.2 && < 0.6,- unordered-containers >= 0.2.1 && < 0.3,- utf8-string >= 0.3.6 && < 1.1+ hashable >= 1.2.4 && < 1.5,+ indexed-traversable >= 0.1.1 && < 0.2,+ lens >= 4.14 && < 6,+ mtl >= 2.2.1 && < 2.4,+ parsers >= 0.12.1 && < 1,+ prettyprinter >= 1.7 && < 2,+ prettyprinter-ansi-terminal >= 1.1.2 && < 2,+ profunctors >= 5.2 && < 6,+ reducers >= 3.12.1 && < 4,+ transformers >= 0.5 && < 0.7,+ unordered-containers >= 0.2.1 && < 0.3,+ utf8-string >= 0.3.6 && < 1.1 default-language: Haskell2010 hs-source-dirs: src- ghc-options: -O2 -Wall -fobject-code-- -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0- if impl(ghc >= 8.0)- ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances- else- build-depends: fail == 4.9.*--test-suite doctests- type: exitcode-stdio-1.0- main-is: doctests.hs- ghc-options: -Wall -threaded- hs-source-dirs: tests- default-language: Haskell2010- build-depends:- base,- doctest >= 0.11.1 && < 0.14,- trifecta+ ghc-options: -O2 -Wall -Wcompat -Wnoncanonical-monad-instances -fobject-code+ if !impl(ghc >= 8.8)+ ghc-options: -Wnoncanonical-monadfail-instances test-suite quickcheck type: exitcode-stdio-1.0@@ -110,4 +112,3 @@ trifecta ghc-options: -Wall -threaded hs-source-dirs: tests-