diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ trifecta ======== -[![Hackage](https://img.shields.io/hackage/v/trifecta.svg)](https://hackage.haskell.org/package/trifecta) [![Build Status](https://secure.travis-ci.org/ekmett/trifecta.png?branch=master)](http://travis-ci.org/ekmett/trifecta) +[![Hackage](https://img.shields.io/hackage/v/trifecta.svg)](https://hackage.haskell.org/package/trifecta) [![Build Status](https://github.com/ekmett/trifecta/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/trifecta/actions?query=workflow%3AHaskell-CI) This package provides a parser that focuses on nice diagnostics. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -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} diff --git a/Warning.hs b/Warning.hs deleted file mode 100644 --- a/Warning.hs +++ /dev/null @@ -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 diff --git a/examples/LICENSE b/examples/LICENSE new file mode 100644 --- /dev/null +++ b/examples/LICENSE @@ -0,0 +1,33 @@ +Copyright 2010-2017 Edward Kmett +Copyright 2008 Ross Patterson +Copyright 2007 Paolo Martini +Copyright 1999-2000 Daan Leijen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import RFC2616 (lumpy) +import System.Environment (getArgs) + +main :: IO () +main = mapM_ lumpy =<< getArgs diff --git a/examples/RFC2616-malformed.txt b/examples/RFC2616-malformed.txt new file mode 100644 --- /dev/null +++ b/examples/RFC2616-malformed.txt @@ -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 + diff --git a/examples/RFC2616.hs b/examples/RFC2616.hs deleted file mode 100644 --- a/examples/RFC2616.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main (main) where - -import Control.Applicative -import Control.Exception (bracket) -import System.Environment (getArgs) -import System.IO (hClose, openFile, IOMode(ReadMode)) -import Text.Trifecta hiding (token) -import Text.Parser.Token.Highlight -import Text.Parser.Token.Style -import Data.CharSet.ByteSet as S -import qualified Data.ByteString as B - -infixl 4 <$!> - -(<$!>) :: Monad m => (a -> b) -> m a -> m b -f <$!> ma = do - a <- ma - return $! f a - -token :: CharParsing m => m Char -token = noneOf $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255'] - -isHSpace :: Char -> Bool -isHSpace c = c == ' ' || c == '\t' - -skipHSpaces :: CharParsing m => m () -skipHSpaces = skipSome (satisfy isHSpace) - -data Request = Request { - requestMethod :: String - , requestUri :: String - , requestProtocol :: String - } deriving (Eq, Ord, Show) - -requestLine :: (Monad m, TokenParsing m) => m Request -requestLine = Request <$!> (highlight ReservedIdentifier (some token) "request method") - <* skipHSpaces - <*> (highlight Identifier (some (satisfy (not . isHSpace))) "url") - <* skipHSpaces - <*> (try (highlight ReservedIdentifier (string "HTTP/" *> many httpVersion <* endOfLine)) "protocol") - where - httpVersion :: (Monad m, CharParsing m) => m Char - httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.' || c == '9' - -endOfLine :: CharParsing m => m () -endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ()) - -data Header = Header { - headerName :: String - , headerValue :: [String] - } deriving (Eq, Ord, Show) - -messageHeader :: (Monad m, TokenParsing m) => m Header -messageHeader = (\h b c -> Header h (b : c)) - <$!> (highlight ReservedIdentifier (some token) "header name") - <* highlight Operator (char ':') <* skipHSpaces - <*> (highlight Identifier (manyTill anyChar endOfLine) "header value") - <*> (many (skipHSpaces *> manyTill anyChar endOfLine) "blank line") - -request :: (Monad m, TokenParsing m) => m (Request, [Header]) -request = (,) <$> requestLine <*> many messageHeader <* endOfLine - -lumpy arg = do - r <- parseFromFile (many request) arg - case r of - Nothing -> return () - Just rs -> print (length rs) - -main :: IO () -main = mapM_ lumpy =<< getArgs diff --git a/examples/Spec.hs b/examples/Spec.hs new file mode 100644 --- /dev/null +++ b/examples/Spec.hs @@ -0,0 +1,19 @@ +module Main where + +import qualified RFC2616 + +import Control.Monad.IO.Class (liftIO) +import Test.Hspec +import Text.Trifecta + +-- Just [(Request {requestMethod = "GET", requestUri = "http://slashdot.org/", requestProtocol = "1.1"},[Header {headerName = "foo", headerValue = ["this is a test"]}]),(Request {requestMethod = "GET", requestUri = "http://slashdot.org/", requestProtocol = "1.0"},[Header {headerName = "foo", headerValue = ["of the emergency broadcast system"]}])] + +main :: IO () +main = hspec $ do + describe "RFC2616.hs should be able to parse RFC2616" $ do + it "parses the RFC2616.txt file successfully" $ do + -- result :: Maybe [(RFC2616.Request, [RFC2616.Header])] + -- Tests are intended to be run from the top level. + result <- liftIO $ parseFromFile RFC2616.requests "RFC2616.txt" + print result + result `shouldNotBe` Nothing diff --git a/examples/rfc2616/RFC2616.hs b/examples/rfc2616/RFC2616.hs new file mode 100644 --- /dev/null +++ b/examples/rfc2616/RFC2616.hs @@ -0,0 +1,71 @@ +{-# language BangPatterns #-} + +module RFC2616 where + +import Control.Applicative +import System.Environment (getArgs) +import Text.Trifecta hiding (token) +import Text.Parser.Token.Highlight + +infixl 4 <$!> + +(<$!>) :: Monad m => (a -> b) -> m a -> m b +f <$!> ma = do + a <- ma + return $! f a + +token :: CharParsing m => m Char +token = noneOf $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255'] + +isHSpace :: Char -> Bool +isHSpace c = c == ' ' || c == '\t' + +skipHSpaces :: CharParsing m => m () +skipHSpaces = skipSome (satisfy isHSpace) + +data Request = Request { + requestMethod :: String + , requestUri :: String + , requestProtocol :: String + } deriving (Eq, Ord, Show) + +requestLine :: (Monad m, TokenParsing m) => m Request +requestLine = Request <$!> (highlight ReservedIdentifier (some token) "request method") + <* skipHSpaces + <*> (highlight Identifier (some (satisfy (not . isHSpace))) "url") + <* skipHSpaces + <*> (try (highlight ReservedIdentifier (string "HTTP/" *> many httpVersion <* endOfLine)) "protocol") + where + httpVersion :: (Monad m, CharParsing m) => m Char + httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.' || c == '9' + +endOfLine :: CharParsing m => m () +endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ()) + +data Header = Header { + headerName :: String + , headerValue :: [String] + } deriving (Eq, Ord, Show) + +messageHeader :: (Monad m, TokenParsing m) => m Header +messageHeader = (\h b c -> Header h (b : c)) + <$!> (highlight ReservedIdentifier (some token) "header name") + <* highlight Operator (char ':') <* skipHSpaces + <*> (highlight Identifier (manyTill anyChar endOfLine) "header value") + <*> (many (skipHSpaces *> manyTill anyChar endOfLine) "blank line") + +request :: (Monad m, TokenParsing m) => m (Request, [Header]) +request = (,) <$> requestLine <*> many messageHeader <* endOfLine + +requests :: (Monad m, TokenParsing m) => m [(Request, [Header])] +requests = many request + +lumpy :: String -> IO () +lumpy arg = do + r <- parseFromFile requests arg + case r of + Nothing -> return () + Just rs -> print (length rs) + +main :: IO () +main = mapM_ lumpy =<< getArgs diff --git a/examples/trifecta-examples.cabal b/examples/trifecta-examples.cabal new file mode 100644 --- /dev/null +++ b/examples/trifecta-examples.cabal @@ -0,0 +1,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 +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 diff --git a/images/example.png b/images/example.png new file mode 100644 Binary files /dev/null and b/images/example.png differ diff --git a/src/Text/Trifecta.hs b/src/Text/Trifecta.hs --- a/src/Text/Trifecta.hs +++ b/src/Text/Trifecta.hs @@ -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 -- Stability : experimental -- Portability : non-portable -- +-- For a short introduction, see the "Text.Trifecta.Tutorial" module. ---------------------------------------------------------------------------- module Text.Trifecta ( module Text.Trifecta.Rendering @@ -20,12 +21,12 @@ , module Text.Parser.Token ) where -import Text.Trifecta.Rendering +import Text.Parser.Char +import Text.Parser.Combinators +import Text.Parser.Token +import Text.Trifecta.Combinators import Text.Trifecta.Highlight import Text.Trifecta.Parser -import Text.Trifecta.Combinators +import Text.Trifecta.Rendering import Text.Trifecta.Result import Text.Trifecta.Rope -import Text.Parser.Combinators -import Text.Parser.Char -import Text.Parser.Token diff --git a/src/Text/Trifecta/Combinators.hs b/src/Text/Trifecta/Combinators.hs --- a/src/Text/Trifecta/Combinators.hs +++ b/src/Text/Trifecta/Combinators.hs @@ -1,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 #-} diff --git a/src/Text/Trifecta/Delta.hs b/src/Text/Trifecta/Delta.hs --- a/src/Text/Trifecta/Delta.hs +++ b/src/Text/Trifecta/Delta.hs @@ -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 -- 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 diff --git a/src/Text/Trifecta/Highlight.hs b/src/Text/Trifecta/Highlight.hs --- a/src/Text/Trifecta/Highlight.hs +++ b/src/Text/Trifecta/Highlight.hs @@ -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 @@ -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 diff --git a/src/Text/Trifecta/Instances.hs b/src/Text/Trifecta/Instances.hs deleted file mode 100644 --- a/src/Text/Trifecta/Instances.hs +++ /dev/null @@ -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 diff --git a/src/Text/Trifecta/Parser.hs b/src/Text/Trifecta/Parser.hs --- a/src/Text/Trifecta/Parser.hs +++ b/src/Text/Trifecta/Parser.hs @@ -1,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) diff --git a/src/Text/Trifecta/Rendering.hs b/src/Text/Trifecta/Rendering.hs --- a/src/Text/Trifecta/Rendering.hs +++ b/src/Text/Trifecta/Rendering.hs @@ -1,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 @@ -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 = "" @@ -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; } +-- | ^ +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; } +-- | ~~~ +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; } +-- | ~~~ +-- | 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 diff --git a/src/Text/Trifecta/Result.hs b/src/Text/Trifecta/Result.hs --- a/src/Text/Trifecta/Result.hs +++ b/src/Text/Trifecta/Result.hs @@ -1,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 diff --git a/src/Text/Trifecta/Rope.hs b/src/Text/Trifecta/Rope.hs --- a/src/Text/Trifecta/Rope.hs +++ b/src/Text/Trifecta/Rope.hs @@ -1,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 -- Stability : experimental -- Portability : non-portable -- +-- A rope is a data strucure to efficiently store and manipulate long strings. +-- Wikipedia provides a nice overview: +-- ---------------------------------------------------------------------------- module Text.Trifecta.Rope ( Rope(..) , rope + , ropeBS , Strand(..) , strand , strands @@ -19,25 +29,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 diff --git a/src/Text/Trifecta/Tutorial.hs b/src/Text/Trifecta/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Tutorial.hs @@ -0,0 +1,71 @@ +-- | This module provides a short introduction to get users started using +-- Trifecta. The key takeaway message is that it’s not harder, or even much +-- different, from using other parser libraries, so for users familiar with one +-- of the many Parsecs should feel right at home. +-- +-- __The source of this file is written in a literate style__, and can be read +-- top-to-bottom. +module Text.Trifecta.Tutorial where + +import Control.Applicative +import Text.Trifecta + +-- | First, we import Trifecta itself. It only the core parser definitions and +-- instances. Since Trifecta on its own is just the parser and a handful of +-- instances; the bulk of the utility functions is actually from a separate +-- package, /parsers/, that provides the usual parsing functions like +-- 'manyTill', 'between', and so on. The idea behind the /parsers/ package is +-- that most parser libraries define the same generic functions, so they were +-- put into their own package to be shared. Trifecta reexports these +-- definitions, but it’s useful to keep in mind that the documentation of +-- certain functions might not be directly in the /trifecta/ package. +importDocumentation :: docDummy +importDocumentation = error "Auxiliary definition to write Haddock 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)) +-- > | ^ +examples :: docDummy +examples = error "Haddock dummy for documentation" diff --git a/src/Text/Trifecta/Util/Array.hs b/src/Text/Trifecta/Util/Array.hs deleted file mode 100644 --- a/src/Text/Trifecta/Util/Array.hs +++ /dev/null @@ -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 #-} diff --git a/src/Text/Trifecta/Util/Combinators.hs b/src/Text/Trifecta/Util/Combinators.hs --- a/src/Text/Trifecta/Util/Combinators.hs +++ b/src/Text/Trifecta/Util/Combinators.hs @@ -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 @@ -18,8 +18,8 @@ , (<$!>) ) where +import Data.ByteString as Strict import Data.ByteString.Lazy as Lazy -import Data.ByteString as Strict argmin :: Ord b => (a -> b) -> a -> a -> a argmin f a b diff --git a/src/Text/Trifecta/Util/IntervalMap.hs b/src/Text/Trifecta/Util/IntervalMap.hs --- a/src/Text/Trifecta/Util/IntervalMap.hs +++ b/src/Text/Trifecta/Util/IntervalMap.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} #ifndef MIN_VERSION_lens #define MIN_VERSION_lens(x,y,z) 1 @@ -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 - diff --git a/src/Text/Trifecta/Util/It.hs b/src/Text/Trifecta/Util/It.hs --- a/src/Text/Trifecta/Util/It.hs +++ b/src/Text/Trifecta/Util/It.hs @@ -1,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 @@ -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 +-- 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)) diff --git a/src/Text/Trifecta/Util/Pretty.hs b/src/Text/Trifecta/Util/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Util/Pretty.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2011-2019 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- Utility functions to augment the prettyprinter library's interface. +---------------------------------------------------------------------------- + +module Text.Trifecta.Util.Pretty + ( AnsiStyle + , renderIO + -- * Rendering + , char + -- * Styles + , bold + , debold + , underlined + , deunderline + -- * Compatibility shims + , renderPretty + , columns + ) where + + +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 diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs --- a/tests/QuickCheck.hs +++ b/tests/QuickCheck.hs @@ -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 diff --git a/tests/doctests.hs b/tests/doctests.hs deleted file mode 100644 --- a/tests/doctests.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources diff --git a/trifecta.cabal b/trifecta.cabal --- a/trifecta.cabal +++ b/trifecta.cabal @@ -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 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: + . + <> + . + -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 -