trifecta-1.6/0000755000000000000000000000000012736107753011362 5ustar0000000000000000trifecta-1.6/.travis.yml0000644000000000000000000000753212736107753013502 0ustar0000000000000000language: 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.16 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.16 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.1 compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.2 compiler: ": #GHC 7.10.2" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,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; if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi; 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 trifecta-1.6/LICENSE0000644000000000000000000000301312736107753012364 0ustar0000000000000000Copyright 2010-2015 Edward Kmett Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. trifecta-1.6/README.markdown0000644000000000000000000000077612736107753014075 0ustar0000000000000000trifecta ======== [![Hackage](https://img.shields.io/hackage/v/trifecta.svg)](https://hackage.haskell.org/package/trifecta) [![Build Status](https://secure.travis-ci.org/ekmett/trifecta.png?branch=master)](http://travis-ci.org/ekmett/trifecta) This package provides a parser that focuses on nice diagnostics. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett trifecta-1.6/Setup.lhs0000644000000000000000000000364712736107753013204 0ustar0000000000000000#!/usr/bin/runhaskell \begin{code} {-# OPTIONS_GHC -Wall #-} module Main (main) where import Data.List ( nub ) import Data.Version ( showVersion ) import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Verbosity ( Verbosity ) import System.FilePath ( () ) main :: IO () main = defaultMainWithHooks simpleUserHooks { buildHook = \pkg lbi hooks flags -> do generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi buildHook simpleUserHooks pkg lbi hooks flags } generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do let dir = autogenModulesDir lbi createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines [ "module Build_" ++ testName suite ++ " where" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p) testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys \end{code} trifecta-1.6/trifecta.cabal0000644000000000000000000000553712736107753014161 0ustar0000000000000000name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging version: 1.6 license: BSD3 cabal-version: >= 1.10 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 synopsis: A modern parser combinator library with convenient diagnostics description: A modern parser combinator library with slicing and Clang-style colored diagnostics build-type: Custom extra-source-files: examples/RFC2616.hs examples/RFC2616.txt .travis.yml README.markdown source-repository head type: git location: git://github.com/ekmett/trifecta.git library exposed-modules: Text.Trifecta Text.Trifecta.Combinators Text.Trifecta.Delta Text.Trifecta.Highlight Text.Trifecta.Parser Text.Trifecta.Rendering Text.Trifecta.Result Text.Trifecta.Rope Text.Trifecta.Util.Array Text.Trifecta.Util.IntervalMap Text.Trifecta.Util.It other-modules: Text.Trifecta.Instances Text.Trifecta.Util.Combinators 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.9, blaze-markup >= 0.5 && < 0.8, 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, 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 default-language: Haskell2010 hs-source-dirs: src ghc-options: -O2 -Wall -fobject-code 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, directory >= 1.0, doctest >= 0.9.1, filepath test-suite quickcheck type: exitcode-stdio-1.0 main-is: QuickCheck.hs default-language: Haskell2010 build-depends: base == 4.*, parsers, QuickCheck, trifecta ghc-options: -Wall -threaded hs-source-dirs: tests trifecta-1.6/examples/0000755000000000000000000000000012736107753013200 5ustar0000000000000000trifecta-1.6/examples/RFC2616.hs0000644000000000000000000000455212736107753014473 0ustar0000000000000000{-# 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 trifecta-1.6/examples/RFC2616.txt0000644000000000000000000000020112736107753014663 0ustar0000000000000000GET http://slashdot.org/ HTTP/1.1 foo: this is a test GET http://slashdot.org/ HTTP/1.0 foo: of the emergency broadcast system trifecta-1.6/src/0000755000000000000000000000000012736107753012151 5ustar0000000000000000trifecta-1.6/src/Text/0000755000000000000000000000000012736107753013075 5ustar0000000000000000trifecta-1.6/src/Text/Trifecta.hs0000644000000000000000000000167412736107753015202 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Text.Trifecta ( module Text.Trifecta.Rendering , module Text.Trifecta.Highlight , module Text.Trifecta.Parser , module Text.Trifecta.Combinators , module Text.Trifecta.Result , module Text.Trifecta.Rope , module Text.Parser.Combinators , module Text.Parser.Char , module Text.Parser.Token ) where import Text.Trifecta.Rendering import Text.Trifecta.Highlight import Text.Trifecta.Parser import Text.Trifecta.Combinators import Text.Trifecta.Result import Text.Trifecta.Rope import Text.Parser.Combinators import Text.Parser.Char import Text.Parser.Token trifecta-1.6/src/Text/Trifecta/0000755000000000000000000000000012736107753014636 5ustar0000000000000000trifecta-1.6/src/Text/Trifecta/Combinators.hs0000644000000000000000000002056512736107753017462 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Combinators -- Copyright : (c) Edward Kmett 2011-2015 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Text.Trifecta.Combinators ( DeltaParsing(..) , sliced , careting, careted , spanning, spanned , fixiting , MarkParsing(..) ) where import Control.Applicative import Control.Monad (MonadPlus) import Control.Monad.Trans.Class import Control.Monad.Trans.Identity import Control.Monad.Trans.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.Writer.Strict as Strict import Data.ByteString as Strict hiding (span) import Data.Semigroup import Text.Parser.Token import Text.Trifecta.Delta import Text.Trifecta.Rendering import Prelude hiding (span) -- | This class provides parsers with easy access to: -- -- 1) the current line contents. -- 2) the current position as a 'Delta'. -- 3) the ability to use 'sliced' on any parser. class (MonadPlus m, TokenParsing m) => DeltaParsing m where -- | Retrieve the contents of the current line (from the beginning of the line) line :: m ByteString -- | Retrieve the current position as a 'Delta'. position :: m Delta -- | Run a parser, grabbing all of the text between its start and end points slicedWith :: (a -> Strict.ByteString -> r) -> m a -> m r -- | Retrieve a 'Rendering' of the current linem noting this position, but not -- placing a 'Caret' there. rend :: DeltaParsing m => m Rendering rend = rendered <$> position <*> line {-# INLINE rend #-} -- | Grab the remainder of the current line restOfLine :: DeltaParsing m => m ByteString restOfLine = Strict.drop . fromIntegral . columnByte <$> position <*> line {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Lazy.StateT s m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE position #-} slicedWith f (Lazy.StateT m) = Lazy.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s {-# INLINE slicedWith #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (Strict.StateT s m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE position #-} slicedWith f (Strict.StateT m) = Strict.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s {-# INLINE slicedWith #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (ReaderT e m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE position #-} slicedWith f (ReaderT m) = ReaderT $ slicedWith f . m {-# INLINE slicedWith #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.WriterT w m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE position #-} slicedWith f (Strict.WriterT m) = Strict.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m {-# INLINE slicedWith #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.WriterT w m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE position #-} slicedWith f (Lazy.WriterT m) = Lazy.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m {-# INLINE slicedWith #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Lazy.RWST r w s m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE 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 #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m, Monoid w) => DeltaParsing (Strict.RWST r w s m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE 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 #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} instance (MonadPlus m, DeltaParsing m) => DeltaParsing (IdentityT m) where line = lift line {-# INLINE line #-} position = lift position {-# INLINE position #-} slicedWith f (IdentityT m) = IdentityT $ slicedWith f m {-# INLINE slicedWith #-} rend = lift rend {-# INLINE rend #-} restOfLine = lift restOfLine {-# INLINE restOfLine #-} -- | Run a parser, grabbing all of the text between its start and end points and discarding the original result sliced :: DeltaParsing m => m a -> m ByteString sliced = slicedWith (\_ bs -> bs) {-# INLINE sliced #-} -- | Grab a 'Caret' pointing to the current location. careting :: DeltaParsing m => m Caret careting = Caret <$> position <*> line {-# INLINE 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 #-} -- | Discard the result of a parse, returning a 'Span' from where we start to where it ended parsing. spanning :: DeltaParsing m => m a -> m Span spanning p = (\s l e -> Span s e l) <$> position <*> line <*> (p *> position) {-# INLINE spanning #-} -- | Parse a 'Spanned' result. The 'Span' starts here and runs to the last position parsed. 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 #-} -- | Grab a fixit. fixiting :: DeltaParsing m => m Strict.ByteString -> m Fixit fixiting p = (\(r :~ s) -> Fixit s r) <$> spanned p {-# INLINE fixiting #-} -- | This class is a refinement of 'DeltaParsing' that adds the ability to mark your position in the input -- and return there for further parsing later. class (DeltaParsing m, HasDelta d) => MarkParsing d m | m -> d where -- | mark the current location so it can be used in constructing a span, or for later seeking mark :: m d -- | Seek a previously marked location release :: d -> m () instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Lazy.StateT s m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (Strict.StateT s m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (ReaderT e m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.WriterT w m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.WriterT w m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Lazy.RWST r w s m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} instance (MonadPlus m, MarkParsing d m, Monoid w) => MarkParsing d (Strict.RWST r w s m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} instance (MonadPlus m, MarkParsing d m) => MarkParsing d (IdentityT m) where mark = lift mark {-# INLINE mark #-} release = lift . release {-# INLINE release #-} trifecta-1.6/src/Text/Trifecta/Delta.hs0000644000000000000000000001476312736107753016236 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Text.Trifecta.Delta ( Delta(..) , HasDelta(..) , HasBytes(..) , nextTab , rewind , near , column , columnByte ) where import Data.Semigroup 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, (<>)) class HasBytes t where bytes :: t -> Int64 instance HasBytes ByteString where bytes = fromIntegral . Strict.length instance (Measured v a, HasBytes v) => HasBytes (FingerTree v a) where bytes = bytes . measure 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) instance Eq Delta where (==) = (==) `on` bytes instance Ord Delta where compare = compare `on` bytes instance (HasDelta l, HasDelta r) => HasDelta (Either l r) where delta = either delta delta 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 -- | Retrieve the character offset within the current line from this 'Delta'. column :: HasDelta t => t -> Int64 column t = case delta t of Columns c _ -> c Tab b a _ -> nextTab b + a Lines _ c _ _ -> c Directed _ _ c _ _ -> c {-# INLINE column #-} -- | Retrieve the byte offset within the current line from this 'Delta'. columnByte :: Delta -> Int64 columnByte (Columns _ b) = b columnByte (Tab _ _ b) = b columnByte (Lines _ _ _ b) = b columnByte (Directed _ _ _ _ b) = b {-# INLINE columnByte #-} instance HasBytes Delta where bytes (Columns _ b) = b bytes (Tab _ _ b) = b bytes (Lines _ _ b _) = b bytes (Directed _ _ _ b _) = b instance Hashable Delta instance Monoid Delta where mempty = Columns 0 0 mappend = (<>) instance Semigroup Delta where Columns c a <> Columns d b = Columns (c + d) (a + b) Columns c a <> Tab x y b = Tab (c + x) y (a + b) Columns _ a <> Lines l c t a' = Lines l c (t + a) a' Columns _ a <> Directed p l c t a' = Directed p l c (t + a) a' Lines l c t a <> Columns d b = Lines l (c + d) (t + b) (a + b) Lines l c t a <> Tab x y b = Lines l (nextTab (c + x) + y) (t + b) (a + b) Lines l _ t _ <> Lines m d t' b = Lines (l + m) d (t + t') b Lines _ _ t _ <> Directed p l c t' a = Directed p l c (t + t') a Tab x y a <> Columns d b = Tab x (y + d) (a + b) Tab x y a <> Tab x' y' b = Tab x (nextTab (y + x') + y') (a + b) Tab _ _ a <> Lines l c t a' = Lines l c (t + a ) a' Tab _ _ a <> Directed p l c t a' = Directed p l c (t + a ) a' Directed p l c t a <> Columns d b = Directed p l (c + d) (t + b ) (a + b) Directed p l c t a <> Tab x y b = Directed p l (nextTab (c + x) + y) (t + b ) (a + b) Directed p l _ t _ <> Lines m d t' b = Directed p (l + m) d (t + t') b Directed _ _ _ t _ <> Directed p l c t' b = Directed p l c (t + t') b -- | Increment a column number to the next tabstop. nextTab :: Int64 -> Int64 nextTab x = x + (8 - mod x 8) {-# INLINE 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 #-} -- | Should we show two things with a 'Delta' on the same line? near :: (HasDelta s, HasDelta t) => s -> t -> Bool near s t = rewind (delta s) == rewind (delta t) {-# INLINE near #-} class HasDelta t where delta :: t -> Delta instance HasDelta Delta where delta = id instance HasDelta Char where delta '\t' = Tab 0 0 1 delta '\n' = Lines 1 0 1 0 delta c | o <= 0x7f = Columns 1 1 | o <= 0x7ff = Columns 1 2 | o <= 0xffff = Columns 1 3 | otherwise = Columns 1 4 where o = fromEnum c instance HasDelta Word8 where delta 9 = Tab 0 0 1 delta 10 = Lines 1 0 1 0 delta n | n <= 0x7f = Columns 1 1 | n >= 0xc0 && n <= 0xf4 = Columns 1 1 | otherwise = Columns 0 1 instance HasDelta ByteString where delta = foldMap delta . unpack instance (Measured v a, HasDelta v) => HasDelta (FingerTree v a) where delta = delta . measure trifecta-1.6/src/Text/Trifecta/Highlight.hs0000644000000000000000000001217712736107753017111 0ustar0000000000000000{-# 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 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Text.Trifecta.Highlight ( Highlight , HighlightedRope(HighlightedRope) , HasHighlightedRope(..) , withHighlight , HighlightDoc(HighlightDoc) , HasHighlightDoc(..) , doc ) where import Control.Lens #if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710 hiding (Empty) #endif import Data.Foldable as F import Data.Int (Int64) import Data.List (sort) import Data.Semigroup import Data.Semigroup.Union import Prelude hiding (head) import Text.Blaze import Text.Blaze.Html5 hiding (a,b,i) import qualified Text.Blaze.Html5 as Html5 import Text.Blaze.Html5.Attributes hiding (title,id) import Text.Blaze.Internal (MarkupM(Empty, Leaf)) import Text.Parser.Token.Highlight import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) import Text.Trifecta.Util.IntervalMap as IM import Text.Trifecta.Delta import Text.Trifecta.Rope import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 -- | Convert a 'Highlight' into a coloration on a 'Doc'. withHighlight :: Highlight -> Doc -> Doc 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 _ = id -- | A 'HighlightedRope' is a 'Rope' with an associated 'IntervalMap' full of highlighted regions. data HighlightedRope = HighlightedRope { _ropeHighlights :: !(IM.IntervalMap Delta Highlight) , _ropeContent :: {-# UNPACK #-} !Rope } makeClassy ''HighlightedRope instance HasDelta HighlightedRope where delta = delta . _ropeContent instance HasBytes HighlightedRope where bytes = bytes . _ropeContent instance Semigroup HighlightedRope where HighlightedRope h bs <> HighlightedRope h' bs' = HighlightedRope (h `union` IM.offset (delta bs) h') (bs <> bs') instance Monoid HighlightedRope where mappend = (<>) mempty = HighlightedRope mempty mempty data Located a = a :@ {-# UNPACK #-} !Int64 infix 5 :@ instance Eq (Located a) where _ :@ m == _ :@ n = m == n instance Ord (Located a) where compare (_ :@ m) (_ :@ n) = compare m n instance ToMarkup HighlightedRope where toMarkup (HighlightedRope intervals r) = Html5.pre $ go 0 lbs effects where lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)] ln no = Html5.a ! name (toValue $ "line-" ++ show no) $ Empty effects = sort $ [ i | (Interval lo hi, tok) <- intersections mempty (delta r) intervals , i <- [ (Leaf "span" "" ! class_ (toValue $ show tok)) :@ bytes lo , preEscapedToHtml ("" :: String) :@ bytes hi ] ] ++ imap (\k i -> ln k :@ i) (L.elemIndices '\n' lbs) go _ cs [] = unsafeLazyByteString cs go b cs ((eff :@ eb) : es) | eb <= b = eff >> go b cs es | otherwise = unsafeLazyByteString om >> go eb nom es where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs 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 { _docTitle :: String , _docCss :: String -- href for the css file , _docContent :: HighlightedRope } makeClassy ''HighlightDoc -- | Generate an HTML document from a title and a 'HighlightedRope'. doc :: String -> HighlightedRope -> HighlightDoc doc t r = HighlightDoc t "trifecta.css" r instance ToMarkup HighlightDoc where toMarkup (HighlightDoc t css cs) = docTypeHtml $ do head $ do preEscapedToHtml ("\n" :: String) title $ toHtml t link ! rel "stylesheet" ! type_ "text/css" ! href (toValue css) body $ toHtml cs trifecta-1.6/src/Text/Trifecta/Instances.hs0000644000000000000000000000110412736107753017115 0ustar0000000000000000{-# 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 import Text.PrettyPrint.ANSI.Leijen import qualified Data.Semigroup as Data instance Data.Semigroup Doc where (<>) = (<>) trifecta-1.6/src/Text/Trifecta/Parser.hs0000644000000000000000000002605212736107753016433 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2015 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- module Text.Trifecta.Parser ( Parser(..) , manyAccum -- * Feeding a parser more more input , Step(..) , feed , starve , stepParser , stepResult , stepIt -- * Parsing , parseFromFile , parseFromFileEx , parseString , parseByteString , parseTest ) where import Control.Applicative as Alternative import Control.Monad (MonadPlus(..), ap, join) import Control.Monad.IO.Class import Data.ByteString as Strict hiding (empty, snoc) import Data.ByteString.UTF8 as UTF8 import Data.Maybe (isJust) import Data.Semigroup import Data.Semigroup.Reducer -- import Data.Sequence as Seq hiding (empty) import Data.Set as Set hiding (empty, toList) 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.Rendering import Text.Trifecta.Result import Text.Trifecta.Rope import Text.Trifecta.Delta as Delta import Text.Trifecta.Util.It newtype Parser a = Parser { unparser :: forall r. (a -> Err -> It Rope r) -> (Err -> It Rope r) -> (a -> Set String -> Delta -> ByteString -> It Rope r) -> -- committed success (ErrInfo -> It Rope r) -> -- committed err Delta -> ByteString -> It Rope r } instance Functor Parser where fmap f (Parser m) = Parser $ \ eo ee co -> m (eo . f) ee (co . f) {-# INLINE fmap #-} a <$ Parser m = Parser $ \ eo ee co -> m (\_ -> eo a) ee (\_ -> co a) {-# INLINE (<$) #-} instance Applicative Parser where pure a = Parser $ \ eo _ _ _ _ _ -> eo a mempty {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} instance Alternative Parser where empty = Parser $ \_ ee _ _ _ _ -> ee mempty {-# INLINE 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 (<|>) #-} many p = Prelude.reverse <$> manyAccum (:) p {-# INLINE many #-} some p = (:) <$> p <*> Alternative.many p instance Semigroup a => Semigroup (Parser a) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} instance Monoid a => Monoid (Parser a) where mappend = liftA2 mappend {-# INLINE mappend #-} mempty = pure mempty {-# INLINE mempty #-} instance Monad Parser where return a = Parser $ \ eo _ _ _ _ _ -> eo a mempty {-# INLINE return #-} Parser m >>= k = Parser $ \ eo ee co ce d bs -> m (\a e -> unparser (k a) (\b e' -> eo b (e <> e')) (\e' -> ee (e <> e')) co ce d bs) ee (\a es d' bs' -> unparser (k a) (\b e' -> co b (es <> _expected e') d' bs') (\e -> let errDoc = explain (renderingCaret d' bs') e { _expected = _expected e <> es } errDelta = _finalDeltas e in ce $ ErrInfo errDoc (d' : errDelta) ) co ce d' bs') ce d bs {-# INLINE (>>=) #-} (>>) = (*>) {-# INLINE (>>) #-} fail s = Parser $ \ _ ee _ _ _ _ -> ee (failed s) {-# INLINE fail #-} instance MonadPlus Parser where mzero = empty {-# INLINE mzero #-} mplus = (<|>) {-# INLINE mplus #-} manyAccum :: (a -> [a] -> [a]) -> Parser a -> Parser [a] manyAccum f (Parser p) = Parser $ \eo _ co ce d bs -> let walk xs x es d' bs' = p (manyErr d' bs') (\e -> co (f x xs) (_expected e <> es) d' bs') (walk (f x xs)) ce d' bs' manyErr d' bs' _ e = ce (ErrInfo errDoc [d']) where errDoc = explain (renderingCaret d' bs') (e <> failed "'many' applied to a parser that accepted an empty string") in p (manyErr d bs) (eo []) (walk []) ce d bs liftIt :: It Rope a -> Parser a liftIt m = Parser $ \ eo _ _ _ _ _ -> do a <- m eo a mempty {-# INLINE liftIt #-} instance Parsing Parser where try (Parser m) = Parser $ \ eo ee co _ -> m eo ee co (\_ -> ee mempty) {-# INLINE 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 () #-} skipMany p = () <$ manyAccum (\_ _ -> []) p {-# INLINE skipMany #-} unexpected s = Parser $ \ _ ee _ _ _ _ -> ee $ failed $ "unexpected " ++ s {-# INLINE unexpected #-} eof = notFollowedBy anyChar "end of input" {-# INLINE eof #-} notFollowedBy p = try (optional p >>= maybe (pure ()) (unexpected . show)) {-# INLINE notFollowedBy #-} instance Errable Parser where raiseErr e = Parser $ \ _ ee _ _ _ _ -> ee e {-# INLINE raiseErr #-} instance LookAheadParsing Parser where lookAhead (Parser m) = Parser $ \eo ee _ -> m eo ee (\a _ _ _ -> eo a mempty) {-# INLINE lookAhead #-} instance CharParsing Parser where satisfy f = Parser $ \ _ ee co _ d bs -> case UTF8.uncons $ Strict.drop (fromIntegral (columnByte d)) bs of Nothing -> ee (failed "unexpected EOF") Just (c, xs) | not (f c) -> ee mempty | Strict.null xs -> let !ddc = d <> delta c in join $ fillIt (co c mempty ddc (if c == '\n' then mempty else bs)) (co c mempty) ddc | otherwise -> co c mempty (d <> delta c) bs {-# INLINE satisfy #-} instance TokenParsing Parser instance DeltaParsing Parser where line = Parser $ \eo _ _ _ _ bs -> eo bs mempty {-# INLINE line #-} position = Parser $ \eo _ _ _ d _ -> eo d mempty {-# INLINE position #-} rend = Parser $ \eo _ _ _ d bs -> eo (rendered d bs) mempty {-# INLINE rend #-} slicedWith f p = do m <- position a <- p r <- position f a <$> liftIt (sliceIt m r) {-# INLINE slicedWith #-} instance MarkParsing Delta Parser where mark = position {-# INLINE mark #-} release d' = Parser $ \_ ee co _ d bs -> do mbs <- rewindIt d' case mbs of Just bs' -> co () mempty d' bs' Nothing | bytes d' == bytes (rewind d) + fromIntegral (Strict.length bs) -> if near d d' then co () mempty d' bs else co () mempty d' mempty | otherwise -> ee mempty data Step a = StepDone !Rope a | StepFail !Rope ErrInfo | StepCont !Rope (Result a) (Rope -> Step a) instance Show a => Show (Step a) where showsPrec d (StepDone r a) = showParen (d > 10) $ showString "StepDone " . showsPrec 11 r . showChar ' ' . showsPrec 11 a showsPrec d (StepFail r xs) = showParen (d > 10) $ showString "StepFail " . showsPrec 11 r . showChar ' ' . showsPrec 11 xs showsPrec d (StepCont r fin _) = showParen (d > 10) $ showString "StepCont " . showsPrec 11 r . showChar ' ' . showsPrec 11 fin . showString " ..." instance Functor Step where fmap f (StepDone r a) = StepDone r (f a) fmap _ (StepFail r xs) = StepFail r xs fmap f (StepCont r z k) = StepCont r (fmap f z) (fmap f . k) feed :: 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 #-} starve :: Step a -> Result a starve (StepDone _ a) = Success a starve (StepFail _ xs) = Failure xs starve (StepCont _ z _) = z {-# INLINE starve #-} stepResult :: Rope -> Result a -> Step a stepResult r (Success a) = StepDone r a stepResult r (Failure xs) = StepFail r xs {-# INLINE 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 #-} data Stepping a = EO a Err | EE Err | 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 #-} -- | @parseFromFile p filePath@ runs a parser @p@ on the -- input read from @filePath@ using 'ByteString.readFile'. All diagnostic messages -- emitted over the course of the parse attempt are shown to the user on the console. -- -- > main = do -- > result <- parseFromFile numbers "digits.txt" -- > case result of -- > Nothing -> return () -- > Just a -> print $ sum a parseFromFile :: MonadIO m => Parser a -> String -> m (Maybe a) parseFromFile p fn = do result <- parseFromFileEx p fn case result of Success a -> return (Just a) Failure xs -> do liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc xs) <> linebreak return Nothing -- | @parseFromFileEx p filePath@ runs a parser @p@ on the -- input read from @filePath@ using 'ByteString.readFile'. Returns all diagnostic messages -- emitted over the course of the parse and the answer if the parse was successful. -- -- > 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 parseString :: Parser a -> Delta -> String -> Result a parseString p d inp = starve $ feed inp $ stepParser (release d *> p) mempty mempty 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 Success a -> liftIO (print a) trifecta-1.6/src/Text/Trifecta/Rendering.hs0000644000000000000000000003171512736107753017116 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- The type for Lines will very likely change over time, to enable drawing -- lit up multi-character versions of control characters for @^Z@, @^[@, -- @<0xff>@, etc. This will make for much nicer diagnostics when -- working with protocols. -- ---------------------------------------------------------------------------- module Text.Trifecta.Rendering ( Rendering(Rendering) , HasRendering(..) , nullRendering , emptyRendering , Source(..) , rendered , Renderable(..) , Rendered(..) -- * Carets , Caret(..) , HasCaret(..) , Careted(..) , drawCaret , addCaret , caretEffects , renderingCaret -- * Spans , Span(..) , HasSpan(..) , Spanned(..) , spanEffects , drawSpan , addSpan -- * Fixits , Fixit(..) , HasFixit(..) , drawFixit , addFixit -- * Drawing primitives , Lines , draw , ifNear , (.#) ) where import Control.Applicative import Control.Comonad import Control.Lens import Data.Array import Data.ByteString as B hiding (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 Text.Trifecta.Delta import Text.Trifecta.Instances () import Text.Trifecta.Util.Combinators outOfRangeEffects :: [SGR] -> [SGR] outOfRangeEffects xs = SetConsoleIntensity BoldIntensity : xs sgr :: [SGR] -> Doc -> Doc 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 (SetColor f i c : xs) = case f of 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 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 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 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 go (_ : xs) = go xs type Lines = Array (Int,Int64) ([SGR], Char) (///) :: Ix i => Array i e -> [(i, e)] -> Array i e a /// xs = a // P.filter (inRange (bounds a) . fst) xs grow :: Int -> Lines -> Lines grow y a | inRange (t,b) y = a | otherwise = array new [ (i, if inRange old i then a ! i else ([],' ')) | i <- range new ] where old@((t,lo),(b,hi)) = bounds a new = ((min t y,lo),(max b y,hi)) draw :: [SGR] -> Int -> Int64 -> String -> Lines -> Lines draw e y n xs a0 | P.null xs = a0 | otherwise = gt $ lt (a /// out) where a = grow y a0 ((_,lo),(_,hi)) = bounds a out = P.zipWith (\i c -> ((y,i),(e,c))) [n..] xs lt | P.any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))]) | otherwise = id gt | P.any (\el -> snd (fst el) > hi) out = (// [((y,hi),(outOfRangeEffects e,'>'))]) | otherwise = id data Rendering = Rendering { _renderingDelta :: !Delta -- focus, the render will keep this visible , _renderingLineLen :: {-# UNPACK #-} !Int64 -- actual line length , _renderingLineBytes :: {-# UNPACK #-} !Int64 -- line length in bytes , _renderingLine :: Lines -> Lines , _renderingOverlays :: Delta -> Lines -> Lines } makeClassy ''Rendering instance Show Rendering where showsPrec d (Rendering p ll lb _ _) = showParen (d > 10) $ showString "Rendering " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showChar ' ' . showsPrec 11 lb . showString " ... ..." nullRendering :: Rendering -> Bool nullRendering (Rendering (Columns 0 0) 0 0 _ _) = True nullRendering _ = False emptyRendering :: Rendering emptyRendering = Rendering (Columns 0 0) 0 0 id (const id) instance Semigroup Rendering where -- an unprincipled hack Rendering (Columns 0 0) 0 0 _ f <> Rendering del len lb dc g = Rendering del len lb dc $ \d l -> f d (g d l) Rendering del len lb dc f <> Rendering _ _ _ _ g = Rendering del len lb dc $ \d l -> f d (g d l) instance Monoid Rendering where mappend = (<>) mempty = emptyRendering ifNear :: Delta -> (Lines -> Lines) -> Delta -> Lines -> Lines ifNear d f d' l | near d d' = f l | otherwise = l instance HasDelta Rendering where delta = _renderingDelta class Renderable t where render :: t -> Rendering instance Renderable Rendering where render = id class Source t where source :: t -> (Int64, Int64, Lines -> Lines) {- the number of (padded) columns, number of bytes, and the the line -} instance Source String where source s | P.elem '\n' s = ( ls, bs, draw [] 0 0 s') | otherwise = ( ls + fromIntegral (P.length end), bs, draw [SetColor Foreground Vivid Blue, SetConsoleIntensity BoldIntensity] 0 ls end . draw [] 0 0 s') where end = "" s' = go 0 s bs = fromIntegral $ B.length $ UTF8.fromString $ P.takeWhile (/='\n') s ls = fromIntegral $ P.length s' go n ('\t':xs) = let t = 8 - mod n 8 in P.replicate t ' ' ++ go (n + t) xs go _ ('\n':_) = [] go n (x:xs) = x : go (n + 1) xs go _ [] = [] instance Source ByteString where source = source . UTF8.toString -- | create a drawing surface rendered :: Source s => Delta -> s -> Rendering rendered del s = case source s of (len, lb, dc) -> Rendering del len lb dc (\_ l -> l) (.#) :: (Delta -> Lines -> Lines) -> Rendering -> Rendering f .# Rendering d ll lb s g = Rendering d ll lb s $ \e l -> f e $ g e l 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] ] window :: Int64 -> Int64 -> Int64 -> (Int64, Int64) window c l w | c <= w2 = (0, min w l) | c + w2 >= l = if l > w then (l-w, l) else (0, w) | otherwise = (c-w2,c + w2) where w2 = div w 2 data Rendered a = a :@ Rendering deriving Show instance Functor Rendered where fmap f (a :@ s) = f a :@ s instance HasDelta (Rendered a) where delta = delta . render instance HasBytes (Rendered a) where bytes = bytes . delta instance Comonad Rendered where extend f as@(_ :@ s) = f as :@ s extract (a :@ _) = a instance ComonadApply Rendered where (f :@ s) <@> (a :@ t) = f a :@ (s <> t) instance Foldable Rendered where foldMap f (a :@ _) = f a instance Traversable Rendered where traverse f (a :@ s) = (:@ s) <$> f a instance Renderable (Rendered a) where render (_ :@ s) = s -- | -- > 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) class HasCaret t where caret :: Lens' t Caret instance HasCaret Caret where caret = id instance Hashable Caret caretEffects :: [SGR] caretEffects = [SetColor Foreground Vivid Green] drawCaret :: Delta -> Delta -> Lines -> Lines drawCaret p = ifNear p $ draw caretEffects 1 (fromIntegral (column p)) "^" addCaret :: Delta -> Rendering -> Rendering addCaret p r = drawCaret p .# r instance HasBytes Caret where bytes = bytes . delta instance HasDelta Caret where delta (Caret d _) = d instance Renderable Caret where render (Caret d bs) = addCaret d $ rendered d bs instance Reducer Caret Rendering where unit = render instance Semigroup Caret where a <> _ = a renderingCaret :: Delta -> ByteString -> Rendering renderingCaret d bs = addCaret d $ rendered d bs data Careted a = a :^ Caret deriving (Eq,Ord,Show,Data,Typeable,Generic) instance HasCaret (Careted a) where caret f (a :^ c) = (a :^) <$> f c instance Functor Careted where fmap f (a :^ s) = f a :^ s instance HasDelta (Careted a) where delta (_ :^ c) = delta c instance HasBytes (Careted a) where bytes (_ :^ c) = bytes c instance Comonad Careted where extend f as@(_ :^ s) = f as :^ s extract (a :^ _) = a instance ComonadApply Careted where (a :^ c) <@> (b :^ d) = a b :^ (c <> d) instance Foldable Careted where foldMap f (a :^ _) = f a instance Traversable Careted where traverse f (a :^ s) = (:^ s) <$> f a instance Renderable (Careted a) where render (_ :^ a) = render a instance Reducer (Careted a) Rendering where unit = render instance Hashable a => Hashable (Careted a) 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 where go = draw spanEffects 1 . fromIntegral l = argmin bytes s e h = argmax bytes s e nl = near l d nh = near h 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) class HasSpan t where span :: Lens' t Span instance HasSpan Span where span = id instance Renderable Span where render (Span s e bs) = addSpan s e $ rendered s bs instance Semigroup Span where Span s _ b <> Span _ e _ = Span s e b instance Reducer Span Rendering where unit = render instance Hashable Span data Spanned a = a :~ Span deriving (Eq,Ord,Show,Data,Typeable,Generic) instance HasSpan (Spanned a) where span f (a :~ c) = (a :~) <$> f c instance Functor Spanned where fmap f (a :~ s) = f a :~ s instance Comonad Spanned where extend f as@(_ :~ s) = f as :~ s extract (a :~ _) = a instance ComonadApply Spanned where (a :~ c) <@> (b :~ d) = a b :~ (c <> d) instance Foldable Spanned where foldMap f (a :~ _) = f a instance Traversable Spanned where traverse f (a :~ s) = (:~ s) <$> f a instance Reducer (Spanned a) Rendering where unit = render instance Renderable (Spanned a) where render (_ :~ s) = render s instance Hashable a => Hashable (Spanned a) -- > 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 where l = argmin bytes s e addFixit :: Delta -> Delta -> String -> Rendering -> Rendering addFixit s e rpl r = drawFixit s e rpl .# r data Fixit = Fixit { _fixitSpan :: {-# UNPACK #-} !Span , _fixitReplacement :: !ByteString } deriving (Eq,Ord,Show,Data,Typeable,Generic) makeClassy ''Fixit instance HasSpan Fixit where span = fixitSpan instance Hashable Fixit instance Reducer Fixit Rendering where unit = render instance Renderable Fixit where render (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ rendered s bs trifecta-1.6/src/Text/Trifecta/Result.hs0000644000000000000000000001201312736107753016445 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# 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 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- -- Results and Parse Errors ----------------------------------------------------------------------------- module Text.Trifecta.Result ( -- * Parse Results Result(..) , AsResult(..) , _Success , _Failure -- * Parsing Errors , Err(..), HasErr(..), Errable(..) , ErrInfo(..) , explain , 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 Text.Trifecta.Rendering import Text.Trifecta.Delta as Delta data ErrInfo = ErrInfo { _errDoc :: Doc , _errDeltas :: [Delta] } deriving(Show) -- | This is used to report an error. What went wrong, some supplemental docs and a set of things expected -- at the current location. This does not, however, include the actual location. data Err = Err { _reason :: Maybe Doc , _footnotes :: [Doc] , _expected :: Set String , _finalDeltas :: [Delta] } makeClassy ''Err instance Semigroup Err where Err md mds mes delta1 <> Err nd nds nes delta2 = Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes) (delta1 <> delta2) {-# INLINE (<>) #-} instance Monoid Err where mempty = Err Nothing [] mempty mempty {-# INLINE mempty #-} mappend = (<>) {-# INLINE 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 #-} -- | Convert a location and an 'Err' into a 'Doc' explain :: Rendering -> Err -> Doc explain r (Err mm as es _) | Set.null es = report (withEx mempty) | isJust mm = report $ withEx $ Pretty.char ',' <+> expecting | otherwise = report expecting where now = spaceHack $ toList es spaceHack [""] = ["space"] spaceHack xs = List.filter (/= "") xs withEx x = fromMaybe (fillSep $ 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)) <|> as class Errable m where raiseErr :: Err -> m a instance Monoid ErrInfo where mempty = ErrInfo mempty mempty mappend (ErrInfo xs d1) (ErrInfo ys d2) = ErrInfo (vsep [xs, ys]) (max d1 d2) -- | The result of parsing. Either we succeeded or something went wrong. data Result a = Success a | Failure ErrInfo deriving (Show,Functor,Foldable,Traversable) -- | 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 #-} -- | 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 #-} -- | 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 instance Applicative Result where pure = Success {-# INLINE 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 (<*>) #-} instance Alternative Result where Failure x <|> Failure y = Failure $ ErrInfo (vsep [_errDoc x, _errDoc y]) (_errDeltas x <> _errDeltas y) Success a <|> Success _ = Success a Success a <|> Failure _ = Success a Failure _ <|> Success a = Success a {-# INLINE (<|>) #-} empty = Failure mempty {-# INLINE empty #-} trifecta-1.6/src/Text/Trifecta/Rope.hs0000644000000000000000000000640712736107753016106 0ustar0000000000000000{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, DeriveDataTypeable, DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Text.Trifecta.Rope ( Rope(..) , rope , Strand(..) , strand , strands , grabRest , 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 Text.Trifecta.Delta import Data.Data data Strand = Strand {-# UNPACK #-} !ByteString !Delta | Skipping !Delta deriving (Show, Data, Typeable, Generic) strand :: ByteString -> Strand strand bs = Strand bs (delta bs) instance Measured Delta Strand where measure (Strand _ s) = delta s measure (Skipping d) = d instance Hashable Strand instance HasDelta Strand where delta = measure instance HasBytes Strand where bytes (Strand _ d) = bytes d bytes _ = 0 data Rope = Rope !Delta !(FingerTree Delta Strand) deriving Show rope :: FingerTree Delta Strand -> Rope rope r = Rope (measure r) r 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 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 instance HasBytes Rope where bytes = bytes . measure instance HasDelta Rope where delta = measure instance Measured Delta Rope where measure (Rope s _) = s instance Monoid Rope where mempty = Rope mempty mempty mappend = (<>) instance Semigroup Rope where Rope mx x <> Rope my y = Rope (mx <> my) (x `mappend` y) instance Reducer Rope Rope where unit = id instance Reducer Strand Rope where unit s = rope (FingerTree.singleton s) cons s (Rope mt t) = Rope (delta s `mappend` mt) (s <| t) snoc (Rope mt t) !s = Rope (mt `mappend` delta s) (t |> s) instance Reducer Strict.ByteString Rope where unit = unit . strand cons = cons . strand snoc r = snoc r . strand instance Reducer [Char] Rope where unit = unit . strand . UTF8.fromString cons = cons . strand . UTF8.fromString snoc r = snoc r . strand . UTF8.fromString trifecta-1.6/src/Text/Trifecta/Util/0000755000000000000000000000000012736107753015553 5ustar0000000000000000trifecta-1.6/src/Text/Trifecta/Util/Array.hs0000644000000000000000000002462112736107753017172 0ustar0000000000000000{-# 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 #-} trifecta-1.6/src/Text/Trifecta/Util/Combinators.hs0000644000000000000000000000231612736107753020371 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- ---------------------------------------------------------------------------- module Text.Trifecta.Util.Combinators ( argmin , argmax -- * ByteString conversions , fromLazy , toLazy , takeLine , (<$!>) ) where import Data.ByteString.Lazy as Lazy import Data.ByteString as Strict argmin :: Ord b => (a -> b) -> a -> a -> a argmin f a b | f a <= f b = a | otherwise = b {-# INLINE argmin #-} argmax :: Ord b => (a -> b) -> a -> a -> a argmax f a b | f a > f b = a | otherwise = b {-# INLINE argmax #-} fromLazy :: Lazy.ByteString -> Strict.ByteString fromLazy = Strict.concat . Lazy.toChunks toLazy :: Strict.ByteString -> Lazy.ByteString toLazy = Lazy.fromChunks . return takeLine :: Lazy.ByteString -> Lazy.ByteString takeLine s = case Lazy.elemIndex 10 s of Just i -> Lazy.take (i + 1) s Nothing -> s infixl 4 <$!> (<$!>) :: Monad m => (a -> b) -> m a -> m b f <$!> m = do a <- m return $! f a trifecta-1.6/src/Text/Trifecta/Util/IntervalMap.hs0000644000000000000000000002101412736107753020327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} #ifndef MIN_VERSION_lens #define MIN_VERSION_lens(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.IntervalMap -- Copyright : (c) Edward Kmett 2011-2015 -- (c) Ross Paterson 2008 -- License : BSD-style -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable (MPTCs, type families, functional dependencies) -- -- Interval maps implemented using the 'FingerTree' type, following -- section 4.8 of -- -- * Ralf Hinze and Ross Paterson, -- \"Finger trees: a simple general-purpose data structure\", -- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. -- -- -- An amortized running time is given for each operation, with /n/ -- referring to the size of the priority queue. These bounds hold even -- in a persistent (shared) setting. -- -- /Note/: Many of these operations have the same names as similar -- operations on lists in the "Prelude". The ambiguity may be resolved -- using either qualification or the @hiding@ clause. -- -- Unlike "Data.IntervalMap.FingerTree", this version sorts things so -- that the largest interval from a given point comes first. This way -- if you have nested intervals, you get the outermost interval before -- the contained intervals. ----------------------------------------------------------------------------- module Text.Trifecta.Util.IntervalMap ( -- * Intervals Interval(..) -- * Interval maps , IntervalMap(..), singleton, insert -- * Searching , search, intersections, dominators -- * Prepending an offset onto every interval in the map , offset -- * The result monoid , IntInterval(..) , fromList ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative hiding (empty) import Data.Foldable (Foldable(foldMap)) #endif import Control.Lens hiding ((<|),(|>) #if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710 ,(:<) #endif ) import qualified Data.FingerTree as FT import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) import Data.Semigroup import Data.Semigroup.Reducer import Data.Semigroup.Union ---------------------------------- -- 4.8 Application: interval trees ---------------------------------- -- | A closed interval. The lower bound should be less than or equal -- to the higher bound. data Interval v = Interval { low :: v, high :: v } deriving Show instance Ord v => Semigroup (Interval v) where Interval a b <> Interval c d = Interval (min a c) (max b d) -- assumes the monoid and ordering are compatible. instance (Ord v, Monoid v) => Reducer v (Interval v) where unit v = Interval v v cons v (Interval a b) = Interval (v `mappend` a) (v `mappend` b) snoc (Interval a b) v = Interval (a `mappend` v) (b `mappend` v) instance Eq v => Eq (Interval v) where Interval a b == Interval c d = a == c && d == b instance Ord v => Ord (Interval v) where compare (Interval a b) (Interval c d) = case compare a c of LT -> LT EQ -> compare d b -- reversed to put larger intervals first GT -> GT instance Functor Interval where fmap f (Interval a b) = Interval (f a) (f b) instance Foldable Interval where foldMap f (Interval a b) = f a `mappend` f b instance Traversable Interval where traverse f (Interval a b) = Interval <$> f a <*> f b data Node v a = Node (Interval v) a instance Functor (Node v) where fmap f (Node i x) = Node i (f x) instance FunctorWithIndex (Interval v) (Node v) where imap f (Node i x) = Node i (f i x) instance Foldable (Node v) where foldMap f (Node _ x) = f x instance FoldableWithIndex (Interval v) (Node v) where ifoldMap f (Node k v) = f k v instance Traversable (Node v) where traverse f (Node i x) = Node i <$> f x instance TraversableWithIndex (Interval v) (Node v) where itraverse f (Node i x) = Node i <$> f i x -- rightmost interval (including largest lower bound) and largest upper bound. data IntInterval v = NoInterval | IntInterval (Interval v) v instance Ord v => Monoid (IntInterval v) where mempty = NoInterval NoInterval `mappend` i = i i `mappend` NoInterval = i IntInterval _ hi1 `mappend` IntInterval int2 hi2 = IntInterval int2 (max hi1 hi2) instance Ord v => Measured (IntInterval v) (Node v a) where measure (Node i _) = IntInterval i (high i) -- | Map of closed intervals, possibly with duplicates. -- The 'Foldable' and 'Traversable' instances process the intervals in -- lexicographical order. newtype IntervalMap v a = IntervalMap { runIntervalMap :: FingerTree (IntInterval v) (Node v a) } -- ordered lexicographically by interval instance Functor (IntervalMap v) where fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) instance FunctorWithIndex (Interval v) (IntervalMap v) where imap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (imap f) t) instance Foldable (IntervalMap v) where foldMap f (IntervalMap t) = foldMap (foldMap f) t instance FoldableWithIndex (Interval v) (IntervalMap v) where ifoldMap f (IntervalMap t) = foldMap (ifoldMap f) t instance Traversable (IntervalMap v) where traverse f (IntervalMap t) = IntervalMap <$> FT.unsafeTraverse (traverse f) t instance TraversableWithIndex (Interval v) (IntervalMap v) where itraverse f (IntervalMap t) = IntervalMap <$> FT.unsafeTraverse (itraverse f) t instance Ord v => Measured (IntInterval v) (IntervalMap v a) where measure (IntervalMap m) = measure m largerError :: a largerError = error "Text.Trifecta.IntervalMap.larger: the impossible happened" -- | /O(m log (n/\//m))/. Merge two interval maps. -- The map may contain duplicate intervals; entries with equal intervals -- are kept in the original order. instance Ord v => HasUnion (IntervalMap v a) where union (IntervalMap xs) (IntervalMap ys) = IntervalMap (merge1 xs ys) where merge1 as bs = case FT.viewl as of EmptyL -> bs a@(Node i _) :< as' -> l >< a <| merge2 as' r where (l, r) = FT.split larger bs larger (IntInterval k _) = k >= i larger _ = largerError merge2 as bs = case FT.viewl bs of EmptyL -> as b@(Node i _) :< bs' -> l >< b <| merge1 r bs' where (l, r) = FT.split larger as larger (IntInterval k _) = k >= i larger _ = largerError instance Ord v => HasUnion0 (IntervalMap v a) where empty = IntervalMap FT.empty instance Ord v => Monoid (IntervalMap v a) where mempty = empty mappend = union -- | /O(n)/. Add a delta to each interval in the map offset :: (Ord v, Monoid v) => v -> IntervalMap v a -> IntervalMap v a offset v (IntervalMap m) = IntervalMap $ FT.fmap' (\(Node (Interval lo hi) a) -> Node (Interval (mappend v lo) (mappend v hi)) a) m -- | /O(1)/. Interval map with a single entry. singleton :: Ord v => Interval v -> a -> IntervalMap v a singleton i x = IntervalMap (FT.singleton (Node i x)) -- | /O(log n)/. Insert an interval into a map. -- The map may contain duplicate intervals; the new entry will be inserted -- before any existing entries for the same interval. insert :: Ord v => v -> v -> a -> IntervalMap v a -> IntervalMap v a insert lo hi _ m | lo > hi = m insert lo hi x (IntervalMap t) = IntervalMap (l >< Node i x <| r) where i = Interval lo hi (l, r) = FT.split larger t larger (IntInterval k _) = k >= i larger _ = largerError -- | /O(k log (n/\//k))/. All intervals that contain the given interval, -- in lexicographical order. dominators :: Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)] dominators i j = intersections j i -- | /O(k log (n/\//k))/. All intervals that contain the given point, -- in lexicographical order. search :: Ord v => v -> IntervalMap v a -> [(Interval v, a)] search p = intersections p p -- | /O(k log (n/\//k))/. All intervals that intersect with the given -- interval, in lexicographical order. intersections :: Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)] intersections lo hi (IntervalMap t) = matches (FT.takeUntil (greater hi) t) where matches xs = case FT.viewl (FT.dropUntil (atleast lo) xs) of EmptyL -> [] Node i x :< xs' -> (i, x) : matches xs' atleast :: Ord v => v -> IntInterval v -> Bool atleast k (IntInterval _ hi) = k <= hi atleast _ _ = False greater :: Ord v => v -> IntInterval v -> Bool greater k (IntInterval i _) = low i > k greater _ _ = False fromList :: Ord v => [(v, v, a)] -> IntervalMap v a fromList = foldr ins empty where ins (lo, hi, n) = insert lo hi n trifecta-1.6/src/Text/Trifecta/Util/It.hs0000644000000000000000000000723612736107753016473 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.It -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable -- -- harder, better, faster, stronger... ---------------------------------------------------------------------------- module Text.Trifecta.Util.It ( It(Pure, It) , needIt , wantIt , simplifyIt , runIt , fillIt , rewindIt , sliceIt ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Monad #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.ByteString as Strict import Data.ByteString.Lazy as Lazy import Data.Profunctor import Text.Trifecta.Rope import Text.Trifecta.Delta import Text.Trifecta.Util.Combinators as Util data It r a = Pure a | It a (r -> It r a) instance Show a => Show (It r a) where showsPrec d (Pure a) = showParen (d > 10) $ showString "Pure " . showsPrec 11 a showsPrec d (It a _) = showParen (d > 10) $ showString "It " . showsPrec 11 a . showString " ..." instance Functor (It r) where fmap f (Pure a) = Pure $ f a fmap f (It a k) = It (f a) $ fmap f . k instance Profunctor It where rmap = fmap lmap _ (Pure a) = Pure a lmap f (It a g) = It a (lmap f . g . f) instance Applicative (It r) where pure = Pure Pure f <*> Pure a = Pure $ f a Pure f <*> It a ka = It (f a) $ fmap f . ka It f kf <*> Pure a = It (f a) $ fmap ($a) . kf It f kf <*> It a ka = It (f a) $ \r -> kf r <*> ka r indexIt :: It r a -> r -> a indexIt (Pure a) _ = a indexIt (It _ k) r = extract (k r) simplifyIt :: It r a -> r -> It r a simplifyIt (It _ k) r = k r simplifyIt pa _ = pa instance Monad (It r) where return = Pure Pure a >>= f = f a It a k >>= f = It (extract (f a)) $ \r -> case k r of It a' k' -> It (indexIt (f a') r) $ k' >=> f Pure a' -> simplifyIt (f a') r instance ComonadApply (It r) where (<@>) = (<*>) -- | It is a cofree comonad instance Comonad (It r) where duplicate p@Pure{} = Pure p duplicate p@(It _ k) = It p (duplicate . k) extend f p@Pure{} = Pure (f p) extend f p@(It _ k) = It (f p) (extend f . k) extract (Pure a) = a extract (It a _) = a needIt :: a -> (r -> Maybe a) -> 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 wantIt z f = It z k where k r = case f r of (# False, a #) -> It a k (# True, a #) -> Pure a -- scott decoding 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 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 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 #) sliceIt :: Delta -> Delta -> It Rope Strict.ByteString sliceIt !i !j = wantIt mempty $ \r -> (# bj < bytes (rewind (delta r)) , grabRest i r mempty $ const $ Util.fromLazy . Lazy.take (fromIntegral (bj - bi)) #) where bi = bytes i bj = bytes j trifecta-1.6/tests/0000755000000000000000000000000012736107753012524 5ustar0000000000000000trifecta-1.6/tests/doctests.hs0000644000000000000000000000164512736107753014716 0ustar0000000000000000{-# LANGUAGE CPP #-} module Main where import Build_doctests (deps) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad import Data.List import System.Directory import System.FilePath import Test.DocTest main :: IO () main = getSources >>= \sources -> doctest $ "-isrc" : "-idist/build/autogen" : "-optP-include" : "-fobject-code" : "-optPdist/build/autogen/cabal_macros.h" : "-hide-all-packages" : map ("-package="++) deps ++ sources getSources :: IO [FilePath] getSources = filter (isSuffixOf ".hs") <$> go "src" where go dir = do (dirs, files) <- getFilesAndDirectories dir (files ++) . concat <$> mapM go dirs getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c trifecta-1.6/tests/QuickCheck.hs0000644000000000000000000000433312736107753015075 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main ( main ) where import Control.Applicative #if MIN_VERSION_base(4,7,0) import Data.Either #endif #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import qualified Test.QuickCheck as Q import Text.Parser.Char import Text.Parser.Combinators import Text.Trifecta.Parser import Text.Trifecta.Result import System.Exit -- -------------------------------------------------------------------------- -- -- Main main :: IO () main = mapM Q.quickCheckResult tests >>= \x -> case filter (not . passed) x of [] -> exitSuccess _ -> exitFailure where passed Q.Success{} = True passed _ = False -- -------------------------------------------------------------------------- -- -- Tests tests :: [Q.Property] tests = [ Q.property prop_fail , Q.property prop_succeed , Q.property prop_notFollowedBy0 , Q.property prop_notFollowedBy1 , Q.property prop_notFollowedBy2 , Q.property prop_notFollowedBy3 ] -- -------------------------------------------------------------------------- -- -- Properties prop_fail :: String -> Bool prop_fail = isLeft . parse (fail "fail" :: Parser ()) prop_succeed :: String -> Bool prop_succeed = isRight . parse (mempty :: Parser ()) prop_notFollowedBy0 :: Char -> Char -> Bool prop_notFollowedBy0 x y = either (\_ -> x == y) (/= y) $ parse (notFollowedBy (char y) *> anyChar) [x] prop_notFollowedBy1 :: Char -> Bool prop_notFollowedBy1 x = either (\_ -> x == x) (/= x) $ parse (notFollowedBy (char x) *> anyChar) [x] prop_notFollowedBy2 :: String -> Char -> Bool prop_notFollowedBy2 x y = isLeft $ parse (anyChar *> notFollowedBy (char y) *> char y) x prop_notFollowedBy3 :: Char -> Bool prop_notFollowedBy3 x = isRight $ parse (notFollowedBy (char x) <|> char x *> pure ()) [x] -- -------------------------------------------------------------------------- -- -- Utils parse :: Parser a -> String -> Either String a parse p s = case parseString p mempty s of Failure e -> Left (show e) Success a -> Right a #if !MIN_VERSION_base(4,7,0) isLeft :: Either a b -> Bool isLeft = either (const True) (const False) isRight :: Either a b -> Bool isRight = either (const False) (const True) #endif