diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,1 +1,27 @@ language: haskell + +before_install: + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config + - cabal update + + # Try installing some of the build-deps with apt-get for speed. + - travis/cabal-apt-install --only-dependencies --force-reinstall $mode + +install: + - cabal configure $mode + - cabal build + +script: + - $script + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313trifecta\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + +env: + - mode="--enable-tests" script="cabal test --show-details=always" diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,4 @@ -Copyright 2010-2011 Edward Kmett -Copyright 2008 Bryan O'Sullivan +Copyright 2010-2013 Edward Kmett Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,15 @@ +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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,7 +1,44 @@ #!/usr/bin/runhaskell -> module Main (main) where +\begin{code} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where -> import Distribution.Simple +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 = defaultMain +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} diff --git a/examples/RFC2616.hs b/examples/RFC2616.hs --- a/examples/RFC2616.hs +++ b/examples/RFC2616.hs @@ -5,13 +5,10 @@ import Control.Exception (bracket) import System.Environment (getArgs) import System.IO (hClose, openFile, IOMode(ReadMode)) -import Text.Trifecta.Parser.Class hiding (satisfy) -import Text.Trifecta.Parser.Token -import Text.Trifecta.Parser.ByteString -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Parser.Char8 -import Text.Trifecta.Highlight.Prim -import qualified Text.Trifecta.ByteSet as S +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 <$!> @@ -21,13 +18,13 @@ a <- ma return $! f a -token :: MonadParser m => m Char +token :: CharParsing m => m Char token = noneOf $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255'] isHSpace :: Char -> Bool isHSpace c = c == ' ' || c == '\t' -skipHSpaces :: MonadParser m => m () +skipHSpaces :: CharParsing m => m () skipHSpaces = skipSome (satisfy isHSpace) data Request = Request { @@ -36,17 +33,17 @@ , requestProtocol :: String } deriving (Eq, Ord, Show) -requestLine :: MonadParser m => m Request +requestLine :: (Monad m, TokenParsing m) => m Request requestLine = Request <$!> (highlight ReservedIdentifier (some token) "request method") - <* skipHSpaces + <* skipHSpaces <*> (highlight Identifier (some (satisfy (not . isHSpace))) "url") - <* skipHSpaces - -- <*> try (highlight ReservedIdentifier (string "HTTP/" *> many httpVersion <* endOfLine) "protocol") + <* skipHSpaces <*> (try (highlight ReservedIdentifier (string "HTTP/" *> many httpVersion <* endOfLine)) "protocol") - where - httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.' || c == '9' + where + httpVersion :: (Monad m, CharParsing m) => m Char + httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.' || c == '9' -endOfLine :: MonadParser m => m () +endOfLine :: CharParsing m => m () endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ()) data Header = Header { @@ -54,14 +51,14 @@ , headerValue :: [String] } deriving (Eq, Ord, Show) -messageHeader :: MonadParser m => m Header -messageHeader = (\h b c -> Header h (b : c)) +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 :: MonadParser m => m (Request, [Header]) +request :: (Monad m, TokenParsing m) => m (Request, [Header]) request = (,) <$> requestLine <*> many messageHeader <* endOfLine lumpy arg = do diff --git a/src/Text/Trifecta.hs b/src/Text/Trifecta.hs --- a/src/Text/Trifecta.hs +++ b/src/Text/Trifecta.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta --- Copyright : (C) 2011 Edward Kmett, +-- Copyright : (C) 2011-2013 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -10,21 +10,21 @@ -- ---------------------------------------------------------------------------- module Text.Trifecta - ( module Text.Trifecta.Diagnostic + ( module Text.Trifecta.Rendering , module Text.Trifecta.Highlight - , module Text.Trifecta.Language - , module Text.Trifecta.Layout - , module Text.Trifecta.Literate , module Text.Trifecta.Parser + , module Text.Trifecta.Combinators , module Text.Trifecta.Rope - , module System.Console.Terminfo.PrettyPrint + , module Text.Parser.Combinators + , module Text.Parser.Char + , module Text.Parser.Token ) where -import Text.Trifecta.Diagnostic +import Text.Trifecta.Rendering import Text.Trifecta.Highlight -import Text.Trifecta.Language -import Text.Trifecta.Layout -import Text.Trifecta.Literate import Text.Trifecta.Parser +import Text.Trifecta.Combinators import Text.Trifecta.Rope -import System.Console.Terminfo.PrettyPrint +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 new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Combinators.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Trifecta.Combinators +-- Copyright : (c) Edward Kmett 2011-2013 +-- 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 #-} diff --git a/src/Text/Trifecta/Delta.hs b/src/Text/Trifecta/Delta.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Delta.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Trifecta.Delta +-- Copyright : (C) 2011-2013 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 +import Data.Foldable +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 + +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 #-} + +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 + +nextTab :: Int64 -> Int64 +nextTab x = x + (8 - mod x 8) +{-# INLINE nextTab #-} + +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 #-} + +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 diff --git a/src/Text/Trifecta/Diagnostic.hs b/src/Text/Trifecta/Diagnostic.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic.hs +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic - ( - -- * Diagnostics - Diagnostic(..) - -- * Rendering - , Renderable(..) - , Source - , rendering - , renderingCaret - , Caret(..), Careted(..) - , Span(..), Spanned(..) - , Fixit(..), Rendered(..) - -- * Emitting diagnostics - , MonadDiagnostic(..) - , panic, panicAt - , fatal, fatalAt - , err, errAt - , warn, warnAt - , note, noteAt - , verbose, verboseAt - -- * Diagnostic Levels - , DiagnosticLevel(..) - ) where - -import Text.Trifecta.Diagnostic.Prim -import Text.Trifecta.Diagnostic.Class -import Text.Trifecta.Diagnostic.Combinators -import Text.Trifecta.Diagnostic.Level -import Text.Trifecta.Diagnostic.Rendering diff --git a/src/Text/Trifecta/Diagnostic/Class.hs b/src/Text/Trifecta/Diagnostic/Class.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Class.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, FlexibleContexts, UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Class --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- --- Provides a class for logging and throwing expressive diagnostics. ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Class - ( MonadDiagnostic(..) - ) where - -import Control.Monad.Trans.Class -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Identity -import Data.Monoid -import Text.Trifecta.Diagnostic.Prim - -class Monad m => MonadDiagnostic e m | m -> e where - throwDiagnostic :: Diagnostic e -> m a - logDiagnostic :: Diagnostic e -> m () - -instance MonadDiagnostic e m => MonadDiagnostic e (Lazy.StateT s m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance MonadDiagnostic e m => MonadDiagnostic e (Strict.StateT s m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance MonadDiagnostic e m => MonadDiagnostic e (ReaderT r m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance (MonadDiagnostic e m, Monoid w) => MonadDiagnostic e (Lazy.WriterT w m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance (MonadDiagnostic e m, Monoid w) => MonadDiagnostic e (Strict.WriterT w m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance (MonadDiagnostic e m, Monoid w) => MonadDiagnostic e (Lazy.RWST r w s m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance (MonadDiagnostic e m, Monoid w) => MonadDiagnostic e (Strict.RWST r w s m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance MonadDiagnostic e m => MonadDiagnostic e (IdentityT m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic diff --git a/src/Text/Trifecta/Diagnostic/Combinators.hs b/src/Text/Trifecta/Diagnostic/Combinators.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Combinators.hs +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Combinators --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- --- Combinators for throwing and logging expressive diagnostics ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Combinators - ( panic, panicAt - , fatal, fatalAt - , err, errAt - , warn, warnAt - , note, noteAt - , verbose, verboseAt - ) where - -import Control.Applicative -import Control.Monad.Instances () -import Text.Trifecta.Parser.Class -import Text.Trifecta.Diagnostic.Class -import Text.Trifecta.Diagnostic.Prim -import Text.Trifecta.Diagnostic.Level -import Text.Trifecta.Diagnostic.Rendering.Prim -import Text.Trifecta.Diagnostic.Rendering.Caret -import Text.Trifecta.Rope.Delta - -rendCaret :: MonadParser m => m Rendering -rendCaret = (delta >>= addCaret) <$> rend - -panicAt, fatalAt, errAt :: MonadDiagnostic e m => [Diagnostic e] -> e -> Rendering -> m a -panicAt es e r = throwDiagnostic $ Diagnostic (Right r) Panic e es -fatalAt es e r = throwDiagnostic $ Diagnostic (Right r) Fatal e es -errAt es e r = throwDiagnostic $ Diagnostic (Right r) Error e es - -panic, fatal, err :: (MonadParser m, MonadDiagnostic e m) => [Diagnostic e] -> e -> m a -panic es e = rendCaret >>= panicAt es e -fatal es e = rendCaret >>= fatalAt es e -err es e = rendCaret >>= errAt es e - -warnAt, noteAt :: MonadDiagnostic e m => [Diagnostic e] -> e -> Rendering -> m () -warnAt es e r = logDiagnostic $ Diagnostic (Right r) Warning e es -noteAt es e r = logDiagnostic $ Diagnostic (Right r) Note e es - -verboseAt :: MonadDiagnostic e m => Int -> [Diagnostic e] -> e -> Rendering -> m () -verboseAt l es e r = logDiagnostic $ Diagnostic (Right r) (Verbose l) e es - -warn, note :: (MonadParser m, MonadDiagnostic e m) => [Diagnostic e] -> e -> m () -warn es e = rendCaret >>= warnAt es e -note es e = rendCaret >>= noteAt es e - -verbose :: (MonadParser m, MonadDiagnostic e m) => Int -> [Diagnostic e] -> e -> m () -verbose l es e = rendCaret >>= verboseAt l es e diff --git a/src/Text/Trifecta/Diagnostic/Err.hs b/src/Text/Trifecta/Diagnostic/Err.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Err.hs +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Err --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- --- The unlocated error type used internally within the parser. ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Err - ( Err(..) - , knownErr - , fatalErr - ) where - -import Control.Applicative -import Data.Foldable -import Data.Traversable -import Data.Semigroup -import Data.Functor.Plus -import Text.Trifecta.Diagnostic.Prim -import Text.Trifecta.Diagnostic.Level -import Text.Trifecta.Diagnostic.Rendering.Prim - -data Err e - = EmptyErr -- no error specified, unlocated - | FailErr Rendering String -- a recoverable error caused by fail from a known location - | PanicErr Rendering String -- something is bad with the grammar, fail fast - | Err !(Diagnostic e) -- a user defined error message - deriving Show - -knownErr :: Err e -> Bool -knownErr EmptyErr = False -knownErr _ = True - -fatalErr :: Err e -> Bool -fatalErr (Err (Diagnostic _ Panic _ _)) = True -fatalErr (Err (Diagnostic _ Fatal _ _)) = True -fatalErr (PanicErr _ _) = True -fatalErr _ = False - -instance Functor Err where - fmap _ EmptyErr = EmptyErr - fmap _ (FailErr r s) = FailErr r s - fmap _ (PanicErr r s) = PanicErr r s - fmap f (Err e) = Err (fmap f e) - -instance Foldable Err where - foldMap _ EmptyErr = mempty - foldMap _ FailErr{} = mempty - foldMap _ PanicErr{} = mempty - foldMap f (Err e) = foldMap f e - -instance Traversable Err where - traverse _ EmptyErr = pure EmptyErr - traverse _ (FailErr r s) = pure $ FailErr r s - traverse _ (PanicErr r s) = pure $ PanicErr r s - traverse f (Err e) = Err <$> traverse f e - --- | Merge two errors, selecting the most severe. -instance Alt Err where - a EmptyErr = a - _ a@(Err (Diagnostic _ Panic _ _)) = a - a@(Err (Diagnostic _ Panic _ _)) _ = a - _ a@PanicErr{} = a - a@PanicErr{} _ = a - _ a@(Err (Diagnostic _ Fatal _ _)) = a - a@(Err (Diagnostic _ Fatal _ _)) _ = a - _ b = b - {-# INLINE () #-} - --- | Merge two errors, selecting the most severe. -instance Plus Err where - zero = EmptyErr - --- | Merge two errors, selecting the most severe. -instance Semigroup (Err t) where - (<>) = () - times1p _ = id - --- | Merge two errors, selecting the most severe. -instance Monoid (Err t) where - mempty = EmptyErr - mappend = () diff --git a/src/Text/Trifecta/Diagnostic/Err/Log.hs b/src/Text/Trifecta/Diagnostic/Err/Log.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Err/Log.hs +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Err.Log --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Err.Log - ( ErrLog(..) - ) where - -import Data.Functor.Plus -import Data.Semigroup -import Text.Trifecta.Diagnostic.Prim -import Text.Trifecta.Highlight.Prim -import Data.Semigroup.Union (union, empty) -import Data.Sequence (Seq) - -data ErrLog e = ErrLog - { errLog :: !(Seq (Diagnostic e)) - , errHighlights :: !Highlights - } - -instance Functor ErrLog where - fmap f (ErrLog a b) = ErrLog (fmap (fmap f) a) b - -instance Alt ErrLog where - ErrLog a b ErrLog a' b' = ErrLog (a <> a') (union b b') - {-# INLINE () #-} - -instance Plus ErrLog where - zero = ErrLog mempty empty - -instance Semigroup (ErrLog e) where - (<>) = () - -instance Monoid (ErrLog e) where - mempty = zero - mappend = () diff --git a/src/Text/Trifecta/Diagnostic/Err/State.hs b/src/Text/Trifecta/Diagnostic/Err/State.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Err/State.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Err.State --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Err.State - ( ErrState(..) - ) where - -import Data.Functor.Plus -import Data.Set as Set -import Data.Semigroup -import Text.Trifecta.Diagnostic.Err -import Text.Trifecta.Diagnostic.Rendering.Caret - -data ErrState e = ErrState - { errExpected :: !(Set (Careted String)) - , errMessage :: !(Err e) - } - -instance Functor ErrState where - fmap f (ErrState a b) = ErrState a (fmap f b) - -instance Alt ErrState where - ErrState a b ErrState a' b' = ErrState (a <> a') (b <> b') - {-# INLINE () #-} - -instance Plus ErrState where - zero = ErrState mempty mempty - -instance Semigroup (ErrState e) where - (<>) = () - -instance Monoid (ErrState e) where - mempty = zero - mappend = () diff --git a/src/Text/Trifecta/Diagnostic/Level.hs b/src/Text/Trifecta/Diagnostic/Level.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Level.hs +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Level --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- --- A fairly straightforward set of common error levels. ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Level - ( DiagnosticLevel(..) - ) where - -import Control.Applicative -import Data.Semigroup -import Text.PrettyPrint.Free -import System.Console.Terminfo.PrettyPrint - --- | The severity of an error (or message) -data DiagnosticLevel - = Verbose !Int -- ^ a comment we should only show to the excessively curious - | Note -- ^ a comment - | Warning -- ^ a warning, computation continues - | Error -- ^ a user specified error - | Fatal -- ^ a user specified fatal error - | Panic -- ^ a non-maskable death sentence thrown by the parser itself - deriving (Eq,Show,Read) - -instance Ord DiagnosticLevel where - compare (Verbose n) (Verbose m) = compare m n - compare (Verbose _) _ = LT - compare Note (Verbose _) = GT - compare Note Note = EQ - compare Note _ = LT - compare Warning (Verbose _) = GT - compare Warning Note = GT - compare Warning Warning = EQ - compare Warning _ = LT - compare Error Error = EQ - compare Error Fatal = LT - compare Error Panic = LT - compare Error _ = GT - compare Fatal Panic = LT - compare Fatal Fatal = EQ - compare Fatal _ = GT - compare Panic Panic = EQ - compare Panic _ = GT - --- | Compute the maximum of two diagnostic levels -instance Semigroup DiagnosticLevel where - (<>) = max - -instance Pretty DiagnosticLevel where - pretty p = prettyTerm p *> empty - --- | pretty print as a color coded description -instance PrettyTerm DiagnosticLevel where - prettyTerm (Verbose n) = blue $ text "verbose (" <> prettyTerm n <> char ')' - prettyTerm Note = black $ text "note" - prettyTerm Warning = magenta $ text "warning" - prettyTerm Error = red $ text "error" - prettyTerm Fatal = standout $ red $ text "fatal" - prettyTerm Panic = standout $ red $ text "panic" diff --git a/src/Text/Trifecta/Diagnostic/Prim.hs b/src/Text/Trifecta/Diagnostic/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Prim.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Prim --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- --- Rich diagnostics ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Prim - ( Diagnostic(..) - ) where - -import Control.Applicative -import Control.Comonad -import Control.Monad (guard) -import Control.Exception -import Data.Functor.Apply -import Data.Foldable -import Data.Traversable -import Data.List.NonEmpty hiding (map) -import Data.Semigroup -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Diagnostic.Rendering.Prim -import Text.Trifecta.Diagnostic.Level -import Text.PrettyPrint.Free -import Text.Trifecta.Highlight.Class -import System.Console.Terminfo.PrettyPrint -import Prelude hiding (log) -import Data.Typeable - -data Diagnostic m = Diagnostic !(Either String Rendering) !DiagnosticLevel m [Diagnostic m] - deriving (Show, Typeable) - -instance Highlightable (Diagnostic e) where - addHighlights h (Diagnostic rs l m xs) = Diagnostic (addHighlights h <$> rs) l m (addHighlights h <$> xs) - -instance (Typeable m, Show m) => Exception (Diagnostic m) - -instance Renderable (Diagnostic m) where - render (Diagnostic r _ _ _) = either (const emptyRendering) id r - -instance HasDelta (Diagnostic m) where - delta (Diagnostic r _ _ _) = either (const mempty) delta r - -instance HasBytes (Diagnostic m) where - bytes (Diagnostic r _ _ _) = either (const 0) (bytes . delta) r - -instance Comonad Diagnostic where - extend f d@(Diagnostic r l _ xs) = Diagnostic r l (f d) (map (extend f) xs) - extract (Diagnostic _ _ m _) = m - -instance Pretty m => Pretty (Diagnostic m) where - pretty (Diagnostic src l m xs) = case src of - Left p -> vsep $ [pretty p <> msg] - <|> children - Right r -> vsep $ [pretty (delta r) <> msg] - <|> pretty r <$ guard (not (nullRendering r)) - <|> children - where - msg = char ':' <+> pretty l <> char ':' <+> nest 4 (pretty m) - children = indent 2 (prettyList xs) <$ guard (not (null xs)) - - prettyList = vsep . Prelude.map pretty - -instance PrettyTerm m => PrettyTerm (Diagnostic m) where - prettyTerm (Diagnostic src l m xs) = case src of - Left p -> vsep $ [prettyTerm p <> msg] - <|> children - Right r -> vsep $ [prettyTerm (delta r) <> msg] - <|> prettyTerm r <$ guard (not (nullRendering r)) - <|> children - where - msg = char ':' <+> prettyTerm l <> char ':' <+> nest 4 (prettyTerm m) - children = indent 2 (prettyTermList xs) <$ guard (not (null xs)) - prettyTermList = vsep . Prelude.map prettyTerm - -instance Functor Diagnostic where - fmap f (Diagnostic r l m xs) = Diagnostic r l (f m) $ map (fmap f) xs - -instance Foldable Diagnostic where - foldMap f (Diagnostic _ _ m xs) = f m `mappend` foldMap (foldMap f) xs - -instance Traversable Diagnostic where - traverse f (Diagnostic r l m xs) = Diagnostic r l <$> f m <*> traverse (traverse f) xs - -instance Foldable1 Diagnostic where - foldMap1 f (Diagnostic _ _ m []) = f m - foldMap1 f (Diagnostic _ _ m (x:xs)) = f m <> foldMap1 (foldMap1 f) (x:|xs) - -instance Traversable1 Diagnostic where - traverse1 f (Diagnostic r l m []) = fmap (\fm -> Diagnostic r l fm []) (f m) - traverse1 f (Diagnostic r l m (x:xs)) = (\fm (y:|ys) -> Diagnostic r l fm (y:ys)) - <$> f m - <.> traverse1 (traverse1 f) (x:|xs) diff --git a/src/Text/Trifecta/Diagnostic/Rendering.hs b/src/Text/Trifecta/Diagnostic/Rendering.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Rendering.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Rendering --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Rendering - ( Renderable(..) - , Source, rendering, renderingCaret - , Caret(..), Careted(..) - , Span(..), Spanned(..) - , Fixit(..), Rendered(..) - ) where - -import Text.Trifecta.Diagnostic.Rendering.Prim -import Text.Trifecta.Diagnostic.Rendering.Caret -import Text.Trifecta.Diagnostic.Rendering.Span -import Text.Trifecta.Diagnostic.Rendering.Fixit diff --git a/src/Text/Trifecta/Diagnostic/Rendering/Caret.hs b/src/Text/Trifecta/Diagnostic/Rendering/Caret.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Rendering/Caret.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Rendering.Caret --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Rendering.Caret - ( Caret(..) - , caret - , Careted(..) - , careted - -- * Internals - , drawCaret - , addCaret - , caretEffects - , renderingCaret - ) where - -import Control.Applicative -import Control.Comonad -import Data.ByteString (ByteString) -import Data.Foldable -import Data.Hashable -import Data.Semigroup -import Data.Semigroup.Reducer -import Data.Traversable -import Prelude hiding (span) -import System.Console.Terminfo.Color -import System.Console.Terminfo.PrettyPrint -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Parser.Class -import Text.Trifecta.Diagnostic.Rendering.Prim - --- | --- > 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) - -instance Hashable Caret where - hash (Caret d bs) = hash d `hashWithSalt` bs - -caretEffects :: [ScopedEffect] -caretEffects = [soft (Foreground Green), soft Bold] - -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 - -caret :: MonadParser m => m Caret -caret = Caret <$> position <*> line - -careted :: MonadParser m => m a -> m (Careted a) -careted p = do - m <- position - l <- line - a <- p - return $ a :^ Caret m l - -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 $ rendering d bs - -instance Reducer Caret Rendering where - unit = render - -instance Semigroup Caret where - a <> _ = a - -renderingCaret :: Delta -> ByteString -> Rendering -renderingCaret d bs = addCaret d $ rendering d bs - -data Careted a = a :^ Caret deriving (Eq,Ord,Show) - -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 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) where - diff --git a/src/Text/Trifecta/Diagnostic/Rendering/Fixit.hs b/src/Text/Trifecta/Diagnostic/Rendering/Fixit.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Rendering/Fixit.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Rendering.Fixit --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Rendering.Fixit - ( Fixit(..) - , drawFixit - , addFixit - , fixit - ) where - -import Data.Functor -import Data.Hashable -import Data.ByteString (ByteString) -import qualified Data.ByteString as Strict -import qualified Data.ByteString.UTF8 as UTF8 -import Data.Semigroup.Reducer -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Diagnostic.Rendering.Prim -import Text.Trifecta.Diagnostic.Rendering.Span -import Text.Trifecta.Parser.Class -import Text.Trifecta.Util.Combinators -import System.Console.Terminfo.Color -import System.Console.Terminfo.PrettyPrint -import Prelude hiding (span) - --- | --- > int main(int argc char ** argv) { int; } --- > ^ --- > , -drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines -drawFixit s e rpl d a = ifNear l (draw [soft (Foreground 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 :: {-# UNPACK #-} !ByteString - } deriving (Eq,Ord,Show) - -instance Hashable Fixit where - hash (Fixit s b) = hash s `hashWithSalt` b - -instance Reducer Fixit Rendering where - unit = render - -instance Renderable Fixit where - render (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ rendering s bs - -fixit :: MonadParser m => m Strict.ByteString -> m Fixit -fixit p = (\(r :~ s) -> Fixit s r) <$> spanned p diff --git a/src/Text/Trifecta/Diagnostic/Rendering/Prim.hs b/src/Text/Trifecta/Diagnostic/Rendering/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Rendering/Prim.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Rendering.Prim --- Copyright : (C) 2011 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.Diagnostic.Rendering.Prim - ( Rendering(..) - , nullRendering - , emptyRendering - , Source(..) - , rendering - , Renderable(..) - , Rendered(..) - -- * Lower level drawing primitives - , Lines - , draw - , ifNear - , (.#) - ) where - -import Control.Applicative -import Control.Comonad -import Control.Monad.State -import Data.Array -import Data.ByteString as B hiding (groupBy, empty, any) -import Data.Foldable -import Data.Function (on) -import Data.Int (Int64) -import Data.Functor.Bind -import Data.List (groupBy) -import Data.Semigroup -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Data.Traversable -import Text.Trifecta.IntervalMap -import Prelude as P -import Prelude hiding (span) -import System.Console.Terminfo.Color -import System.Console.Terminfo.PrettyPrint -import Text.PrettyPrint.Free hiding (column) -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Highlight.Class -import Text.Trifecta.Highlight.Effects -import qualified Data.ByteString.UTF8 as UTF8 - -outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect] -outOfRangeEffects xs = soft Bold : xs - -type Lines = Array (Int,Int64) ([ScopedEffect], 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 :: [ScopedEffect] -> Int -> Int64 -> String -> Lines -> Lines -draw e y n xs a0 - | Prelude.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 | Prelude.any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))]) - | otherwise = id - gt | Prelude.any (\el -> snd (fst el) > hi) out = (// [((y,hi),(outOfRangeEffects e,'>'))]) - | otherwise = id - --- | fill the interval from [n .. m) with a given effect -recolor :: ([ScopedEffect] -> [ScopedEffect]) -> Maybe Int64 -> Maybe Int64 -> Lines -> Lines -recolor f n0 m0 a0 - | m <= n = a0 - | otherwise = a /// P.map rc [n .. m - 1] - where - ((_,lo),(_,hi)) = bounds a - n = maybe lo id n0 - m = maybe (hi + 1) id m0 - a = grow 0 a0 - rc i = (yi, (f e, c)) -- only if not isSpace? - where - yi = (0, i) - (e,c) = a ! yi - -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 - } - -instance Highlightable Rendering where - addHighlights intervals (Rendering d ll lb l o) = Rendering d ll lb l' o where - d' = rewind d - l' = Prelude.foldr (.) l [ recolor (eff tok) (column lo <$ guard (near d lo)) (column hi <$ guard (near d hi)) - | (Interval lo hi, tok) <- intersections d' (d' <> Columns ll lb) intervals ] - eff t _ = highlightEffects t - -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) "" - -instance Semigroup Rendering where - -- an unprincipled hack - Rendering (Columns 0 0) 0 0 _ f <> Rendering del len lb doc g = Rendering del len lb doc $ \d l -> f d (g d l) - Rendering del len lb doc f <> Rendering _ _ _ _ g = Rendering del len lb doc $ \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 - | Prelude.elem '\n' s = ( ls, bs, draw [] 0 0 s') - | otherwise = ( ls + fromIntegral (Prelude.length end), bs, draw [soft (Foreground Blue), soft Bold] 0 ls end . draw [] 0 0 s') - where - end = "" - s' = go 0 s - bs = fromIntegral $ B.length $ UTF8.fromString $ Prelude.takeWhile (/='\n') s - ls = fromIntegral $ Prelude.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 -rendering :: Source s => Delta -> s -> Rendering -rendering del s = case source s of - (len, lb, doc) -> Rendering del len lb doc (\_ 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 r = prettyTerm r >>= const empty - -instance PrettyTerm Rendering where - prettyTerm (Rendering d ll _ l f) = nesting $ \k -> columns $ \n -> go (fromIntegral (n - 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 -> P.foldr with (pretty (P.map snd g)) (fst (P.head 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 Apply Rendered where - (f :@ s) <.> (a :@ t) = f a :@ (s <> t) - -instance ComonadApply Rendered where - (f :@ s) <@> (a :@ t) = f a :@ (s <> t) - -instance Bind Rendered where - (a :@ s) >>- f = case f a of - b :@ t -> b :@ (s <> t) - -instance Foldable Rendered where - foldMap f (a :@ _) = f a - -instance Traversable Rendered where - traverse f (a :@ s) = (:@ s) <$> f a - -instance Foldable1 Rendered where - foldMap1 f (a :@ _) = f a - -instance Traversable1 Rendered where - traverse1 f (a :@ s) = (:@ s) <$> f a - -instance Renderable (Rendered a) where - render (_ :@ s) = s diff --git a/src/Text/Trifecta/Diagnostic/Rendering/Span.hs b/src/Text/Trifecta/Diagnostic/Rendering/Span.hs deleted file mode 100644 --- a/src/Text/Trifecta/Diagnostic/Rendering/Span.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Diagnostic.Rendering.Span --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Diagnostic.Rendering.Span - ( Span(..) - , span - , Spanned(..) - , spanned - -- * Internals - , spanEffects - , drawSpan - , addSpan - ) where - -import Control.Applicative -import Data.Hashable -import Data.Semigroup -import Data.Semigroup.Reducer -import Data.Foldable -import Data.Traversable -import Control.Comonad -import Data.ByteString (ByteString) -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Diagnostic.Rendering.Prim -import Text.Trifecta.Util.Combinators -import Text.Trifecta.Parser.Class -import Data.Array -import System.Console.Terminfo.Color -import System.Console.Terminfo.PrettyPrint -import Prelude as P hiding (span) - -spanEffects :: [ScopedEffect] -spanEffects = [soft (Foreground 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) - -instance Renderable Span where - render (Span s e bs) = addSpan s e $ rendering s bs - -instance Semigroup Span where - Span s _ b <> Span _ e _ = Span s e b - -instance Reducer Span Rendering where - unit = render - -data Spanned a = a :~ Span deriving (Eq,Ord,Show) - -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 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 Span where - hash (Span s e bs) = hash s `hashWithSalt` e `hashWithSalt` bs - -instance Hashable a => Hashable (Spanned a) where - hash (a :~ s) = hash a `hashWithSalt` s - -span :: MonadParser m => m a -> m Span -span p = (\s l e -> Span s e l) <$> position <*> line <*> (p *> position) - -spanned :: MonadParser m => m a -> m (Spanned a) -spanned p = (\s l a e -> a :~ Span s e l) <$> position <*> line <*> p <*> position 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,7 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Highlight --- Copyright : (C) 2011 Edward Kmett +-- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -9,14 +11,150 @@ -- Portability : non-portable -- ---------------------------------------------------------------------------- -module Text.Trifecta.Highlight - ( - -- * Text.Trifecta.Highlight.Class - Highlightable(..) - -- * Text.Trifecta.Highlight.Prim - , Highlight - , Highlights +module Text.Trifecta.Highlight + ( Highlight + , HighlightedRope(HighlightedRope) + , HasHighlightedRope(..) + , withHighlight + , HighlightDoc(HighlightDoc) + , HasHighlightDoc(..) + , doc ) where -import Text.Trifecta.Highlight.Class -import Text.Trifecta.Highlight.Prim +import Control.Lens +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 +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 + +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 + +{- +pushToken, popToken :: Highlight -> Doc +pushToken h = Prelude.foldr (\x b -> pure (Push x) <> b) mempty (withHighlight h) +popToken h = Prelude.foldr (\_ b -> pure Pop <> b) mempty (withHighlight h) +-} + +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 + , preEscapedString "" :@ 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 + +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 + preEscapedString "\n" + title $ toHtml t + link ! rel "stylesheet" ! type_ "text/css" ! href (toValue css) + body $ toHtml cs + +{- +newtype Highlighter m a = Highlighter { runHighlighter :: IntervalMap Map Highlight -> m (a, IntervalMap Map Highlight) } + deriving (Functor) + +instance (Functor m, Monad m) => Applicative (Highlighter m) where + (<*>) = ap + pure = return + +instance (Functor m, MonadPlus m) => Alternative (Highlighter m) where + (<|>) = mplus + empty = mzero + +instance Monad m => Monad (Highlighter m) where + return a = Highlighter $ \s -> return (a, s) + Highlighter m >>= f = Highlighter $ \s -> m s >>= \(a, s') -> runHighlighter (f a) s' + +instance MonadTrans Highlighter where + lift m = Highlighter $ \s -> fmap (\a -> (a,s)) m + +instance MonadPlus m => MonadPlus (Highlighter m) where + mplus (Highlighter m) (Highligher n) = Highlighter $ \s -> m s `mplus` n s + mzero = Highlighter $ const mzero + +-- instance Parsing m => Parsing (Highlighter m) where +-} diff --git a/src/Text/Trifecta/Highlight/Class.hs b/src/Text/Trifecta/Highlight/Class.hs deleted file mode 100644 --- a/src/Text/Trifecta/Highlight/Class.hs +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Highlight.Class --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Highlight.Class - ( Highlightable(..) - ) where - -import Text.Trifecta.Highlight.Prim - -class Highlightable a where - addHighlights :: Highlights -> a -> a diff --git a/src/Text/Trifecta/Highlight/Effects.hs b/src/Text/Trifecta/Highlight/Effects.hs deleted file mode 100644 --- a/src/Text/Trifecta/Highlight/Effects.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Highlight.Effects --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Highlight.Effects - ( highlightEffects - , pushToken - , popToken - , withHighlight - ) where - -import Control.Applicative -import System.Console.Terminfo.PrettyPrint -import System.Console.Terminfo.Color -import Data.Semigroup -import Text.Trifecta.Highlight.Prim - -highlightEffects :: Highlight -> [ScopedEffect] -highlightEffects Comment = [soft $ Foreground Blue] -highlightEffects ReservedIdentifier = [soft $ Foreground Magenta, soft Bold] -highlightEffects ReservedConstructor = [soft $ Foreground Magenta, soft Bold] -highlightEffects EscapeCode = [soft $ Foreground Magenta, soft Bold] -highlightEffects Operator = [soft $ Foreground Yellow] -highlightEffects CharLiteral = [soft $ Foreground Cyan] -highlightEffects StringLiteral = [soft $ Foreground Cyan] -highlightEffects Constructor = [soft Bold] -highlightEffects ReservedOperator = [soft $ Foreground Yellow] -highlightEffects ConstructorOperator = [soft $ Foreground Yellow, soft Bold] -highlightEffects ReservedConstructorOperator = [soft $ Foreground Yellow, soft Bold] -highlightEffects _ = [] - -pushToken, popToken :: Highlight -> TermDoc -pushToken h = foldr (\a b -> pure (Push a) <> b) mempty (highlightEffects h) -popToken h = foldr (\_ b -> pure Pop <> b) mempty (highlightEffects h) - -withHighlight :: Highlight -> TermDoc -> TermDoc -withHighlight h d = pushToken h <> d <> popToken h diff --git a/src/Text/Trifecta/Highlight/Prim.hs b/src/Text/Trifecta/Highlight/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Highlight/Prim.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Highlight.Prim --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Highlight.Prim - ( Highlight(..) - , Highlights - ) where - -import Data.Ix -import Text.Trifecta.IntervalMap -import Text.Trifecta.Rope.Delta - -data Highlight - = EscapeCode - | Number - | Comment - | CharLiteral - | StringLiteral - | Constant - | Statement - | Special - | Symbol - | Identifier - | ReservedIdentifier - | Operator - | ReservedOperator - | Constructor - | ReservedConstructor - | ConstructorOperator - | ReservedConstructorOperator - | BadInput - | Unbound - | Layout - | MatchedSymbols - | LiterateComment - | LiterateSyntax - deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded) - -type Highlights = IntervalMap Delta Highlight diff --git a/src/Text/Trifecta/Highlight/Rendering/HTML.hs b/src/Text/Trifecta/Highlight/Rendering/HTML.hs deleted file mode 100644 --- a/src/Text/Trifecta/Highlight/Rendering/HTML.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Highlight.Rendering.HTML --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Highlight.Rendering.HTML - ( Doc(..) - , doc - ) where - -import Data.Monoid -import Prelude hiding (head) -import Text.Blaze -import Text.Blaze.Html5 hiding (b,i) -import Text.Blaze.Html5.Attributes hiding (title) -import Text.Trifecta.Highlight.Class -import Text.Trifecta.Rope.Highlighted - --- | Represents a source file like an HsColour rendered document -data Doc = Doc - { docTitle :: String - , docCss :: String -- href for the css file - , docContent :: HighlightedRope - } - --- | --- --- > renderHtml $ toHtml $ addHighlights highlightedRope $ doc "Foo.hs" -doc :: String -> Doc -doc t = Doc t "trifecta.css" mempty - -instance ToHtml Doc where - toHtml (Doc t css cs) = docTypeHtml $ do - head $ do - preEscapedString "\n" - title $ toHtml t - link ! rel "stylesheet" ! type_ "text/css" ! href (toValue css) - body $ toHtml cs - -instance Highlightable Doc where - addHighlights h (Doc t c r) = Doc t c (addHighlights h r) diff --git a/src/Text/Trifecta/Instances.hs b/src/Text/Trifecta/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Instances.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Trifecta.Instances +-- Copyright : (c) Edward Kmett 2013 +-- 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 + (<>) = (<>) diff --git a/src/Text/Trifecta/IntervalMap.hs b/src/Text/Trifecta/IntervalMap.hs deleted file mode 100644 --- a/src/Text/Trifecta/IntervalMap.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.IntervalMap --- Copyright : (c) Edward Kmett 2011 --- (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.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 - -import Control.Applicative hiding (empty) -import qualified Data.FingerTree as FT -import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) -import Data.Functor.Plus - -import Data.Traversable (Traversable(traverse)) -import Data.Foldable (Foldable(foldMap)) -import Data.Bifunctor -import Data.Semigroup -import Data.Semigroup.Reducer -import Data.Semigroup.Union -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Data.Key -import Data.Pointed - ----------------------------------- --- 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 - -instance Foldable1 Interval where - foldMap1 f (Interval a b) = f a <> f b - -instance Traversable1 Interval where - traverse1 f (Interval a b) = Interval <$> f a <.> f b - -instance Pointed Interval where - point v = Interval v v - -data Node v a = Node (Interval v) a - -type instance Key (Node v) = Interval v - -instance Functor (Node v) where - fmap f (Node i x) = Node i (f x) - -instance Bifunctor Node where - bimap f g (Node v a) = Node (fmap f v) (g a) - -instance Keyed (Node v) where - mapWithKey f (Node i x) = Node i (f i x) - -instance Foldable (Node v) where - foldMap f (Node _ x) = f x - -instance FoldableWithKey (Node v) where - foldMapWithKey f (Node k v) = f k v - -instance Traversable (Node v) where - traverse f (Node i x) = Node i <$> f x - -instance TraversableWithKey (Node v) where - traverseWithKey f (Node i x) = Node i <$> f i x - -instance Foldable1 (Node v) where - foldMap1 f (Node _ x) = f x - -instance FoldableWithKey1 (Node v) where - foldMapWithKey1 f (Node k v) = f k v - -instance Traversable1 (Node v) where - traverse1 f (Node i x) = Node i <$> f x - -instance TraversableWithKey1 (Node v) where - traverseWithKey1 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 - -type instance Key (IntervalMap v) = Interval v - -instance Functor (IntervalMap v) where - fmap f (IntervalMap t) = IntervalMap (FT.unsafeFmap (fmap f) t) - -instance Keyed (IntervalMap v) where - mapWithKey f (IntervalMap t) = IntervalMap (FT.unsafeFmap (mapWithKey f) t) - -instance Foldable (IntervalMap v) where - foldMap f (IntervalMap t) = foldMap (foldMap f) t - -instance FoldableWithKey (IntervalMap v) where - foldMapWithKey f (IntervalMap t) = foldMap (foldMapWithKey f) t - -instance Traversable (IntervalMap v) where - traverse f (IntervalMap t) = - IntervalMap <$> FT.unsafeTraverse (traverse f) t - -instance TraversableWithKey (IntervalMap v) where - traverseWithKey f (IntervalMap t) = - IntervalMap <$> FT.unsafeTraverse (traverseWithKey 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 - -instance Ord v => Alt (IntervalMap v) where - () = union - -instance Ord v => Plus (IntervalMap v) where - zero = empty - --- | /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' (first (mappend v)) 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 - diff --git a/src/Text/Trifecta/Language.hs b/src/Text/Trifecta/Language.hs deleted file mode 100644 --- a/src/Text/Trifecta/Language.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Language --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Language - ( Language(..) - , runLanguage - , LanguageDef(..) - , MonadLanguage(..) - , asksLanguage - , identifier - , reserved - , reservedByteString - , op - , reservedOp - , reservedOpByteString - , emptyLanguageDef - , haskellLanguageDef - , haskell98LanguageDef - ) where - -import Text.Trifecta.Language.Class -import Text.Trifecta.Language.Combinators -import Text.Trifecta.Language.Prim -import Text.Trifecta.Language.Monad -import Text.Trifecta.Language.Style - diff --git a/src/Text/Trifecta/Language/Class.hs b/src/Text/Trifecta/Language/Class.hs deleted file mode 100644 --- a/src/Text/Trifecta/Language/Class.hs +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Language.Class --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Language.Class - ( MonadLanguage(..) - , asksLanguage - ) where - -import Control.Monad (liftM) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Identity -import qualified Control.Monad.Trans.Writer.Strict as Strict -import qualified Control.Monad.Trans.State.Strict as Strict -import qualified Control.Monad.Trans.RWS.Strict as Strict -import qualified Control.Monad.Trans.Writer.Lazy as Lazy -import qualified Control.Monad.Trans.State.Lazy as Lazy -import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import Data.Monoid -import Text.Trifecta.Language.Prim -import Text.Trifecta.Parser.Class - -class MonadParser m => MonadLanguage m where - askLanguage :: m (LanguageDef m) - -asksLanguage :: MonadLanguage m => (LanguageDef m -> r) -> m r -asksLanguage f = liftM f askLanguage - -instance MonadLanguage m => MonadLanguage (Strict.StateT s m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance MonadLanguage m => MonadLanguage (Lazy.StateT s m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance (Monoid w, MonadLanguage m) => MonadLanguage (Strict.WriterT w m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance (Monoid w, MonadLanguage m) => MonadLanguage (Lazy.WriterT w m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance MonadLanguage m => MonadLanguage (ReaderT s m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance MonadLanguage m => MonadLanguage (IdentityT m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance (Monoid w, MonadLanguage m) => MonadLanguage (Strict.RWST r w s m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance (Monoid w, MonadLanguage m) => MonadLanguage (Lazy.RWST r w s m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage diff --git a/src/Text/Trifecta/Language/Combinators.hs b/src/Text/Trifecta/Language/Combinators.hs deleted file mode 100644 --- a/src/Text/Trifecta/Language/Combinators.hs +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Language.Combinators --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Language.Combinators - ( identifier - , reserved - , reservedByteString - , op - , reservedOp - , reservedOpByteString - ) where - -import Data.ByteString -import Text.Trifecta.Language.Class -import Text.Trifecta.Language.Prim -import Text.Trifecta.Parser.Identifier - -identifier :: MonadLanguage m => m ByteString -identifier = asksLanguage languageIdentifierStyle >>= ident - -reserved :: MonadLanguage m => String -> m () -reserved i = asksLanguage languageIdentifierStyle >>= \style -> reserve style i - -reservedByteString :: MonadLanguage m => ByteString -> m () -reservedByteString i = asksLanguage languageIdentifierStyle >>= \style -> reserveByteString style i - -op :: MonadLanguage m => m ByteString -op = asksLanguage languageOperatorStyle >>= ident - -reservedOp :: MonadLanguage m => String -> m () -reservedOp i = asksLanguage languageOperatorStyle >>= \style -> reserve style i - -reservedOpByteString :: MonadLanguage m => ByteString -> m () -reservedOpByteString i = asksLanguage languageOperatorStyle >>= \style -> reserveByteString style i diff --git a/src/Text/Trifecta/Language/Monad.hs b/src/Text/Trifecta/Language/Monad.hs deleted file mode 100644 --- a/src/Text/Trifecta/Language/Monad.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Language.Monad --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Language.Monad - ( Language(..) - , runLanguage - ) where - -import Control.Applicative -import Control.Monad () -import Control.Monad.Trans.Class -import Control.Monad.Reader -import Control.Monad.Writer.Class -import Control.Monad.State.Class -import Control.Monad.Cont.Class -import Text.Trifecta.Diagnostic.Class -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Mark -import Text.Trifecta.Parser.Token.Style -import Text.Trifecta.Language.Prim -import Text.Trifecta.Language.Class - -newtype Language m a = Language { unlanguage :: ReaderT (LanguageDef (Language m)) m a } - deriving (Functor,Applicative,Alternative,Monad,MonadPlus,MonadCont) - -runLanguage :: Language m a -> LanguageDef (Language m) -> m a -runLanguage = runReaderT . unlanguage - -instance MonadParser m => MonadLanguage (Language m) where - askLanguage = Language ask - -instance MonadTrans Language where - lift = Language . lift - -instance MonadParser m => MonadParser (Language m) where - highlightInterval h s e = lift $ highlightInterval h s e - someSpace = asksLanguage languageCommentStyle >>= buildSomeSpaceParser (lift someSpace) - nesting (Language (ReaderT m)) = Language $ ReaderT $ nesting . m - semi = lift semi - try (Language m) = Language $ try m - labels (Language m) ss = Language $ labels m ss - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - skipping = lift . skipping - unexpected = lift . unexpected - position = lift position - line = lift line - lookAhead (Language m) = Language (lookAhead m) - slicedWith f (Language m) = Language $ ReaderT $ slicedWith f . runReaderT m - -instance MonadMark d m => MonadMark d (Language m) where - mark = lift mark - release = lift . release - -instance MonadDiagnostic e m => MonadDiagnostic e (Language m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance MonadState s m => MonadState s (Language m) where - get = Language $ lift get - put s = Language $ lift $ put s - -instance MonadWriter w m => MonadWriter w (Language m) where - tell = Language . lift . tell - pass = Language . pass . unlanguage - listen = Language . listen . unlanguage - -instance MonadReader e m => MonadReader e (Language m) where - ask = Language $ lift ask - local f (Language m) = Language $ ReaderT $ \e -> local f (runReaderT m e) diff --git a/src/Text/Trifecta/Language/Prim.hs b/src/Text/Trifecta/Language/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Language/Prim.hs +++ /dev/null @@ -1,28 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Language.Prim --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Language.Prim - ( LanguageDef(..) - , liftLanguageDef - ) where - -import Control.Monad.Trans.Class -import Text.Trifecta.Parser.Token.Style -import Text.Trifecta.Parser.Identifier - -data LanguageDef m = LanguageDef - { languageCommentStyle :: CommentStyle - , languageIdentifierStyle :: IdentifierStyle m - , languageOperatorStyle :: IdentifierStyle m - } - -liftLanguageDef :: (MonadTrans t, Monad m) => LanguageDef m -> LanguageDef (t m) -liftLanguageDef (LanguageDef c i o) = LanguageDef c (liftIdentifierStyle i) (liftIdentifierStyle o) diff --git a/src/Text/Trifecta/Language/Style.hs b/src/Text/Trifecta/Language/Style.hs deleted file mode 100644 --- a/src/Text/Trifecta/Language/Style.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Language.Style --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : provisional --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Language.Style - ( emptyLanguageDef - , haskellLanguageDef - , haskell98LanguageDef - ) where - -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Token.Style -import Text.Trifecta.Parser.Identifier.Style -import Text.Trifecta.Language.Prim - -emptyLanguageDef, haskellLanguageDef, haskell98LanguageDef :: MonadParser m => LanguageDef m -emptyLanguageDef = LanguageDef emptyCommentStyle emptyIdents emptyOps -haskellLanguageDef = LanguageDef haskellCommentStyle haskellIdents haskellOps -haskell98LanguageDef = LanguageDef haskellCommentStyle haskell98Idents haskell98Ops diff --git a/src/Text/Trifecta/Layout.hs b/src/Text/Trifecta/Layout.hs deleted file mode 100644 --- a/src/Text/Trifecta/Layout.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Layout --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Layout - ( Layout(..) - , LayoutMark(..) - , MonadLayout(..) - , LayoutState(..) - , runLayout - , defaultLayoutState - ) where - -import Text.Trifecta.Layout.Monad -import Text.Trifecta.Layout.Class -import Text.Trifecta.Layout.Prim diff --git a/src/Text/Trifecta/Layout/Class.hs b/src/Text/Trifecta/Layout/Class.hs deleted file mode 100644 --- a/src/Text/Trifecta/Layout/Class.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Layout.Class --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Layout.Class - ( MonadLayout(..) - ) where - -import Data.Monoid -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Identity -import qualified Control.Monad.Trans.State.Lazy as Lazy -import qualified Control.Monad.Trans.State.Strict as Strict -import qualified Control.Monad.Trans.Writer.Lazy as Lazy -import qualified Control.Monad.Trans.Writer.Strict as Strict -import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import qualified Control.Monad.Trans.RWS.Strict as Strict -import Text.Trifecta.Layout.Prim -import Text.Trifecta.Parser.Class - -class MonadParser m => MonadLayout m where - layout :: m LayoutToken - layoutState :: (LayoutState -> (a, LayoutState)) -> m a - -instance MonadLayout m => MonadLayout (Strict.StateT s m) where - layout = lift layout - layoutState = lift . layoutState - -instance MonadLayout m => MonadLayout (Lazy.StateT s m) where - layout = lift layout - layoutState = lift . layoutState - -instance MonadLayout m => MonadLayout (ReaderT e m) where - layout = lift layout - layoutState = lift . layoutState - -instance (Monoid w, MonadLayout m) => MonadLayout (Strict.WriterT w m) where - layout = lift layout - layoutState = lift . layoutState - -instance (Monoid w, MonadLayout m) => MonadLayout (Lazy.WriterT w m) where - layout = lift layout - layoutState = lift . layoutState - -instance (Monoid w, MonadLayout m) => MonadLayout (Strict.RWST r w s m) where - layout = lift layout - layoutState = lift . layoutState - -instance (Monoid w, MonadLayout m) => MonadLayout (Lazy.RWST r w s m) where - layout = lift layout - layoutState = lift . layoutState - -instance MonadLayout m => MonadLayout (IdentityT m) where - layout = lift layout - layoutState = lift . layoutState diff --git a/src/Text/Trifecta/Layout/Combinators.hs b/src/Text/Trifecta/Layout/Combinators.hs deleted file mode 100644 --- a/src/Text/Trifecta/Layout/Combinators.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Layout.Combinators --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Layout.Combinators - ( layoutEq - , getLayout - , setLayout - , modLayout - , disableLayout - , enableLayout - , laidout - ) where - -import Control.Applicative -import Control.Monad (guard) -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Token.Combinators -import qualified Text.Trifecta.Highlight.Prim as Highlight -import Text.Trifecta.Layout.Class -import Text.Trifecta.Layout.Prim -import Data.Functor.Identity - --- getLayout :: MonadLayout m => Lens LayoutState t -> m t -getLayout :: MonadLayout m => ((t -> Const t t') -> LayoutState -> Const t LayoutState) -> m t -getLayout l = layoutState $ \s -> (getConst (l Const s), s) - -setLayout :: MonadLayout m => ((t -> Identity t) -> LayoutState -> Identity LayoutState) -> t -> m () -setLayout l t = modLayout l (const t) - -modLayout :: MonadLayout m => ((t -> Identity t) -> LayoutState -> Identity LayoutState) -> (t -> t) -> m () -modLayout l f = layoutState $ \s -> ((), runIdentity $ l (Identity . f) s) - -disableLayout :: MonadLayout m => m a -> m a -disableLayout p = do - r <- rend - modLayout layoutStack (DisabledLayout r:) - result <- p - stk <- getLayout layoutStack - case stk of - DisabledLayout r':xs | delta r == delta r' -> result <$ setLayout layoutStack xs - _ -> unexpected "layout" - -enableLayout :: MonadLayout m => m a -> m a -enableLayout p = do - result <- highlight Highlight.Layout $ do - r <- rend - modLayout layoutStack (IndentedLayout r:) - p - result <$ layout "virtual right brace" - -laidout :: MonadLayout m => m a -> m a -laidout p = braces p <|> enableLayout p - -layoutEq :: MonadLayout m => LayoutToken -> m () -layoutEq s = try $ do - r <- layout - guard (s == r) - diff --git a/src/Text/Trifecta/Layout/Monad.hs b/src/Text/Trifecta/Layout/Monad.hs deleted file mode 100644 --- a/src/Text/Trifecta/Layout/Monad.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Layout.Monad --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Layout.Monad - ( Layout(..) - , runLayout - ) where - -import Control.Applicative -import Control.Category -import Control.Monad -import Control.Monad.State.Class -import Control.Monad.Trans.State.Strict (StateT(..)) -import Control.Monad.Writer.Class -import Control.Monad.Reader.Class -import Control.Monad.Cont.Class -import Control.Monad.Trans.Class -import Prelude hiding ((.), id) -import Text.Trifecta.Diagnostic.Class -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Mark -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Layout.Prim -import Text.Trifecta.Layout.Class -import Text.Trifecta.Layout.Combinators -import Text.Trifecta.Rope.Delta - --- | Adds Haskell-style "layout" to base parser -newtype Layout m a = Layout { unlayout :: StateT LayoutState m a } - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadTrans, MonadCont) - -runLayout :: Monad m => Layout m a -> LayoutState -> m (a, LayoutState) -runLayout = runStateT . unlayout - -instance MonadParser m => MonadParser (Layout m) where - satisfy p = try $ layoutEq Other *> lift (satisfy p) - satisfy8 p = try $ layoutEq Other *> lift (satisfy8 p) - line = lift line - unexpected = lift . unexpected - try = Layout . try . unlayout - labels m s = Layout $ labels (unlayout m) s - skipMany = Layout . skipMany . unlayout - highlightInterval h s e = lift $ highlightInterval h s e - someSpace = try $ (layoutEq WhiteSpace "") - nesting (Layout m) = disableLayout $ Layout (nesting m) - semi = getLayout layoutStack >>= \ stk -> case stk of - (DisabledLayout _:_) -> lift semi - _ -> try (';' <$ layoutEq VirtualSemi "virtual semi-colon") - <|> lift semi - skipping = lift . skipping - position = lift position - slicedWith f (Layout m) = Layout $ slicedWith f m - lookAhead (Layout m) = Layout $ lookAhead m - -instance MonadMark d m => MonadMark (LayoutMark d) (Layout m) where - mark = LayoutMark <$> getLayout id <*> lift mark - release (LayoutMark s m) = lift (release m) *> setLayout id s - -instance MonadDiagnostic e m => MonadDiagnostic e (Layout m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance MonadParser m => MonadLayout (Layout m) where - layout = buildLayoutParser (lift whiteSpace) - layoutState f = Layout . StateT $ return . f - -buildLayoutParser :: MonadLayout m => m () -> m LayoutToken -buildLayoutParser realWhiteSpace = do - bol <- getLayout layoutBol - m <- position - realWhiteSpace - r <- position - if near m r && not bol - then onside m r - else getLayout layoutStack >>= \stk -> case compare (column r) (depth stk) of - GT -> onside m r - EQ -> return VirtualSemi - LT -> case stk of - (IndentedLayout _:xs) -> VirtualRightBrace <$ setLayout layoutStack xs <* setLayout layoutBol True - _ -> unexpected "layout context" - where - onside m r - | r /= m = pure WhiteSpace - | otherwise = setLayout layoutBol False *> option Other (VirtualRightBrace <$ eof <* trailing) - trailing = getLayout layoutStack >>= \ stk -> case stk of - (IndentedLayout _:xs) -> setLayout layoutStack xs - _ -> empty - depth [] = 0 - depth (IndentedLayout r:_) = column r - depth (DisabledLayout _:_) = -1 - -instance MonadState s m => MonadState s (Layout m) where - get = Layout $ lift get - put = Layout . lift . put - -instance MonadReader e m => MonadReader e (Layout m) where - ask = Layout $ lift ask - local f (Layout m) = Layout $ local f m - -instance MonadWriter w m => MonadWriter w (Layout m) where - tell = Layout . lift . tell - listen (Layout m) = Layout $ listen m - pass (Layout m) = Layout $ pass m diff --git a/src/Text/Trifecta/Layout/Prim.hs b/src/Text/Trifecta/Layout/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Layout/Prim.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Layout.Prim --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Layout.Prim - ( LayoutToken(..) - , LayoutState(..) - , LayoutContext(..) - , LayoutMark(..) - , defaultLayoutState - , layoutBol - , layoutStack - ) where - -import Data.Functor -import Data.Foldable -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Data.Traversable -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Diagnostic.Rendering.Prim - -data LayoutToken - = VirtualSemi - | VirtualRightBrace - | WhiteSpace - | Other - deriving (Eq,Ord,Show,Read) - -data LayoutContext - = IndentedLayout Rendering - | DisabledLayout Rendering - -instance HasDelta LayoutContext where - delta (IndentedLayout r) = delta r - delta (DisabledLayout r) = delta r - -instance HasBytes LayoutContext where - bytes = bytes . delta - -data LayoutState = LayoutState - { _layoutBol :: Bool - , _layoutStack :: [LayoutContext] - } - -defaultLayoutState :: LayoutState -defaultLayoutState = LayoutState False [] - -layoutBol :: Functor f => (Bool -> f Bool) -> LayoutState -> f LayoutState -layoutBol f (LayoutState b s) = (`LayoutState` s) <$> f b -{-# INLINE layoutBol #-} - -layoutStack :: Functor f => ([LayoutContext] -> f [LayoutContext]) -> LayoutState -> f LayoutState -layoutStack f (LayoutState b s) = LayoutState b <$> f s -{-# INLINE layoutStack #-} - -data LayoutMark d = LayoutMark LayoutState d - -instance Functor LayoutMark where - fmap f (LayoutMark s a) = LayoutMark s (f a) - -instance Foldable LayoutMark where - foldMap f (LayoutMark _ a) = f a - -instance Traversable LayoutMark where - traverse f (LayoutMark s a) = LayoutMark s <$> f a - -instance Foldable1 LayoutMark where - foldMap1 f (LayoutMark _ a) = f a - -instance Traversable1 LayoutMark where - traverse1 f (LayoutMark s a) = LayoutMark s <$> f a - -instance HasDelta d => HasDelta (LayoutMark d) where - delta (LayoutMark _ d) = delta d - -instance HasBytes d => HasBytes (LayoutMark d) where - bytes (LayoutMark _ d) = bytes d diff --git a/src/Text/Trifecta/Literate.hs b/src/Text/Trifecta/Literate.hs deleted file mode 100644 --- a/src/Text/Trifecta/Literate.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Literate --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Literate - ( Literate(..) - , LiterateMark(..) - , MonadLiterate(..) - , LiterateState(..) - , runLiterate - , defaultLiterateState - ) where - -import Text.Trifecta.Literate.Monad -import Text.Trifecta.Literate.Class -import Text.Trifecta.Literate.Prim diff --git a/src/Text/Trifecta/Literate/Class.hs b/src/Text/Trifecta/Literate/Class.hs deleted file mode 100644 --- a/src/Text/Trifecta/Literate/Class.hs +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Literate.Class --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Literate.Class - ( MonadLiterate(..) - ) where - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Identity -import qualified Control.Monad.Trans.State.Strict as Strict -import qualified Control.Monad.Trans.State.Lazy as Lazy -import qualified Control.Monad.Trans.Writer.Strict as Strict -import qualified Control.Monad.Trans.Writer.Lazy as Lazy -import qualified Control.Monad.Trans.RWS.Strict as Strict -import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import Data.Monoid -import Text.Trifecta.Parser.Class -import Text.Trifecta.Literate.Prim - -class MonadParser m => MonadLiterate m where - literateState :: (LiterateState -> (a, LiterateState)) -> m a - -instance MonadLiterate m => MonadLiterate (Strict.StateT s m) where - literateState = lift . literateState - -instance MonadLiterate m => MonadLiterate (Lazy.StateT s m) where - literateState = lift . literateState - -instance (Monoid w, MonadLiterate m) => MonadLiterate (Strict.WriterT w m) where - literateState = lift . literateState - -instance (Monoid w, MonadLiterate m) => MonadLiterate (Lazy.WriterT w m) where - literateState = lift . literateState - -instance (Monoid w, MonadLiterate m) => MonadLiterate (Strict.RWST r w s m) where - literateState = lift . literateState - -instance (Monoid w, MonadLiterate m) => MonadLiterate (Lazy.RWST r w s m) where - literateState = lift . literateState - -instance MonadLiterate m => MonadLiterate (IdentityT m) where - literateState = lift . literateState - -instance MonadLiterate m => MonadLiterate (ReaderT e m) where - literateState = lift . literateState diff --git a/src/Text/Trifecta/Literate/Combinators.hs b/src/Text/Trifecta/Literate/Combinators.hs deleted file mode 100644 --- a/src/Text/Trifecta/Literate/Combinators.hs +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Literate.Combinators --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Literate.Combinators - ( someLiterateSpace - , getLiterate - , putLiterate - ) where - -import Data.Char (isSpace) -import Control.Applicative -import Control.Monad -import Text.Trifecta.Rope.Delta -import qualified Text.Trifecta.Highlight.Prim as Highlight -import Text.Trifecta.Literate.Prim -import Text.Trifecta.Literate.Class -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Combinators - -getLiterate :: MonadLiterate m => m LiterateState -getLiterate = literateState $ \s -> (s, s) - -putLiterate :: MonadLiterate m => LiterateState -> m () -putLiterate s = literateState $ \_ -> ((), s) - -skipLine :: MonadParser m => m () -skipLine = do - r <- restOfLine - skipping (delta r) - -someLiterateSpace :: MonadLiterate m => m () -someLiterateSpace = do - s <- getLiterate - case s of - IlliterateStart -> skipSome $ satisfy isSpace - LiterateStart -> position >>= \m -> track m <|> begin m <|> blank m <|> other m - LiterateCode -> do - skipSome $ satisfy isSpace - option () $ position >>= \m -> when (column m == 0) $ do - highlight Highlight.LiterateSyntax (string "\\end{code}") *> skipLine - begin m <|> blank m <|> other m - LiterateTrack -> skipSome horizontalSpace >> skipOptional bird - <|> bird - where - bird = newline *> position >>= \m -> track m <|> blank m - --- parse space excluding newlines -horizontalSpace :: MonadLiterate m => m Char -horizontalSpace = satisfy $ \s -> s /= '\n' && isSpace s - -track, begin, blank, other :: MonadLiterate m => Delta -> m () -track s = do - e <- position - try $ highlight Highlight.LiterateSyntax (char '>') - *> highlightInterval Highlight.LiterateComment s e - *> skipSome horizontalSpace - tracks <|> putLiterate LiterateTrack where - tracks = do - s' <- newline *> position - track s' <|> blank s' - -begin s = do - try $ highlight Highlight.LiterateSyntax (string "\begin{code}") *> skipLine - position >>= highlightInterval Highlight.LiterateComment s - putLiterate LiterateCode - whiteSpace - -other s = do - notChar '>' *> skipLine - begin s <|> blank s <|> other s - -blank s = do - k <- try $ do - skipMany horizontalSpace - True <$ newline <|> False <$ eof - when k $ track s <|> begin s <|> blank s <|> other s diff --git a/src/Text/Trifecta/Literate/Monad.hs b/src/Text/Trifecta/Literate/Monad.hs deleted file mode 100644 --- a/src/Text/Trifecta/Literate/Monad.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Literate.Monad --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Literate.Monad - ( Literate(..) - , runLiterate - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.State.Strict (StateT(..)) -import Control.Monad.Trans.Class -import Control.Monad.State.Class -import Control.Monad.Cont.Class -import Control.Monad.Reader.Class -import Control.Monad.Writer.Class -import Data.Semigroup -import Text.Trifecta.Diagnostic.Class -import Text.Trifecta.Language.Prim -import Text.Trifecta.Language.Class -import Text.Trifecta.Literate.Prim -import Text.Trifecta.Literate.Class -import Text.Trifecta.Literate.Combinators -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Parser.Mark -import Text.Trifecta.Rope.Delta - -newtype Literate m a = Literate { unliterate :: StateT LiterateState m a } - deriving (Functor,Applicative,Alternative,Monad,MonadPlus,MonadTrans,MonadCont) - -runLiterate :: Monad m => Literate m a -> LiterateState -> m (a, LiterateState) -runLiterate = runStateT . unliterate - -instance MonadParser m => MonadParser (Literate m) where - someSpace = someLiterateSpace - highlightInterval h s e = lift $ highlightInterval h s e - try (Literate m) = Literate $ try m - nesting (Literate m) = Literate $ nesting m - skipMany (Literate m) = Literate $ skipMany m - slicedWith f (Literate m) = Literate $ slicedWith f m - labels (Literate m) p = Literate $ labels m p - semi = lift semi - line = lift line - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - unexpected = lift . unexpected - position = lift position - skipping d - | near (Columns 0 0) d = lift $ skipping d -- we don't change literate states within a line - | otherwise = do - s <- position - let e = s <> d - () <$ (manyTill (someSpace <|> () <$ anyChar) $ position >>= \p -> guard (e <= p)) - lookAhead (Literate (StateT p)) = Literate $ StateT $ \s -> do - as' <- lookAhead $ p s - return (fst as', s) - -instance MonadParser m => MonadLiterate (Literate m) where - literateState f = Literate $ StateT $ return . f - -instance MonadMark d m => MonadMark (LiterateMark d) (Literate m) where - mark = LiterateMark <$> getLiterate <*> lift mark - release (LiterateMark s d) = lift (release d) *> putLiterate s - -instance MonadLanguage m => MonadLanguage (Literate m) where - askLanguage = liftM liftLanguageDef $ lift askLanguage - -instance MonadDiagnostic e m => MonadDiagnostic e (Literate m) where - throwDiagnostic = lift . throwDiagnostic - logDiagnostic = lift . logDiagnostic - -instance MonadState s m => MonadState s (Literate m) where - get = lift get - put = lift . put - -instance MonadReader e m => MonadReader e (Literate m) where - ask = lift ask - local f (Literate m) = Literate $ local f m - -instance MonadWriter w m => MonadWriter w (Literate m) where - tell = lift . tell - listen (Literate m) = Literate $ listen m - pass (Literate m) = Literate $ pass m diff --git a/src/Text/Trifecta/Literate/Prim.hs b/src/Text/Trifecta/Literate/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Literate/Prim.hs +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Literate.Prim --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Literate.Prim - ( LiterateState(..) - , defaultLiterateState - , LiterateMark(..) - ) where - -import Data.Functor -import Data.Foldable -import Data.Traversable -import Data.Semigroup -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Delta - -data LiterateState - = LiterateStart -- ^ Parsing literate syntax - | IlliterateStart -- ^ Disable literate parsing - | LiterateCode -- ^ In the midst of a @\begin{code} ... \end{code}@ block - | LiterateTrack -- ^ In the midst of a @> ...@ block - -defaultLiterateState :: LiterateState -defaultLiterateState = LiterateStart - -data LiterateMark d = LiterateMark LiterateState d - -instance Functor LiterateMark where - fmap f (LiterateMark s a) = LiterateMark s (f a) - -instance Foldable LiterateMark where - foldMap f (LiterateMark _ a) = f a - -instance Traversable LiterateMark where - traverse f (LiterateMark s a) = LiterateMark s <$> f a - -instance Foldable1 LiterateMark where - foldMap1 f (LiterateMark _ a) = f a - -instance Traversable1 LiterateMark where - traverse1 f (LiterateMark s a) = LiterateMark s <$> f a - -instance HasDelta d => HasDelta (LiterateMark d) where - delta (LiterateMark _ d) = delta d - -instance HasBytes d => HasBytes (LiterateMark d) where - bytes (LiterateMark _ d) = bytes d - -instance Semigroup d => Semigroup (LiterateMark d) where - LiterateMark _ d <> LiterateMark s e = LiterateMark s (d <> e) 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,47 +1,308 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Parser --- Copyright : (C) 2011 Edward Kmett, --- License : BSD-style (see the file LICENSE) +-- Copyright : (c) Edward Kmett 2011-2013 +-- License : BSD3 -- --- Maintainer : Edward Kmett +-- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- module Text.Trifecta.Parser - ( module Text.Trifecta.Parser.ByteString - , module Text.Trifecta.Parser.Char - , module Text.Trifecta.Parser.Class - , module Text.Trifecta.Parser.Combinators - , module Text.Trifecta.Parser.Identifier - , module Text.Trifecta.Parser.Prim - , module Text.Trifecta.Parser.Result - , module Text.Trifecta.Parser.Rich - , module Text.Trifecta.Parser.Token - -- * Expressive Diagnostics - -- ** Text.Trifecta.Diagnostic.Rendering.Caret - , caret - , careted - -- ** Text.Trifecta.Diagnostic.Rendering.Span - , span - , spanned - -- ** Text.Trifecta.Diagnostic.Rendering.Fixit - , fixit - + ( Parser(..) + , manyAccum + -- * Feeding a parser more more input + , Step(..) + , feed + , starve + , stepParser + , stepResult + , stepIt + -- * Parsing + , parseFromFile + , parseFromFileEx + , parseString + , parseByteString + , parseTest ) where -import Text.Trifecta.Diagnostic.Rendering.Caret (caret, careted) -import Text.Trifecta.Diagnostic.Rendering.Span (span, spanned) -import Text.Trifecta.Diagnostic.Rendering.Fixit (fixit) -import Text.Trifecta.Parser.ByteString -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Parser.Identifier -import Text.Trifecta.Parser.Prim -import Text.Trifecta.Parser.Result -import Text.Trifecta.Parser.Rich -import Text.Trifecta.Parser.Token +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 -import Prelude () +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 + (Doc -> 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 (Parser a) where + (<>) = (<|>) + {-# INLINE (<>) #-} + +instance Monoid (Parser a) where + mappend = (<|>) + {-# INLINE mappend #-} + mempty = empty + {-# 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 -> ce (explain (renderingCaret d' bs') e { _expected = _expected e <> es })) + co ce d' bs') ce d bs + {-# INLINE (>>=) #-} + (>>) = (*>) + {-# INLINE (>>) #-} + fail s = Parser $ \ _ ee _ _ _ _ -> ee (failing 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 $ explain (renderingCaret d' bs') (e <> failing "'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 $ failing $ "unexpected " ++ s + {-# INLINE unexpected #-} + eof = notFollowedBy anyChar "end of input" + {-# INLINE eof #-} + +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 (failing "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 Doc + | 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 Doc + +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 doc = Pure (CE doc) + go r (Pure (EO a _)) = StepDone r a + go r (Pure (EE e)) = StepFail r $ explain (renderingCaret d0 bs0) 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 $ explain (renderingCaret d0 bs0) 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 $ 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 $ xs <> linebreak -- TODO: retrieve columns + Success a -> liftIO (print a) diff --git a/src/Text/Trifecta/Parser/ByteString.hs b/src/Text/Trifecta/Parser/ByteString.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/ByteString.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, Rank2Types #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.ByteString --- Copyright : (c) Edward Kmett 2011 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable (mptcs, fundeps) --- --- Loading a file as a strict bytestring in one step. --- ------------------------------------------------------------------------------ - - -module Text.Trifecta.Parser.ByteString - ( parseFromFile - , parseFromFileEx - , parseByteString - , parseTest - ) where - -import Control.Applicative -import Control.Monad (unless) -import Data.Semigroup -import Data.Foldable -import qualified Data.ByteString as B -import System.Console.Terminfo.PrettyPrint -import Text.Trifecta.Parser.Mark -import Text.Trifecta.Parser.Prim -import Text.Trifecta.Parser.Step -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Parser.Result -import Data.Sequence as Seq -import qualified Data.ByteString.UTF8 as UTF8 - - --- | @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 :: Show a => (forall r. Parser r String a) -> String -> IO (Maybe a) -parseFromFile p fn = do - result <- parseFromFileEx p fn - case result of - Success xs a -> Just a <$ unless (Seq.null xs) (displayLn (toList xs)) - Failure xs -> Nothing <$ unless (Seq.null xs) (displayLn (toList xs)) - --- | @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 -> unless (Seq.null xs) $ displayLn xs --- > Success xs a -> --- > unless (Seq.null xs) $ displayLn xs --- > print $ sum a --- > - -parseFromFileEx :: Show a => (forall r. Parser r String a) -> String -> IO (Result TermDoc a) -parseFromFileEx p fn = parseByteString p (Directed (UTF8.fromString fn) 0 0 0 0) <$> B.readFile fn - --- | @parseByteString p delta i@ runs a parser @p@ on @i@. - -parseByteString :: Show a => (forall r. Parser r String a) -> Delta -> UTF8.ByteString -> Result TermDoc a -parseByteString p d inp = starve - $ feed inp - $ stepParser (fmap prettyTerm) - (why prettyTerm) - (release d *> p) - mempty - True - mempty - mempty - - -parseTest :: Show a => (forall r. Parser r String a) -> String -> IO () -parseTest p s = case parseByteString p mempty (UTF8.fromString s) of - Failure xs -> displayLn $ toList xs - Success xs a -> do - unless (Seq.null xs) $ displayLn $ toList xs - print a - diff --git a/src/Text/Trifecta/Parser/Char.hs b/src/Text/Trifecta/Parser/Char.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Char.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, FlexibleContexts, PatternGuards #-} -{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Char --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Parser.Char - ( oneOf -- :: MonadParser m => [Char] -> m Char - , noneOf -- :: MonadParser m => [Char] -> m Char - , oneOfSet -- :: MonadParser m => CharSet -> m Char - , noneOfSet -- :: MonadParser m => CharSet -> m Char - , spaces -- :: MonadParser m => m () - , space -- :: MonadParser m => m Char - , newline -- :: MonadParser m => m Char - , tab -- :: MonadParser m => m Char - , upper -- :: MonadParser m => m Char - , lower -- :: MonadParser m => m Char - , alphaNum -- :: MonadParser m => m Char - , letter -- :: MonadParser m => m Char - , digit -- :: MonadParser m => m Char - , hexDigit -- :: MonadParser m => m Char - , octDigit -- :: MonadParser m => m Char - , char -- :: MonadParser m => Char -> m Char - , notChar -- :: MonadParser m => Char -> m Char - , anyChar -- :: MonadParser m => m Char - , string -- :: MonadParser m => String -> m String - , byteString -- :: MonadParser m => ByteString -> m ByteString - ) where - -import Data.Char -import Control.Applicative -import Control.Monad (guard) -import Text.Trifecta.Parser.Class -import Text.Trifecta.Rope.Delta -import qualified Data.IntSet as IntSet -import Data.CharSet (CharSet(..)) -import qualified Data.CharSet as CharSet -import qualified Data.CharSet.ByteSet as ByteSet -import qualified Data.ByteString as Strict -import Data.ByteString.Internal (w2c,c2w) -import Data.ByteString.UTF8 as UTF8 - --- | @oneOf cs@ succeeds if the current character is in the supplied --- list of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" -oneOf :: MonadParser m => [Char] -> m Char -oneOf xs = oneOfSet (CharSet.fromList xs) -{-# INLINE oneOf #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" -noneOf :: MonadParser m => [Char] -> m Char -noneOf xs = noneOfSet (CharSet.fromList xs) -{-# INLINE noneOf #-} - --- | @oneOfSet cs@ succeeds if the current character is in the supplied --- set of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" -oneOfSet :: MonadParser m => CharSet -> m Char -oneOfSet (CharSet True bs is) - | (_,r) <- IntSet.split 0x80 is, IntSet.null r = w2c <$> satisfy8 (\w -> ByteSet.member w bs) - | otherwise = satisfy (\c -> IntSet.member (fromEnum c) is) -oneOfSet (CharSet False bs is) - | (_,r) <- IntSet.split 0x80 is, not (IntSet.null r) = satisfy (\c -> not (IntSet.member (fromEnum c) is)) - | otherwise = satisfyAscii (\c -> not (ByteSet.member (c2w c) bs)) -{-# INLINE oneOfSet #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" -noneOfSet :: MonadParser m => CharSet -> m Char -noneOfSet s = oneOfSet (CharSet.complement s) -{-# INLINE noneOfSet #-} - --- | Skips /zero/ or more white space characters. See also 'skipMany' and --- 'whiteSpace'. -spaces :: MonadParser m => m () -spaces = skipMany space "white space" - --- | Parses a white space character (any character which satisfies 'isSpace') --- Returns the parsed character. -space :: MonadParser m => m Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Parses a newline character (\'\\n\'). Returns a newline character. -newline :: MonadParser m => m Char -newline = char '\n' "new-line" -{-# INLINE newline #-} - --- | Parses a tab character (\'\\t\'). Returns a tab character. -tab :: MonadParser m => m Char -tab = char '\t' "tab" -{-# INLINE tab #-} - --- | Parses an upper case letter (a character between \'A\' and \'Z\'). --- Returns the parsed character. -upper :: MonadParser m => m Char -upper = satisfy isUpper "uppercase letter" -{-# INLINE upper #-} - --- | Parses a lower case character (a character between \'a\' and \'z\'). --- Returns the parsed character. -lower :: MonadParser m => m Char -lower = satisfy isLower "lowercase letter" -{-# INLINE lower #-} - --- | Parses a letter or digit (a character between \'0\' and \'9\'). --- Returns the parsed character. - -alphaNum :: MonadParser m => m Char -alphaNum = satisfy isAlphaNum "letter or digit" -{-# INLINE alphaNum #-} - --- | Parses a letter (an upper case or lower case character). Returns the --- parsed character. - -letter :: MonadParser m => m Char -letter = satisfy isAlpha "letter" -{-# INLINE letter #-} - --- | Parses a digit. Returns the parsed character. - -digit :: MonadParser m => m Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - --- | Parses a hexadecimal digit (a digit or a letter between \'a\' and --- \'f\' or \'A\' and \'F\'). Returns the parsed character. -hexDigit :: MonadParser m => m Char -hexDigit = satisfy isHexDigit "hexadecimal digit" -{-# INLINE hexDigit #-} - --- | Parses an octal digit (a character between \'0\' and \'7\'). Returns --- the parsed character. -octDigit :: MonadParser m => m Char -octDigit = satisfy isOctDigit "octal digit" -{-# INLINE octDigit #-} - --- | @char c@ parses a single character @c@. Returns the parsed --- character (i.e. @c@). --- --- > semiColon = char ';' -char :: MonadParser m => Char -> m Char -char c - | c <= w2c 0x7f, w <- c2w c = w2c <$> satisfy8 (w ==) show [c] - | otherwise = satisfy (c ==) show [c] -{-# INLINE char #-} - --- | @notChar c@ parses any single character other than @c@. Returns the parsed --- character. --- --- > semiColon = char ';' -notChar :: MonadParser m => Char -> m Char -notChar c - | fromEnum c <= 0x7f = satisfyAscii (c /=) - | otherwise = satisfy (c /=) -{-# INLINE notChar #-} - --- | This parser succeeds for any character. Returns the parsed character. -anyChar :: MonadParser m => m Char -anyChar = satisfy (const True) - --- | @string s@ parses a sequence of characters given by @s@. Returns --- the parsed string (i.e. @s@). --- --- > divOrMod = string "div" --- > <|> string "mod" -string :: MonadParser m => String -> m String -string s = s <$ byteString (UTF8.fromString s) show s - --- | @byteString s@ parses a sequence of bytes given by @s@. Returns --- the parsed byteString (i.e. @s@). --- --- > divOrMod = string "div" --- > <|> string "mod" -byteString :: MonadParser m => Strict.ByteString -> m Strict.ByteString -byteString bs = do - r <- restOfLine - let lr = Strict.length r - lbs = Strict.length bs - guard $ lr > 0 - case compare lbs lr of - LT | bs `Strict.isPrefixOf` r -> bs <$ skipping (delta bs) - EQ | bs == r -> bs <$ skipping (delta bs) - GT | r `Strict.isPrefixOf` bs -> bs <$ skipping (delta r) *> byteString (Strict.drop lr bs) - _ -> empty - show (UTF8.toString bs) diff --git a/src/Text/Trifecta/Parser/Char8.hs b/src/Text/Trifecta/Parser/Char8.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Char8.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, FlexibleContexts, PatternGuards #-} -{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Char8 --- Copyright : (c) Edward Kmett 2011 --- License : BSD-style (see the LICENSE file) --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable (mptcs, fundeps) --- --- This provides a thin backwards compatibility layer for folks who --- want to write parsers for languages where characters are bytes --- and don't need to deal with unicode issues. Diagnostics will still --- report the correct column number in the absence of high ascii characters --- but if you have those in your source file, you probably aren't going to --- want to draw those to the screen anyways. --- ------------------------------------------------------------------------------ - - -module Text.Trifecta.Parser.Char8 - ( satisfy -- :: MonadParser m => (Char -> Bool) -> m Char - , oneOf -- :: MonadParser m => [Char] -> m Char - , noneOf -- :: MonadParser m => [Char] -> m Char - , oneOfSet -- :: MonadParser m => ByteSet -> m Char - , noneOfSet -- :: MonadParser m => ByteSet -> m Char - , spaces -- :: MonadParser m => m () - , space -- :: MonadParser m => m Char - , newline -- :: MonadParser m => m Char - , tab -- :: MonadParser m => m Char - , upper -- :: MonadParser m => m Char - , lower -- :: MonadParser m => m Char - , alphaNum -- :: MonadParser m => m Char - , letter -- :: MonadParser m => m Char - , digit -- :: MonadParser m => m Char - , hexDigit -- :: MonadParser m => m Char - , octDigit -- :: MonadParser m => m Char - , char -- :: MonadParser m => Char -> m Char - , notChar -- :: MonadParser m => Char -> m Char - , anyChar -- :: MonadParser m => m Char - , string -- :: MonadParser m => String -> m String - , byteString -- :: MonadParser m => ByteString -> m ByteString - ) where - -import Data.Char -import Control.Applicative -import Control.Monad (guard) -import Text.Trifecta.Parser.Class hiding (satisfy) -import Text.Trifecta.Rope.Delta -import Data.CharSet.ByteSet (ByteSet(..)) -import qualified Data.CharSet.ByteSet as ByteSet -import qualified Data.ByteString as Strict -import Data.ByteString.Internal (w2c,c2w) -import qualified Data.ByteString.Char8 as Char8 - --- | Using this instead of 'Text.Trifecta.Parser.Class.satisfy' --- you too can time travel back to when men were men and characters --- fit into 8 bits like God intended. It might also be useful --- when writing lots of fiddly protocol code, where the UTF8 decoding --- is probably a very bad idea. -satisfy :: MonadParser m => (Char -> Bool) -> m Char -satisfy f = w2c <$> satisfy8 (\w -> f (w2c w)) - --- | @oneOf cs@ succeeds if the current character is in the supplied --- list of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" -oneOf :: MonadParser m => [Char] -> m Char -oneOf xs = oneOfSet (ByteSet.fromList (map c2w xs)) -{-# INLINE oneOf #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" -noneOf :: MonadParser m => [Char] -> m Char -noneOf xs = noneOfSet (ByteSet.fromList (map c2w xs)) -{-# INLINE noneOf #-} - --- | @oneOfSet cs@ succeeds if the current character is in the supplied --- set of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" -oneOfSet :: MonadParser m => ByteSet -> m Char -oneOfSet bs = w2c <$> satisfy8 (\w -> ByteSet.member w bs) -{-# INLINE oneOfSet #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" -noneOfSet :: MonadParser m => ByteSet -> m Char -noneOfSet s = w2c <$> satisfy8 (\w -> not (ByteSet.member w s)) -{-# INLINE noneOfSet #-} - --- | Skips /zero/ or more white space characters. See also 'skipMany' and --- 'whiteSpace'. -spaces :: MonadParser m => m () -spaces = skipMany space "white space" - --- | Parses a white space character (any character which satisfies 'isSpace') --- Returns the parsed character. -space :: MonadParser m => m Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Parses a newline character (\'\\n\'). Returns a newline character. -newline :: MonadParser m => m Char -newline = char '\n' "new-line" -{-# INLINE newline #-} - --- | Parses a tab character (\'\\t\'). Returns a tab character. -tab :: MonadParser m => m Char -tab = char '\t' "tab" -{-# INLINE tab #-} - --- | Parses an upper case letter (a character between \'A\' and \'Z\'). --- Returns the parsed character. -upper :: MonadParser m => m Char -upper = satisfy isUpper "uppercase letter" -{-# INLINE upper #-} - --- | Parses a lower case character (a character between \'a\' and \'z\'). --- Returns the parsed character. -lower :: MonadParser m => m Char -lower = satisfy isLower "lowercase letter" -{-# INLINE lower #-} - --- | Parses a letter or digit (a character between \'0\' and \'9\'). --- Returns the parsed character. - -alphaNum :: MonadParser m => m Char -alphaNum = satisfy isAlphaNum "letter or digit" -{-# INLINE alphaNum #-} - --- | Parses a letter (an upper case or lower case character). Returns the --- parsed character. - -letter :: MonadParser m => m Char -letter = satisfy isAlpha "letter" -{-# INLINE letter #-} - --- | Parses a digit. Returns the parsed character. - -digit :: MonadParser m => m Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - --- | Parses a hexadecimal digit (a digit or a letter between \'a\' and --- \'f\' or \'A\' and \'F\'). Returns the parsed character. -hexDigit :: MonadParser m => m Char -hexDigit = satisfy isHexDigit "hexadecimal digit" -{-# INLINE hexDigit #-} - --- | Parses an octal digit (a character between \'0\' and \'7\'). Returns --- the parsed character. -octDigit :: MonadParser m => m Char -octDigit = satisfy isOctDigit "octal digit" -{-# INLINE octDigit #-} - --- | @char c@ parses a single character @c@. Returns the parsed --- character (i.e. @c@). --- --- > semiColon = char ';' -char :: MonadParser m => Char -> m Char -char c = satisfy (c ==) show [c] -{-# INLINE char #-} - --- | @char c@ parses a single character @c@. Returns the parsed --- character (i.e. @c@). --- --- > semiColon = char ';' -notChar :: MonadParser m => Char -> m Char -notChar c = satisfy (c /=) -{-# INLINE notChar #-} - --- | This parser succeeds for any character. Returns the parsed character. -anyChar :: MonadParser m => m Char -anyChar = satisfy (const True) - --- | @string s@ parses a sequence of characters given by @s@. Returns --- the parsed string (i.e. @s@). --- --- > divOrMod = string "div" --- > <|> string "mod" -string :: MonadParser m => String -> m String -string s = s <$ byteString (Char8.pack s) show s - --- | @byteString s@ parses a sequence of bytes given by @s@. Returns --- the parsed byteString (i.e. @s@). --- --- > divOrMod = string "div" --- > <|> string "mod" -byteString :: MonadParser m => Strict.ByteString -> m Strict.ByteString -byteString bs = do - r <- restOfLine - let lr = Strict.length r - lbs = Strict.length bs - guard $ lr > 0 - case compare lbs lr of - LT | bs `Strict.isPrefixOf` r -> bs <$ skipping (delta bs) - | otherwise -> empty - EQ | bs == r -> bs <$ skipping (delta bs) - | otherwise -> empty - GT | r `Strict.isPrefixOf` bs -> bs <$ skipping (delta r) *> byteString (Strict.drop lr bs) - | otherwise -> empty - show (Char8.unpack bs) diff --git a/src/Text/Trifecta/Parser/Class.hs b/src/Text/Trifecta/Parser/Class.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Class.hs +++ /dev/null @@ -1,271 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Class --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Class - ( MonadParser(..) - , satisfyAscii - , restOfLine - , () - , sliced - , rend - , whiteSpace - , highlight - ) where - -import Control.Applicative -import Control.Monad (MonadPlus(..)) -import Control.Monad.Trans.Class -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 Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Identity -import Data.Word -import Data.ByteString as Strict -import Data.Char (isSpace) -import Data.ByteString.Internal (w2c) -import Data.Semigroup -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Highlight.Prim -import Text.Trifecta.Diagnostic.Rendering.Prim - -infix 0 - -class (Alternative m, MonadPlus m) => MonadParser m where - -- | Take a parser that may consume input, and on failure, go back to where we started and fail as if we didn't consume input. - try :: m a -> m a - - -- Used to implement (), runs the parser then sets the 'expected' tokens to the list supplied - labels :: m a -> [String] -> m a - - -- | A version of many that discards its input. Specialized because it can often be implemented more cheaply. - skipMany :: m a -> m () - skipMany p = () <$ many p - - -- | Parse a single character of the input, with UTF-8 decoding - satisfy :: (Char -> Bool) -> m Char - - -- | Parse a single byte of the input, without UTF-8 decoding - satisfy8 :: (Word8 -> Bool) -> m Word8 - - -- | Usually, someSpace consists of /one/ or more occurrences of a 'space'. - -- Some parsers may choose to recognize line comments or block (multi line) - -- comments as white space as well. - someSpace :: m () - someSpace = space *> skipMany space - where space = satisfy isSpace - - -- | Called when we enter a nested pair of symbols. - -- Overloadable to disable layout or highlight nested contexts. - nesting :: m a -> m a - nesting = id - - -- | Lexeme parser |semi| parses the character \';\' and skips any - -- trailing white space. Returns the character \';\'. - semi :: m Char - semi = (satisfyAscii (';'==) ";") <* (someSpace <|> pure ()) - - -- | Used to emit an error on an unexpected token - unexpected :: String -> m a - - -- | Retrieve the contents of the current line (from the beginning of the line) - line :: m ByteString - - skipping :: Delta -> m () - - -- | @highlightInterval@ is called internally in the token parsers. - -- It delimits ranges of the input recognized by certain parsers that - -- are useful for syntax highlighting. An interested monad could - -- choose to listen to these events and construct an interval tree - -- for later pretty printing purposes. - highlightInterval :: Highlight -> Delta -> Delta -> m () - highlightInterval _ _ _ = pure () - - 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 - - -- | @lookAhead p@ parses @p@ without consuming any input. - lookAhead :: m a -> m a - - -instance MonadParser m => MonadParser (Lazy.StateT s m) where - try (Lazy.StateT m) = Lazy.StateT $ try . m - labels (Lazy.StateT m) ss = Lazy.StateT $ \s -> labels (m s) ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (Lazy.StateT m) = Lazy.StateT $ nesting . m - skipping = lift . skipping - position = lift position - slicedWith f (Lazy.StateT m) = Lazy.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s - lookAhead (Lazy.StateT m) = Lazy.StateT $ lookAhead . m - -instance MonadParser m => MonadParser (Strict.StateT s m) where - try (Strict.StateT m) = Strict.StateT $ try . m - labels (Strict.StateT m) ss = Strict.StateT $ \s -> labels (m s) ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (Strict.StateT m) = Strict.StateT $ nesting . m - skipping = lift . skipping - position = lift position - slicedWith f (Strict.StateT m) = Strict.StateT $ \s -> slicedWith (\(a,s') b -> (f a b, s')) $ m s - lookAhead (Strict.StateT m) = Strict.StateT $ lookAhead . m - -instance MonadParser m => MonadParser (ReaderT e m) where - try (ReaderT m) = ReaderT $ try . m - labels (ReaderT m) ss = ReaderT $ \s -> labels (m s) ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (ReaderT m) = ReaderT $ nesting . m - skipping = lift . skipping - position = lift position - slicedWith f (ReaderT m) = ReaderT $ slicedWith f . m - lookAhead (ReaderT m) = ReaderT $ lookAhead . m - -instance (MonadParser m, Monoid w) => MonadParser (Strict.WriterT w m) where - try (Strict.WriterT m) = Strict.WriterT $ try m - labels (Strict.WriterT m) ss = Strict.WriterT $ labels m ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (Strict.WriterT m) = Strict.WriterT $ nesting m - skipping = lift . skipping - position = lift position - slicedWith f (Strict.WriterT m) = Strict.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m - lookAhead (Strict.WriterT m) = Strict.WriterT $ lookAhead m - -instance (MonadParser m, Monoid w) => MonadParser (Lazy.WriterT w m) where - try (Lazy.WriterT m) = Lazy.WriterT $ try m - labels (Lazy.WriterT m) ss = Lazy.WriterT $ labels m ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (Lazy.WriterT m) = Lazy.WriterT $ nesting m - skipping = lift . skipping - position = lift position - slicedWith f (Lazy.WriterT m) = Lazy.WriterT $ slicedWith (\(a,s') b -> (f a b, s')) m - lookAhead (Lazy.WriterT m) = Lazy.WriterT $ lookAhead m - -instance (MonadParser m, Monoid w) => MonadParser (Lazy.RWST r w s m) where - try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s) - labels (Lazy.RWST m) ss = Lazy.RWST $ \r s -> labels (m r s) ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (Lazy.RWST m) = Lazy.RWST $ \r s -> nesting (m r s) - skipping = lift . skipping - position = lift position - slicedWith f (Lazy.RWST m) = Lazy.RWST $ \r s -> slicedWith (\(a,s',w) b -> (f a b, s',w)) $ m r s - lookAhead (Lazy.RWST m) = Lazy.RWST $ \r s -> lookAhead $ m r s - -instance (MonadParser m, Monoid w) => MonadParser (Strict.RWST r w s m) where - try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s) - labels (Strict.RWST m) ss = Strict.RWST $ \r s -> labels (m r s) ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (Strict.RWST m) = Strict.RWST $ \r s -> nesting (m r s) - skipping = lift . skipping - position = lift position - slicedWith f (Strict.RWST m) = Strict.RWST $ \r s -> slicedWith (\(a,s',w) b -> (f a b, s',w)) $ m r s - lookAhead (Strict.RWST m) = Strict.RWST $ \r s -> lookAhead $ m r s - -instance MonadParser m => MonadParser (IdentityT m) where - try = IdentityT . try . runIdentityT - labels (IdentityT m) ss = IdentityT $ labels m ss - line = lift line - unexpected = lift . unexpected - satisfy = lift . satisfy - satisfy8 = lift . satisfy8 - someSpace = lift someSpace - semi = lift semi - highlightInterval h s e = lift $ highlightInterval h s e - nesting (IdentityT m) = IdentityT $ nesting m - skipping = lift . skipping - position = lift position - slicedWith f (IdentityT m) = IdentityT $ slicedWith f m - lookAhead (IdentityT m) = IdentityT $ lookAhead m - --- | Skip zero or more bytes worth of white space. More complex parsers are --- free to consider comments as white space. -whiteSpace :: MonadParser m => m () -whiteSpace = someSpace <|> return () -{-# INLINE whiteSpace #-} - -satisfyAscii :: MonadParser m => (Char -> Bool) -> m Char -satisfyAscii p = w2c <$> satisfy8 (\w -> w <= 0x7f && p (w2c w)) -{-# INLINE satisfyAscii #-} - --- | grab the remainder of the current line -restOfLine :: MonadParser m => m ByteString -restOfLine = do - m <- position - Strict.drop (fromIntegral (columnByte m)) <$> line -{-# INLINE restOfLine #-} - --- | label a parser with a name -() :: MonadParser m => m a -> String -> m a -p msg = labels p [msg] -{-# INLINE () #-} - --- | run a parser, grabbing all of the text between its start and end points and discarding the original result -sliced :: MonadParser m => m a -> m ByteString -sliced = slicedWith (\_ bs -> bs) -{-# INLINE sliced #-} - -rend :: MonadParser m => m Rendering -rend = rendering <$> position <*> line -{-# INLINE rend #-} - --- | run a parser, highlighting all of the text between its start and end points. -highlight :: MonadParser m => Highlight -> m a -> m a -highlight h p = do - m <- position - x <- p - r <- position - x <$ highlightInterval h m r -{-# INLINE highlight #-} diff --git a/src/Text/Trifecta/Parser/Combinators.hs b/src/Text/Trifecta/Parser/Combinators.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Combinators.hs +++ /dev/null @@ -1,207 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Combinators --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Commonly used generic combinators --- ------------------------------------------------------------------------------ - -module Text.Trifecta.Parser.Combinators - ( choice - , option - , optional -- from Control.Applicative, parsec optionMaybe - , skipOptional -- parsec optional - , between - , skipSome -- parsec skipMany1 - , some -- from Control.Applicative, parsec many1 - , many -- from Control.Applicative - , sepBy - , sepBy1 - , sepEndBy1 - , sepEndBy - , endBy1 - , endBy - , count - , chainl - , chainr - , chainl1 - , chainr1 - , eof - , manyTill - , notFollowedBy - ) where - -import Data.Traversable -import Control.Applicative -import Control.Monad -import qualified Data.ByteString as B -import Text.Trifecta.Parser.Class - --- | @choice ps@ tries to apply the parsers in the list @ps@ in order, --- until one of them succeeds. Returns the value of the succeeding --- parser. -choice :: Alternative m => [m a] -> m a -choice = foldr (<|>) empty - --- | @option x p@ tries to apply parser @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value --- returned by @p@. --- --- > priority = option 0 (do{ d <- digit --- > ; return (digitToInt d) --- > }) -option :: Alternative m => a -> m a -> m a -option x p = p <|> pure x - --- | @skipOptional p@ tries to apply parser @p@. It will parse @p@ or nothing. --- It only fails if @p@ fails after consuming input. It discards the result --- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional) -skipOptional :: Alternative m => m a -> m () -skipOptional p = (() <$ p) <|> pure () - --- | @between open close p@ parses @open@, followed by @p@ and @close@. --- Returns the value returned by @p@. --- --- > braces = between (symbol "{") (symbol "}") -between :: Applicative m => m bra -> m ket -> m a -> m a -between bra ket p = bra *> p <* ket - --- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping --- its result. (aka skipMany1 in parsec) -skipSome :: MonadParser m => m a -> m () -skipSome p = p *> skipMany p - --- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. --- --- > commaSep p = p `sepBy` (symbol ",") -sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = sepBy1 p sep <|> pure [] - --- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. -sepBy1 :: Alternative m => m a -> m sep -> m [a] -sepBy1 p sep = (:) <$> p <*> many (sep *> p) - --- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, --- separated and optionally ended by @sep@. Returns a list of values --- returned by @p@. -sepEndBy1 :: Alternative m => m a -> m sep -> m [a] -sepEndBy1 p sep = flip id <$> p <*> ((flip (:) <$> (sep *> sepEndBy p sep)) <|> pure pure) - --- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, --- separated and optionally ended by @sep@, ie. haskell style --- statements. Returns a list of values returned by @p@. --- --- > haskellStatements = haskellStatement `sepEndBy` semi -sepEndBy :: Alternative m => m a -> m sep -> m [a] -sepEndBy p sep = sepEndBy1 p sep <|> pure [] - --- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated --- and ended by @sep@. Returns a list of values returned by @p@. -endBy1 :: Alternative m => m a -> m sep -> m [a] -endBy1 p sep = some (p <* sep) - --- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated --- and ended by @sep@. Returns a list of values returned by @p@. --- --- > cStatements = cStatement `endBy` semi -endBy :: Alternative m => m a -> m sep -> m [a] -endBy p sep = many (p <* sep) - --- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or --- equal to zero, the parser equals to @return []@. Returns a list of --- @n@ values returned by @p@. -count :: Applicative m => Int -> m a -> m [a] -count n p | n <= 0 = pure [] - | otherwise = sequenceA (replicate n p) - --- | @chainr p op x@ parser /zero/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are no occurrences of @p@, the value @x@ is --- returned. -chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainr p op x = chainr1 p op <|> pure x - --- | @chainl p op x@ parser /zero/ or more occurrences of @p@, --- separated by @op@. Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are zero occurrences of @p@, the value @x@ is --- returned. -chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainl p op x = chainl1 p op <|> pure x - --- | @chainl1 p op x@ parser /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. . This parser can for example be used to eliminate left --- recursion which typically occurs in expression grammars. --- --- > expr = term `chainl1` addop --- > term = factor `chainl1` mulop --- > factor = parens expr <|> integer --- > --- > mulop = do{ symbol "*"; return (*) } --- > <|> do{ symbol "/"; return (div) } --- > --- > addop = do{ symbol "+"; return (+) } --- > <|> do{ symbol "-"; return (-) } -chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainl1 p op = scan where - scan = flip id <$> p <*> rst - rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id - --- | @chainr1 p op x@ parser /one/ or more occurrences of |p|, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. -chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainr1 p op = scan where - scan = flip id <$> p <*> rst - rst = (flip <$> op <*> scan) <|> pure id - --- | @manyTill p end@ applies parser @p@ /zero/ or more times until --- parser @end@ succeeds. Returns the list of values returned by @p@. --- This parser can be used to scan comments: --- --- > simpleComment = do{ string "")) --- > } --- --- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and --- therefore the use of the 'try' combinator. -manyTill :: Alternative m => m a -> m end -> m [a] -manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) - --- * MonadParsers - --- | This parser only succeeds at the end of the input. This is not a --- primitive parser but it is defined using 'notFollowedBy'. --- --- > eof = notFollowedBy anyChar "end of input" -eof :: MonadParser m => m () -eof = do - l <- restOfLine - guard $ B.null l - "end of input" - --- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser --- does not consume any input. This parser can be used to implement the --- \'longest match\' rule. For example, when recognizing keywords (for --- example @let@), we want to make sure that a keyword is not followed --- by a legal identifier character, in which case the keyword is --- actually an identifier (for example @lets@). We can program this --- behaviour as follows: --- --- > keywordLet = try (do{ string "let" --- > ; notFollowedBy alphaNum --- > }) -notFollowedBy :: (MonadParser m, Show a) => m a -> m () -notFollowedBy p = try ((try p >>= unexpected . show) <|> pure ()) diff --git a/src/Text/Trifecta/Parser/Expr.hs b/src/Text/Trifecta/Parser/Expr.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Expr.hs +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Expr --- Copyright : (c) Edward Kmett --- (c) Paolo Martini 2007 --- (c) Daan Leijen 1999-2001, --- License : BSD-style (see the LICENSE file) --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- A helper module to parse \"expressions\". --- Builds a parser given a table of operators and associativities. --- ------------------------------------------------------------------------------ - -module Text.Trifecta.Parser.Expr - ( Assoc(..), Operator(..), OperatorTable - , buildExpressionParser - ) where - -import Control.Applicative -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Combinators - ------------------------------------------------------------ --- Assoc and OperatorTable ------------------------------------------------------------ - --- | This data type specifies the associativity of operators: left, right --- or none. - -data Assoc - = AssocNone - | AssocLeft - | AssocRight - --- | This data type specifies operators that work on values of type @a@. --- An operator is either binary infix or unary prefix or postfix. A --- binary operator has also an associated associativity. - -data Operator m a - = Infix (m (a -> a -> a)) Assoc - | Prefix (m (a -> a)) - | Postfix (m (a -> a)) - --- | An @OperatorTable m a@ is a list of @Operator m a@ --- lists. The list is ordered in descending --- precedence. All operators in one list have the same precedence (but --- may have a different associativity). - -type OperatorTable m a = [[Operator m a]] - ------------------------------------------------------------ --- Convert an OperatorTable and basic term parser into --- a full fledged expression parser ------------------------------------------------------------ - --- | @buildExpressionParser table term@ builds an expression parser for --- terms @term@ with operators from @table@, taking the associativity --- and precedence specified in @table@ into account. Prefix and postfix --- operators of the same precedence can only occur once (i.e. @--2@ is --- not allowed if @-@ is prefix negate). Prefix and postfix operators --- of the same precedence associate to the left (i.e. if @++@ is --- postfix increment, than @-2++@ equals @-1@, not @-3@). --- --- The @buildExpressionParser@ takes care of all the complexity --- involved in building expression parser. Here is an example of an --- expression parser that handles prefix signs, postfix increment and --- basic arithmetic. --- --- > expr = buildExpressionParser table term --- > "expression" --- > --- > term = parens expr --- > <|> natural --- > "simple expression" --- > --- > table = [ [prefix "-" negate, prefix "+" id ] --- > , [postfix "++" (+1)] --- > , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ] --- > , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ] --- > ] --- > --- > binary name fun assoc = Infix (do{ reservedOp name; return fun }) assoc --- > prefix name fun = Prefix (do{ reservedOp name; return fun }) --- > postfix name fun = Postfix (do{ reservedOp name; return fun }) - -buildExpressionParser :: MonadParser m - => OperatorTable m a - -> m a - -> m a -buildExpressionParser operators simpleExpr - = foldl (makeParser) simpleExpr operators - where - makeParser term ops - = let (rassoc,lassoc,nassoc,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops - - rassocOp = choice rassoc - lassocOp = choice lassoc - nassocOp = choice nassoc - prefixOp = choice prefix "" - postfixOp = choice postfix "" - - ambigious assoc op= try $ op *> fail ("ambiguous use of a " ++ assoc ++ " associative operator") - - ambigiousRight = ambigious "right" rassocOp - ambigiousLeft = ambigious "left" lassocOp - ambigiousNon = ambigious "non" nassocOp - - termP = do{ pre <- prefixP - ; x <- term - ; post <- postfixP - ; return (post (pre x)) - } - - postfixP = postfixOp <|> return id - - prefixP = prefixOp <|> return id - - rassocP x = do{ f <- rassocOp - ; y <- termP >>= rassocP1 - ; return (f x y) - } - <|> ambigiousLeft - <|> ambigiousNon - -- <|> return x - - rassocP1 x = rassocP x <|> return x - - lassocP x = do{ f <- lassocOp - ; y <- termP - ; lassocP1 (f x y) - } - <|> ambigiousRight - <|> ambigiousNon - -- <|> return x - - lassocP1 x = lassocP x <|> return x - - nassocP x = do{ f <- nassocOp - ; y <- termP - ; ambigiousRight - <|> ambigiousLeft - <|> ambigiousNon - <|> return (f x y) - } - -- <|> return x - - in do{ x <- termP - ; rassocP x <|> lassocP x <|> nassocP x <|> return x - "operator" - } - - - splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix) - = case assoc of - AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix) - AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix) - AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix) - - splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix) - = (rassoc,lassoc,nassoc,op:prefix,postfix) - - splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix) - = (rassoc,lassoc,nassoc,prefix,op:postfix) diff --git a/src/Text/Trifecta/Parser/Identifier.hs b/src/Text/Trifecta/Parser/Identifier.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Identifier.hs +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Identifier --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : provisional --- Portability : non-portable --- --- > idStyle = haskellIdentifierStyle { styleReserved = ... } --- > identifier = ident haskellIdentifierStyle --- > reserved = reserve haskellIdentifierStyle --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Identifier - ( IdentifierStyle(..) - , liftIdentifierStyle - , ident - , reserve - , reserveByteString - ) where - -import Data.ByteString as Strict hiding (map, zip, foldl, foldr) -import Data.ByteString.UTF8 as UTF8 -import Data.HashSet as HashSet -import Control.Applicative -import Control.Monad (when) -import Control.Monad.Trans.Class -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Parser.Token.Combinators -import Text.Trifecta.Highlight.Prim - -data IdentifierStyle m = IdentifierStyle - { styleName :: String - , styleStart :: m () - , styleLetter :: m () - , styleReserved :: HashSet ByteString - , styleHighlight :: Highlight - , styleReservedHighlight :: Highlight - } - --- | Lift an identifier style into a monad transformer -liftIdentifierStyle :: (MonadTrans t, Monad m) => IdentifierStyle m -> IdentifierStyle (t m) -liftIdentifierStyle s = - s { styleStart = lift (styleStart s) - , styleLetter = lift (styleLetter s) - } - --- | parse a reserved operator or identifier using a given style -reserve :: MonadParser m => IdentifierStyle m -> String -> m () -reserve s name = reserveByteString s $! UTF8.fromString name - --- | parse a reserved operator or identifier using a given style specified by bytestring -reserveByteString :: MonadParser m => IdentifierStyle m -> ByteString -> m () -reserveByteString s name = lexeme $ try $ do - _ <- highlight (styleReservedHighlight s) $ byteString name - notFollowedBy (styleLetter s) "end of " ++ show name - --- | parse an non-reserved identifier or symbol -ident :: MonadParser m => IdentifierStyle m -> m ByteString -ident s = lexeme $ try $ do - name <- highlight (styleHighlight s) (sliced (styleStart s *> skipMany (styleLetter s))) styleName s - when (member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name - return name diff --git a/src/Text/Trifecta/Parser/Identifier/Style.hs b/src/Text/Trifecta/Parser/Identifier/Style.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Identifier/Style.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Identifier.Style --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : provisional --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Identifier.Style - ( - -- identifier styles - emptyIdents, haskellIdents, haskell98Idents - -- operator styles - , emptyOps, haskellOps, haskell98Ops - ) where - -import Data.ByteString as Strict hiding (map, zip, foldl, foldr) -import Data.ByteString.UTF8 as UTF8 -import Data.HashSet as HashSet -import Data.Monoid -import Control.Applicative -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Identifier -import Text.Trifecta.Highlight.Prim - -set :: [String] -> HashSet ByteString -set = HashSet.fromList . fmap UTF8.fromString - -emptyOps, haskell98Ops, haskellOps :: MonadParser m => IdentifierStyle m -emptyOps = IdentifierStyle - { styleName = "operator" - , styleStart = styleLetter emptyOps - , styleLetter = () <$ oneOf ":!#$%&*+./<=>?@\\^|-~" - , styleReserved = mempty - , styleHighlight = Operator - , styleReservedHighlight = ReservedOperator - } -haskell98Ops = emptyOps - { styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"] - } -haskellOps = haskell98Ops - -emptyIdents, haskell98Idents, haskellIdents :: MonadParser m => IdentifierStyle m -emptyIdents = IdentifierStyle - { styleName = "identifier" - , styleStart = () <$ (letter <|> char '_') - , styleLetter = () <$ (alphaNum <|> oneOf "_'") - , styleReserved = set [] - , styleHighlight = Identifier - , styleReservedHighlight = ReservedIdentifier } - -haskell98Idents = emptyIdents - { styleReserved = set haskell98ReservedIdents } -haskellIdents = haskell98Idents - { styleLetter = styleLetter haskell98Idents <|> () <$ char '#' - , styleReserved = set $ haskell98ReservedIdents ++ - ["foreign","import","export","primitive","_ccall_","_casm_" ,"forall"] - } - -haskell98ReservedIdents :: [String] -haskell98ReservedIdents = - ["let","in","case","of","if","then","else","data","type" - ,"class","default","deriving","do","import","infix" - ,"infixl","infixr","instance","module","newtype" - ,"where","primitive" -- "as","qualified","hiding" - ] diff --git a/src/Text/Trifecta/Parser/It.hs b/src/Text/Trifecta/Parser/It.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/It.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, BangPatterns, MagicHash, UnboxedTuples, TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.It --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- --- harder, better, faster, stronger... ----------------------------------------------------------------------------- -module Text.Trifecta.Parser.It - ( It(Pure, It) - , needIt - , wantIt - , simplifyIt - , runIt - , fillIt - , rewindIt - , sliceIt - , stepIt - ) where - -import Control.Applicative -import Control.Comonad -import Control.Monad -import Data.Semigroup -import Data.ByteString as Strict -import Data.ByteString.Lazy as Lazy -import Data.Functor.Bind -import Data.Profunctor -import Data.Key as Key -import Text.Trifecta.Rope.Prim as Rope -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Parser.Step -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 - -type instance Key (It r) = r - -instance Profunctor It where - lmap _ (Pure a) = Pure a - lmap f (It a k) = It a (lmap f . k . f) - - rmap g (Pure a) = Pure (g a) - rmap g (It a k) = It (g a) (rmap g . k) - -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 - -instance Indexable (It r) where - index (Pure a) _ = a - index (It _ k) r = extract (k r) - -instance Lookup (It r) where - lookup = lookupDefault - -instance Zip (It r) where - zipWith = liftA2 - -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 (Key.index (f a') r) $ k' >=> f - Pure a' -> simplifyIt (f a') r - -instance Apply (It r) where (<.>) = (<*>) -instance Bind (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 #) - -stepIt :: It Rope a -> Step e a -stepIt = go mempty where - go r (Pure a) = StepDone r mempty a - go r (It a k) = StepCont r (pure a) $ \s -> go s (k s) - --- | 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 diff --git a/src/Text/Trifecta/Parser/Mark.hs b/src/Text/Trifecta/Parser/Mark.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Mark.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Mark --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Mark - ( MonadMark(..) - ) where - -import Control.Monad.Trans.Class -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 Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Identity -import Data.Monoid -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Parser.Class - -class (MonadParser m, HasDelta d) => MonadMark 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 MonadMark d m => MonadMark d (Lazy.StateT s m) where - mark = lift mark - release = lift . release - -instance MonadMark d m => MonadMark d (Strict.StateT s m) where - mark = lift mark - release = lift . release - -instance MonadMark d m => MonadMark d (ReaderT e m) where - mark = lift mark - release = lift . release - -instance (MonadMark d m, Monoid w) => MonadMark d (Strict.WriterT w m) where - mark = lift mark - release = lift . release - -instance (MonadMark d m, Monoid w) => MonadMark d (Lazy.WriterT w m) where - mark = lift mark - release = lift . release - -instance (MonadMark d m, Monoid w) => MonadMark d (Lazy.RWST r w s m) where - mark = lift mark - release = lift . release - -instance (MonadMark d m, Monoid w) => MonadMark d (Strict.RWST r w s m) where - mark = lift mark - release = lift . release - -instance MonadMark d m => MonadMark d (IdentityT m) where - mark = lift mark - release = lift . release - diff --git a/src/Text/Trifecta/Parser/Perm.hs b/src/Text/Trifecta/Parser/Perm.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Perm.hs +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Perm --- Copyright : (c) Edward Kmett 2011 --- (c) Paolo Martini 2007 --- (c) Daan Leijen 1999-2001 --- License : BSD-style --- --- Maintainer : ekmett@gmail.com --- Stability : provisional --- Portability : non-portable --- --- This module implements permutation parsers. The algorithm is described in: --- --- /Parsing Permutation Phrases,/ --- by Arthur Baars, Andres Loh and Doaitse Swierstra. --- Published as a functional pearl at the Haskell Workshop 2001. --- ------------------------------------------------------------------------------ - -{-# LANGUAGE ExistentialQuantification #-} - -module Text.Trifecta.Parser.Perm - ( Perm - , permute - , (<||>), (<$$>) - , (<|?>), (<$?>) - ) where - -import Control.Applicative -import Text.Trifecta.Parser.Combinators (choice) - -infixl 1 <||>, <|?> -infixl 2 <$$>, <$?> - -{--------------------------------------------------------------- - Building a permutation parser ----------------------------------------------------------------} - --- | The expression @perm \<||> p@ adds parser @p@ to the permutation --- parser @perm@. The parser @p@ is not allowed to accept empty input - --- use the optional combinator ('<|?>') instead. Returns a --- new permutation parser that includes @p@. - -(<||>) :: Functor m => Perm m (a -> b) -> m a -> Perm m b -(<||>) perm p = add perm p - --- | The expression @f \<$$> p@ creates a fresh permutation parser --- consisting of parser @p@. The the final result of the permutation --- parser is the function @f@ applied to the return value of @p@. The --- parser @p@ is not allowed to accept empty input - use the optional --- combinator ('<$?>') instead. --- --- If the function @f@ takes more than one parameter, the type variable --- @b@ is instantiated to a functional type which combines nicely with --- the adds parser @p@ to the ('<||>') combinator. This --- results in stylized code where a permutation parser starts with a --- combining function @f@ followed by the parsers. The function @f@ --- gets its parameters in the order in which the parsers are specified, --- but actual input can be in any order. - -(<$$>) :: Functor m => (a -> b) -> m a -> Perm m b -(<$$>) f p = newPerm f <||> p - --- | The expression @perm \<||> (x,p)@ adds parser @p@ to the --- permutation parser @perm@. The parser @p@ is optional - if it can --- not be applied, the default value @x@ will be used instead. Returns --- a new permutation parser that includes the optional parser @p@. - -(<|?>) :: Functor m => Perm m (a -> b) -> (a, m a) -> Perm m b -(<|?>) perm (x,p) = addOpt perm x p - --- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser --- consisting of parser @p@. The the final result of the permutation --- parser is the function @f@ applied to the return value of @p@. The --- parser @p@ is optional - if it can not be applied, the default value --- @x@ will be used instead. - -(<$?>) :: Functor m => (a -> b) -> (a, m a) -> Perm m b -(<$?>) f (x,p) = newPerm f <|?> (x,p) - -{--------------------------------------------------------------- - The permutation tree ----------------------------------------------------------------} - --- | The type @Perm m a@ denotes a permutation parser that, --- when converted by the 'permute' function, parses --- using the base parsing monad @m@ and returns a value of --- type @a@ on success. --- --- Normally, a permutation parser is first build with special operators --- like ('<||>') and than transformed into a normal parser --- using 'permute'. - -data Perm m a = Perm (Maybe a) [Branch m a] - -instance Functor m => Functor (Perm m) where - fmap f (Perm x xs) = Perm (fmap f x) (fmap f <$> xs) - -data Branch m a = forall b. Branch (Perm m (b -> a)) (m b) - -instance Functor m => Functor (Branch m) where - fmap f (Branch perm p) = Branch (fmap (f.) perm) p - --- | The parser @permute perm@ parses a permutation of parser described --- by @perm@. For example, suppose we want to parse a permutation of: --- an optional string of @a@'s, the character @b@ and an optional @c@. --- This can be described by: --- --- > test = permute (tuple <$?> ("",some (char 'a')) --- > <||> char 'b' --- > <|?> ('_',char 'c')) --- > where --- > tuple a b c = (a,b,c) - --- transform a permutation tree into a normal parser -permute :: Alternative m => Perm m a -> m a -permute (Perm def xs) - = choice (map branch xs ++ e) - where - e = maybe [] (pure . pure) def - branch (Branch perm p) = flip id <$> p <*> permute perm - --- build permutation trees -newPerm :: (a -> b) -> Perm m (a -> b) -newPerm f = Perm (Just f) [] - -add :: Functor m => Perm m (a -> b) -> m a -> Perm m b -add perm@(Perm _mf fs) p - = Perm Nothing (first:map insert fs) - where - first = Branch perm p - insert (Branch perm' p') - = Branch (add (fmap flip perm') p) p' - -addOpt :: Functor m => Perm m (a -> b) -> a -> m a -> Perm m b -addOpt perm@(Perm mf fs) x p - = Perm (fmap ($ x) mf) (first:map insert fs) - where - first = Branch perm p - insert (Branch perm' p') = Branch (addOpt (fmap flip perm') x p) p' diff --git a/src/Text/Trifecta/Parser/Prim.hs b/src/Text/Trifecta/Parser/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Prim.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, Rank2Types, FlexibleInstances, BangPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Prim --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Prim - ( Parser(..) - , why - , stepParser - , manyAccum - ) where - - -import Control.Applicative -import Control.Monad.Error.Class -import Control.Monad.Writer.Class -import Control.Monad.Cont.Class -import Control.Monad -import Control.Comonad -import qualified Data.Functor.Plus as Plus -import Data.Functor.Plus hiding (some, many) -import Data.Function -import Data.Semigroup -import Data.Foldable -import qualified Data.List as List -import Data.Functor.Bind (Bind((>>-))) -import qualified Text.Trifecta.IntervalMap as IntervalMap -import Data.Set as Set hiding (empty, toList) -import Data.ByteString as Strict hiding (empty) -import Data.Sequence as Seq hiding (empty) -import Data.ByteString.UTF8 as UTF8 -import Text.PrettyPrint.Free hiding (line) -import Text.Trifecta.Diagnostic.Class -import Text.Trifecta.Diagnostic.Prim -import Text.Trifecta.Diagnostic.Level -import Text.Trifecta.Diagnostic.Err -import Text.Trifecta.Diagnostic.Err.State -import Text.Trifecta.Diagnostic.Err.Log -import Text.Trifecta.Diagnostic.Rendering.Caret -import Text.Trifecta.Highlight.Class -import Text.Trifecta.Highlight.Prim -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.It -import Text.Trifecta.Parser.Mark -import Text.Trifecta.Parser.Step -import Text.Trifecta.Parser.Result -import Text.Trifecta.Rope.Delta as Delta -import Text.Trifecta.Rope.Prim -import Text.Trifecta.Rope.Bytes - -data Parser r e a = Parser - { unparser :: - (a -> ErrState e -> ErrLog e -> Bool -> Delta -> ByteString -> It Rope r) -> -- uncommitted ok - ( ErrState e -> ErrLog e -> Bool -> Delta -> ByteString -> It Rope r) -> -- uncommitted err - (a -> ErrState e -> ErrLog e -> Bool -> Delta -> ByteString -> It Rope r) -> -- committed ok - ( ErrState e -> ErrLog e -> Bool -> Delta -> ByteString -> It Rope r) -> -- committed err - ErrLog e -> Bool -> Delta -> ByteString -> It Rope r - } - -instance Functor (Parser r e) 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 Apply (Parser r e) where (<.>) = (<*>) -instance Applicative (Parser r e) where - pure a = Parser $ \ eo _ _ _ -> eo a mempty - {-# INLINE pure #-} - (<*>) = ap - {-# INLINE (<*>) #-} -{- - Parser m <*> Parser n = Parser $ \ eo ee co ce -> - m (\f e -> n (\a e' -> eo (f a) (e <> e')) ee (\a e' -> co (f a) (e <> e')) ce) ee - (\f e -> n (\a e' -> co (f a) (e <> e')) ce (\a e' -> co (f a) (e <> e')) ce) ce - {-# INLINE (<*>) #-} - Parser m <* Parser n = Parser $ \ eo ee co ce -> - m (\a e -> n (\_ e' -> eo a (e <> e')) ee (\_ e' -> co a (e <> e')) ce) ee - (\a e -> n (\_ e' -> co a (e <> e')) ce (\_ e' -> co a (e <> e')) ce) ce - {-# INLINE (<*) #-} - Parser m *> Parser n = Parser $ \ eo ee co ce -> - m (\_ e -> n (\a e' -> eo a (e <> e')) ee (\a e' -> co a (e <> e')) ce) ee - (\_ e -> n (\a e' -> co a (e <> e')) ce (\a e' -> co a (e <> e')) ce) ce - {-# INLINE (*>) #-} --} - -instance Alt (Parser r e) where - () = (<|>) - many p = Prelude.reverse <$> manyAccum (:) p - some p = p *> many p -instance Plus (Parser r e) where zero = empty -instance Alternative (Parser r e) where - empty = Parser $ \_ ee _ _ -> ee mempty - {-# INLINE empty #-} - Parser m <|> Parser n = Parser $ \ eo ee co ce -> - m eo (\e -> n (\a e'-> eo a (e <> e')) (\e' -> ee (e <> e')) co ce) - co ce - {-# INLINE (<|>) #-} - many p = Prelude.reverse <$> manyAccum (:) p - {-# INLINE many #-} - some p = (:) <$> p <*> many p - -instance Semigroup (Parser r e a) where - (<>) = (<|>) - -instance Monoid (Parser r e a) where - mappend = (<|>) - mempty = empty - -instance Bind (Parser r e) where (>>-) = (>>=) -instance Monad (Parser r e) where - return a = Parser $ \ eo _ _ _ -> eo a mempty - {-# INLINE return #-} - Parser m >>= k = Parser $ \ eo ee co ce -> - m (\a e -> unparser (k a) (\b e' -> eo b (e <> e')) (\e' -> ee (e <> e')) co ce) ee - (\a e -> unparser (k a) (\b e' -> co b (e <> e')) (\e' -> ce (e <> e')) co ce) ce - {-# INLINE (>>=) #-} - (>>) = (*>) - {-# INLINE (>>) #-} - fail s = Parser $ \ _ ee _ _ l b8 d bs -> ee mempty { errMessage = FailErr (renderingCaret d bs) s } l b8 d bs - {-# INLINE fail #-} - - -instance MonadPlus (Parser r e) where - mzero = empty - mplus = (<|>) - -instance MonadWriter (ErrLog e) (Parser r e) where - tell w = Parser $ \eo _ _ _ l -> eo () mempty (l <> w) - {-# INLINE tell #-} - listen (Parser m) = Parser $ \eo ee co ce l -> - m (\ a e' l' -> eo (a,l') e' (l <> l')) - (\ e' l' -> ee e' (l <> l')) - (\ a e' l' -> co (a,l') e' (l <> l')) - (\ e' l' -> ce e' (l <> l')) - mempty - {-# INLINE listen #-} - pass (Parser m) = Parser $ \eo ee co ce l -> - m (\(a,p) e' l' -> eo a e' (l <> p l')) - (\ e' l' -> ee e' (l <> l')) - (\(a,p) e' l' -> co a e' (l <> p l')) - (\ e' l' -> ce e' (l <> l')) - mempty - {-# INLINE pass #-} - -manyAccum :: (a -> [a] -> [a]) -> Parser r e a -> Parser r e [a] -manyAccum acc (Parser p) = Parser $ \eo _ co ce -> - let walk xs x _ = p manyErr (\_ -> co (acc x xs) mempty) (walk (acc x xs)) ce - manyErr _ e l b8 d bs = ce e { errMessage = PanicErr (renderingCaret d bs) "'many' applied to a parser that accepted an empty string" } l b8 d bs - in p manyErr (eo []) (walk []) ce - -instance MonadDiagnostic e (Parser r e) where - throwDiagnostic e@(Diagnostic _ l _ _) - | l == Fatal || l == Panic = Parser $ \_ _ _ ce -> ce mempty { errMessage = Err e } - | otherwise = Parser $ \_ ee _ _ -> ee mempty { errMessage = Err e } - logDiagnostic d = Parser $ \eo _ _ _ l -> eo () mempty l { errLog = errLog l |> d } - -instance MonadError (ErrState e) (Parser r e) where - throwError m = Parser $ \_ ee _ _ -> ee m - {-# INLINE throwError #-} - catchError (Parser m) k = Parser $ \ eo ee co ce -> - m eo (\e -> unparser (k e) eo ee co ce) co ce - {-# INLINE catchError #-} - -ascii :: ByteString -> Bool -ascii = Strict.all (<=0x7f) - -liftIt :: It Rope a -> Parser r e a -liftIt m = Parser $ \ eo _ _ _ l b8 d bs -> do - a <- m - eo a mempty l b8 d bs -{-# INLINE liftIt #-} - -instance MonadParser (Parser r e) where - try (Parser m) = Parser $ \ eo ee co ce l b8 d bs -> m eo ee co (\e l' _ _ _ -> - if fatalErr (errMessage e) - then ce e (l <> l') b8 d bs - else ee e (l <> l') b8 d bs - ) l b8 d bs - {-# INLINE try #-} - highlightInterval h s e = Parser $ \eo _ _ _ l -> eo () mempty l { errHighlights = IntervalMap.insert s e h (errHighlights l) } - {-# INLINE highlightInterval #-} - - skipping d = do - m <- mark - release $ m <> d - {-# INLINE skipping #-} - - unexpected s = Parser $ \ _ ee _ _ l b8 d bs -> ee mempty { errMessage = FailErr (renderingCaret d bs) $ "unexpected " ++ s } l b8 d bs - {-# INLINE unexpected #-} - - labels (Parser p) msgs = Parser $ \ eo ee -> p - (\a e l b8 d bs -> - eo a (if knownErr (errMessage e) - then e { errExpected = Set.fromList (Prelude.map (:^ Caret d bs) msgs) `union` errExpected e } - else e) l b8 d bs) - (\e l b8 d bs -> ee e { errExpected = Set.fromList $ Prelude.map (:^ Caret d bs) msgs } l b8 d bs) - {-# INLINE labels #-} - line = Parser $ \eo _ _ _ l b8 d bs -> eo bs mempty l b8 d bs - {-# INLINE line #-} - skipMany p = () <$ manyAccum (\_ _ -> []) p - {-# INLINE skipMany #-} - satisfy f = Parser $ \ _ ee co _ l b8 d bs -> - if b8 -- fast path - then let b = columnByte d in ( - if b >= 0 && b < fromIntegral (Strict.length bs) - then case toEnum $ fromEnum $ Strict.index bs (fromIntegral b) of - c | not (f c) -> ee mempty l b8 d bs - | b == fromIntegral (Strict.length bs) - 1 -> let !ddc = d <> delta c - in join $ fillIt ( if c == '\n' - then co c mempty l True ddc mempty - else co c mempty l b8 ddc bs ) - (\d' bs' -> co c mempty l (ascii bs') d' bs') - ddc - | otherwise -> co c mempty l b8 (d <> delta c) bs - else ee mempty { errMessage = FailErr (renderingCaret d bs) "unexpected EOF" } l b8 d bs) - else case UTF8.uncons $ Strict.drop (fromIntegral (columnByte d)) bs of - Nothing -> ee mempty { errMessage = FailErr (renderingCaret d bs) "unexpected EOF" } l b8 d bs - Just (c, xs) - | not (f c) -> ee mempty l b8 d bs - | Strict.null xs -> let !ddc = d <> delta c - in join $ fillIt ( if c == '\n' - then co c mempty l True ddc mempty - else co c mempty l b8 ddc bs) - (\d' bs' -> co c mempty l (ascii bs') d' bs') - ddc - | otherwise -> co c mempty l b8 (d <> delta c) bs - satisfy8 f = Parser $ \ _ ee co _ l b8 d bs -> - let b = columnByte d in - if b >= 0 && b < fromIntegral (Strict.length bs) - then case toEnum $ fromEnum $ Strict.index bs (fromIntegral b) of - c | not (f c) -> ee mempty l b8 d bs - | b == fromIntegral (Strict.length bs - 1) -> let !ddc = d <> delta c - in join $ fillIt ( if c == 10 - then co c mempty l True ddc mempty - else co c mempty l b8 ddc bs ) - (\d' bs' -> co c mempty l (ascii bs') d' bs') - ddc - | otherwise -> co c mempty l b8 (d <> delta c) bs - else ee mempty { errMessage = FailErr (renderingCaret d bs) "unexpected EOF" } l b8 d bs - position = Parser $ \eo _ _ _ l b8 d -> eo d mempty l b8 d - {-# INLINE position #-} - slicedWith f p = do - m <- position - a <- p - r <- position - f a <$> liftIt (sliceIt m r) - {-# INLINE slicedWith #-} - lookAhead (Parser m) = Parser $ \eo ee _ ce l b8 d bs -> - m eo ee (\a e l' _ _ _ -> eo a e (l <> l') b8 d bs) ce l b8 d bs - {-# INLINE lookAhead #-} - -instance MonadCont (Parser r e) where - callCC f = Parser $ \ eo ee co ce l b8 d bs -> unparser (f (\a -> Parser $ \_ _ _ _ l' _ _ _ -> eo a mempty l' b8 d bs)) eo ee co ce l b8 d bs - -instance MonadMark Delta (Parser r e) where - mark = position - {-# INLINE mark #-} - release d' = Parser $ \_ ee co _ l b8 d bs -> do - mbs <- rewindIt d' - case mbs of - Just bs' -> co () mempty l (ascii bs') d' bs' - Nothing - | bytes d' == bytes (rewind d) + fromIntegral (Strict.length bs) -> if near d d' - then co () mempty l (ascii bs) d' bs - else co () mempty l True d' mempty - | otherwise -> ee mempty l b8 d bs - -data St e a = JuSt a !(ErrState e) !(ErrLog e) !Bool !Delta !ByteString - | NoSt !(ErrState e) !(ErrLog e) !Bool !Delta !ByteString - -stepParser :: (Diagnostic e -> Diagnostic t) -> - (ErrState e -> Highlights -> Bool -> Delta -> ByteString -> Diagnostic t) -> - (forall r. Parser r e a) -> ErrLog e -> Bool -> Delta -> ByteString -> Step t a -stepParser yl y (Parser p) l0 b80 d0 bs0 = - go mempty $ p ju no ju no l0 b80 d0 bs0 - where - ju a e l b8 d bs = Pure (JuSt a e l b8 d bs) - no e l b8 d bs = Pure (NoSt e l b8 d bs) - go r (Pure (JuSt a _ l _ _ _)) = StepDone r (yl . addHighlights (errHighlights l) <$> errLog l) a - go r (Pure (NoSt e l b8 d bs)) = StepFail r ((yl . addHighlights (errHighlights l) <$> errLog l) |> y e (errHighlights l) b8 d bs) - go r (It ma k) = StepCont r (case ma of - JuSt a _ l _ _ _ -> Success (yl . addHighlights (errHighlights l) <$> errLog l) a - NoSt e l b8 d bs -> Failure ((yl . addHighlights (errHighlights l) <$> errLog l) |> y e (errHighlights l) b8 d bs)) - (go <*> k) - -why :: Pretty e => (e -> Doc t) -> ErrState e -> Highlights -> Bool -> Delta -> ByteString -> Diagnostic (Doc t) -why pp (ErrState ss m) hs _ d bs - | Prelude.null now = explicateWith empty m - | knownErr m = explicateWith (char ',' <+> ex) m - | otherwise = Diagnostic rightHere Error ex notes - where - ex = expect now - ignoreBlanks = go . List.nub . List.sort where - go [] = [] - go [""] = ["space"] - go xs = List.filter (/= "") xs - expect xs = text "expected:" <+> fillSep (punctuate (char ',') (Prelude.map text $ ignoreBlanks $ Prelude.map extract xs)) - (now,later) = List.partition (\x -> errLoc m == Just (delta x)) $ toList ss - clusters = List.groupBy ((==) `on` delta) $ List.sortBy (compare `on` delta) later - diagnoseCluster c = Diagnostic (Right $ addHighlights hs $ renderingCaret dc bsc) Note (expect c) [] where - _ :^ Caret dc bsc = Prelude.head c - notes = Prelude.map diagnoseCluster clusters - rightHere = Right $ addHighlights hs $ renderingCaret d bs - - explicateWith x EmptyErr = Diagnostic rightHere Error ((text "unspecified error") <> x) notes - explicateWith x (FailErr r s) = Diagnostic (Right $ addHighlights hs r) Error ((fillSep $ text <$> words s) <> x) notes - explicateWith x (PanicErr r s) = Diagnostic (Right $ addHighlights hs r) Panic ((fillSep $ text <$> words s) <> x) notes - explicateWith x (Err (Diagnostic r l e es)) = Diagnostic (addHighlights hs <$> r) l (pp e <> x) (notes ++ fmap (addHighlights hs . fmap pp) es) - - errLoc EmptyErr = Just d - errLoc (FailErr r _) = Just $ delta r - errLoc (PanicErr r _) = Just $ delta r - errLoc (Err (Diagnostic (Left _) _ _ _)) = Nothing - errLoc (Err (Diagnostic (Right r) _ _ _)) = Just $ delta r diff --git a/src/Text/Trifecta/Parser/Result.hs b/src/Text/Trifecta/Parser/Result.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Result.hs +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Result --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Parser.Result - ( Result(..) - ) where - -import Control.Applicative -import Data.Semigroup -import Data.Foldable -import Data.Functor.Apply -import Data.Functor.Plus -import Data.Traversable -import Data.Bifunctor -import Data.Sequence as Seq -import Text.Trifecta.Diagnostic.Prim -import Text.PrettyPrint.Free -import System.Console.Terminfo.PrettyPrint - -data Result e a - = Success !(Seq (Diagnostic e)) a - | Failure !(Seq (Diagnostic e)) - deriving Show - -instance (Pretty e, Show a) => Pretty (Result e a) where - pretty (Success xs a) - | Seq.null xs = pretty (show a) - | otherwise = prettyList (toList xs) `above` pretty (show a) - pretty (Failure xs) = prettyList $ toList xs - -instance (PrettyTerm e, Show a) => PrettyTerm (Result e a) where - prettyTerm (Success xs a) - | Seq.null xs = pretty (show a) - | otherwise = prettyTermList (toList xs) `above` pretty (show a) - prettyTerm (Failure xs) = prettyTermList $ toList xs - -instance Functor (Result e) where - fmap f (Success xs a) = Success xs (f a) - fmap _ (Failure xs) = Failure xs - -instance Bifunctor Result where - bimap f g (Success xs a) = Success (fmap (fmap f) xs) (g a) - bimap f _ (Failure xs) = Failure (fmap (fmap f) xs) - -instance Foldable (Result e) where - foldMap f (Success _ a) = f a - foldMap _ (Failure _) = mempty - -instance Traversable (Result e) where - traverse f (Success xs a) = Success xs <$> f a - traverse _ (Failure xs) = pure $ Failure xs - -instance Applicative (Result e) where - pure = Success mempty - Success xs f <*> Success ys a = Success (xs <> ys) (f a) - Success xs _ <*> Failure ys = Failure (xs <> ys) - Failure xs <*> Success ys _ = Failure (xs <> ys) - Failure xs <*> Failure ys = Failure (xs <> ys) - -instance Apply (Result e) where - (<.>) = (<*>) - -instance Alt (Result e) where - Failure xs Failure ys = Failure (xs <> ys) - Success xs a Success ys _ = Success (xs <> ys) a - Success xs a Failure ys = Success (xs <> ys) a - Failure xs Success ys a = Success (xs <> ys) a - -instance Plus (Result e) where - zero = Failure mempty - -instance Alternative (Result e) where - (<|>) = () - empty = zero diff --git a/src/Text/Trifecta/Parser/Rich.hs b/src/Text/Trifecta/Parser/Rich.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Rich.hs +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Rich --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Parser.Rich - ( Rich - , rich - ) where - -import Control.Monad (liftM) -import Text.Trifecta.Layout -import Text.Trifecta.Language -import Text.Trifecta.Language.Prim -import Text.Trifecta.Literate - -type Rich m = Layout (Language (Literate m)) - -rich :: Monad m => LiterateState -> LanguageDef m -> Rich m a -> m (a, LiterateState) -rich lit def p = runLiterate (runLanguage (fst `liftM` runLayout p defaultLayoutState) (liftLanguageDef (liftLanguageDef def))) lit diff --git a/src/Text/Trifecta/Parser/Step.hs b/src/Text/Trifecta/Parser/Step.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Step.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Step --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Parser.Step - ( Step(..) - , feed - , starve - , stepResult - ) where - -import Data.Bifunctor -import Data.Semigroup.Reducer -import Data.Sequence -import Text.Trifecta.Rope.Prim -import Text.Trifecta.Diagnostic.Prim -import Text.Trifecta.Parser.Result - -data Step e a - = StepDone !Rope !(Seq (Diagnostic e)) a - | StepFail !Rope !(Seq (Diagnostic e)) - | StepCont !Rope (Result e a) (Rope -> Step e a) - -instance (Show e, Show a) => Show (Step e a) where - showsPrec d (StepDone r xs a) = showParen (d > 10) $ - showString "StepDone " . showsPrec 11 r . showChar ' ' . showsPrec 11 xs . 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 e) where - fmap f (StepDone r xs a) = StepDone r xs (f a) - fmap _ (StepFail r xs) = StepFail r xs - fmap f (StepCont r z k) = StepCont r (fmap f z) (fmap f . k) - -instance Bifunctor Step where - bimap f g (StepDone r xs a) = StepDone r (fmap (fmap f) xs) (g a) - bimap f _ (StepFail r xs) = StepFail r (fmap (fmap f) xs) - bimap f g (StepCont r z k) = StepCont r (bimap f g z) (bimap f g . k) - -feed :: Reducer t Rope => t -> Step e r -> Step e r -feed t (StepDone r xs a) = StepDone (snoc r t) xs a -feed t (StepFail r xs) = StepFail (snoc r t) xs -feed t (StepCont r _ k) = k (snoc r t) - -starve :: Step e a -> Result e a -starve (StepDone _ xs a) = Success xs a -starve (StepFail _ xs) = Failure xs -starve (StepCont _ z _) = z - -stepResult :: Rope -> Result e a -> Step e a -stepResult r (Success xs a) = StepDone r xs a -stepResult r (Failure xs) = StepFail r xs - diff --git a/src/Text/Trifecta/Parser/Token.hs b/src/Text/Trifecta/Parser/Token.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Token.hs +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Token --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Parser.Token - ( module Text.Trifecta.Parser.Token.Combinators - -- * Text.Trifecta.Parser.Token.Prim - , decimal - , hexadecimal - , octal - ) where - -import Text.Trifecta.Parser.Token.Prim -import Text.Trifecta.Parser.Token.Combinators - --- expected to be imported manually --- import Text.Trifecta.Parser.Token.Style diff --git a/src/Text/Trifecta/Parser/Token/Combinators.hs b/src/Text/Trifecta/Parser/Token/Combinators.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Token/Combinators.hs +++ /dev/null @@ -1,197 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Token.Combinators --- Copyright : (c) Edward Kmett 2011, --- (c) Daan Leijen 1999-2001 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : provisional --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Token.Combinators - ( lexeme - , charLiteral - , stringLiteral - , natural - , integer - , double - , naturalOrDouble - , symbol - , symbolic - , parens - , braces - , angles - , brackets - , comma - , colon - , dot - , semiSep - , semiSep1 - , commaSep - , commaSep1 - ) where - -import Data.ByteString as Strict hiding (map, zip, foldl, foldr) -import Control.Applicative -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Parser.Token.Prim -import Text.Trifecta.Highlight.Prim - --- | @lexeme p@ first applies parser @p@ and then the 'whiteSpace' --- parser, returning the value of @p@. Every lexical --- token (lexeme) is defined using @lexeme@, this way every parse --- starts at a point without white space. Parsers that use @lexeme@ are --- called /lexeme/ parsers in this document. --- --- The only point where the 'whiteSpace' parser should be --- called explicitly is the start of the main parser in order to skip --- any leading white space. --- --- > mainParser = do { whiteSpace --- > ; ds <- many (lexeme digit) --- > ; eof --- > ; return (sum ds) --- > } -lexeme :: MonadParser m => m a -> m a -lexeme p = p <* whiteSpace - --- | This lexeme parser parses a single literal character. Returns the --- literal character value. This parsers deals correctly with escape --- sequences. The literal character is parsed according to the grammar --- rules defined in the Haskell report (which matches most programming --- languages quite closely). -charLiteral :: MonadParser m => m Char -charLiteral = lexeme charLiteral' - --- | This lexeme parser parses a literal string. Returns the literal --- string value. This parsers deals correctly with escape sequences and --- gaps. The literal string is parsed according to the grammar rules --- defined in the Haskell report (which matches most programming --- languages quite closely). - -stringLiteral :: MonadParser m => m String -stringLiteral = lexeme stringLiteral' - --- | This lexeme parser parses a natural number (a positive whole --- number). Returns the value of the number. The number can be --- specified in 'decimal', 'hexadecimal' or --- 'octal'. The number is parsed according to the grammar --- rules in the Haskell report. - -natural :: MonadParser m => m Integer -natural = lexeme natural' - --- | This lexeme parser parses an integer (a whole number). This parser --- is like 'natural' except that it can be prefixed with --- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The --- number can be specified in 'decimal', 'hexadecimal' --- or 'octal'. The number is parsed according --- to the grammar rules in the Haskell report. - -integer :: MonadParser m => m Integer -integer = lexeme int "integer" - where - sign = negate <$ char '-' - <|> id <$ char '+' - <|> pure id - int = lexeme (highlight Operator sign) <*> natural' - --- | This lexeme parser parses a floating point value. Returns the value --- of the number. The number is parsed according to the grammar rules --- defined in the Haskell report. - -double :: MonadParser m => m Double -double = lexeme double' - --- | This lexeme parser parses either 'natural' or a 'float'. --- Returns the value of the number. This parsers deals with --- any overlap in the grammar rules for naturals and floats. The number --- is parsed according to the grammar rules defined in the Haskell report. - -naturalOrDouble :: MonadParser m => m (Either Integer Double) -naturalOrDouble = lexeme naturalOrDouble' - --- | Lexeme parser @symbol s@ parses 'string' @s@ and skips --- trailing white space. - -symbol :: MonadParser m => ByteString -> m ByteString -symbol name = lexeme (highlight Symbol (byteString name)) - --- | Lexeme parser @symbolic s@ parses 'char' @s@ and skips --- trailing white space. - -symbolic :: MonadParser m => Char -> m Char -symbolic name = lexeme (highlight Symbol (char name)) - --- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis, --- returning the value of @p@. - -parens :: MonadParser m => m a -> m a -parens = nesting . between (symbolic '(') (symbolic ')') - --- | Lexeme parser @braces p@ parses @p@ enclosed in braces (\'{\' and --- \'}\'), returning the value of @p@. - -braces :: MonadParser m => m a -> m a -braces = nesting . between (symbolic '{') (symbolic '}') - --- | Lexeme parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\' --- and \'>\'), returning the value of @p@. - -angles :: MonadParser m => m a -> m a -angles = nesting . between (symbolic '<') (symbolic '>') - --- | Lexeme parser @brackets p@ parses @p@ enclosed in brackets (\'[\' --- and \']\'), returning the value of @p@. - -brackets :: MonadParser m => m a -> m a -brackets = nesting . between (symbolic '[') (symbolic ']') - --- | Lexeme parser @comma@ parses the character \',\' and skips any --- trailing white space. Returns the string \",\". - -comma :: MonadParser m => m Char -comma = symbolic ',' - --- | Lexeme parser @colon@ parses the character \':\' and skips any --- trailing white space. Returns the string \":\". - -colon :: MonadParser m => m Char -colon = symbolic ':' - --- | Lexeme parser @dot@ parses the character \'.\' and skips any --- trailing white space. Returns the string \".\". - -dot :: MonadParser m => m Char -dot = symbolic '.' - --- | Lexeme parser @semiSep p@ parses /zero/ or more occurrences of @p@ --- separated by 'semi'. Returns a list of values returned by --- @p@. - -semiSep :: MonadParser m => m a -> m [a] -semiSep p = sepBy p semi - --- | Lexeme parser @semiSep1 p@ parses /one/ or more occurrences of @p@ --- separated by 'semi'. Returns a list of values returned by @p@. - -semiSep1 :: MonadParser m => m a -> m [a] -semiSep1 p = sepBy1 p semi - --- | Lexeme parser @commaSep p@ parses /zero/ or more occurrences of --- @p@ separated by 'comma'. Returns a list of values returned --- by @p@. - -commaSep :: MonadParser m => m a -> m [a] -commaSep p = sepBy p comma - --- | Lexeme parser @commaSep1 p@ parses /one/ or more occurrences of --- @p@ separated by 'comma'. Returns a list of values returned --- by @p@. - -commaSep1 :: MonadParser m => m a -> m [a] -commaSep1 p = sepBy p comma diff --git a/src/Text/Trifecta/Parser/Token/Prim.hs b/src/Text/Trifecta/Parser/Token/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Token/Prim.hs +++ /dev/null @@ -1,217 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Token.Prim --- Copyright : (c) Edward Kmett 2011, --- (c) Daan Leijen 1999-2001 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : provisional --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Token.Prim - ( charLiteral' - , characterChar - , stringLiteral' - , natural' - , integer' - , double' - , naturalOrDouble' - , decimal - , hexadecimal - , octal - ) where - -import Data.Char (digitToInt) -import Data.Foldable -import Control.Applicative -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Highlight.Prim - --- | This parser parses a single literal character. Returns the --- literal character value. This parsers deals correctly with escape --- sequences. The literal character is parsed according to the grammar --- rules defined in the Haskell report (which matches most programming --- languages quite closely). --- --- This parser does NOT swallow trailing whitespace. -charLiteral' :: MonadParser m => m Char -charLiteral' = highlight CharLiteral (between (char '\'') (char '\'' "end of character") characterChar) - "character" - -characterChar, charEscape, charLetter :: MonadParser m => m Char -characterChar = charLetter <|> charEscape - "literal character" -charEscape = highlight EscapeCode $ char '\\' *> escapeCode -charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) - --- | This parser parses a literal string. Returns the literal --- string value. This parsers deals correctly with escape sequences and --- gaps. The literal string is parsed according to the grammar rules --- defined in the Haskell report (which matches most programming --- languages quite closely). --- --- This parser does NOT swallow trailing whitespace -stringLiteral' :: MonadParser m => m String -stringLiteral' = highlight StringLiteral lit where - lit = Prelude.foldr (maybe id (:)) "" <$> between (char '"') (char '"' "end of string") (many stringChar) - "literal string" - stringChar = Just <$> stringLetter - <|> stringEscape - "string character" - stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - - stringEscape = highlight EscapeCode $ char '\\' *> esc where - esc = Nothing <$ escapeGap - <|> Nothing <$ escapeEmpty - <|> Just <$> escapeCode - escapeEmpty = char '&' - escapeGap = do skipSome space - char '\\' "end of string gap" - -escapeCode :: MonadParser m => m Char -escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) "escape code" - where - charControl = (\c -> toEnum (fromEnum c - fromEnum 'A')) <$> (char '^' *> upper) - charNum = toEnum . fromInteger <$> num where - num = decimal - <|> (char 'o' *> number 8 octDigit) - <|> (char 'x' *> number 16 hexDigit) - charEsc = choice $ parseEsc <$> escMap - parseEsc (c,code) = code <$ char c - escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") - charAscii = choice $ parseAscii <$> asciiMap - parseAscii (asc,code) = try $ code <$ string asc - asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - ascii2codes, ascii3codes :: [String] - ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" - , "SI","EM","FS","GS","RS","US","SP"] - ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" - ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" - ,"SYN","ETB","CAN","SUB","ESC","DEL"] - ascii2, ascii3 :: [Char] - ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI' - ,'\EM','\FS','\GS','\RS','\US','\SP'] - ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK' - ,'\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK' - ,'\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] - - --- | This parser parses a natural number (a positive whole --- number). Returns the value of the number. The number can be --- specified in 'decimal', 'hexadecimal' or --- 'octal'. The number is parsed according to the grammar --- rules in the Haskell report. --- --- This parser does NOT swallow trailing whitespace. -natural' :: MonadParser m => m Integer -natural' = highlight Number nat "natural" - -number :: MonadParser m => Integer -> m Char -> m Integer -number base baseDigit = do - digits <- some baseDigit - return $! foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits - --- | This parser parses an integer (a whole number). This parser --- is like 'natural' except that it can be prefixed with --- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The --- number can be specified in 'decimal', 'hexadecimal' --- or 'octal'. The number is parsed according --- to the grammar rules in the Haskell report. --- --- This parser does NOT swallow trailing whitespace. --- --- Also, unlike the 'integer' parser, this parser does not admit spaces --- between the sign and the number. - -integer' :: MonadParser m => m Integer -integer' = int "integer" - -sign :: MonadParser m => m (Integer -> Integer) -sign = highlight Operator - $ negate <$ char '-' - <|> id <$ char '+' - <|> pure id - -int :: MonadParser m => m Integer -int = {-lexeme-} sign <*> highlight Number nat -nat, zeroNumber :: MonadParser m => m Integer -nat = zeroNumber <|> decimal -zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> return 0) "" - --- | This parser parses a floating point value. Returns the value --- of the number. The number is parsed according to the grammar rules --- defined in the Haskell report. --- --- This parser does NOT swallow trailing whitespace. - -double' :: MonadParser m => m Double -double' = highlight Number floating "double" - -floating :: MonadParser m => m Double -floating = decimal >>= fractExponent - -fractExponent :: MonadParser m => Integer -> m Double -fractExponent n = (\fract expo -> (fromInteger n + fract) * expo) <$> fraction <*> option 1.0 exponent' - <|> (fromInteger n *) <$> exponent' where - fraction = Prelude.foldr op 0.0 <$> (char '.' *> (some digit "fraction")) - op d f = (f + fromIntegral (digitToInt d))/10.0 - exponent' = do - _ <- oneOf "eE" - f <- sign - e <- decimal "exponent" - return (power (f e)) - "exponent" - power e - | e < 0 = 1.0/power(-e) - | otherwise = fromInteger (10^e) - - --- | This parser parses either 'natural' or a 'double'. --- Returns the value of the number. This parsers deals with --- any overlap in the grammar rules for naturals and floats. The number --- is parsed according to the grammar rules defined in the Haskell report. --- --- This parser does NOT swallow trailing whitespace. - -naturalOrDouble' :: MonadParser m => m (Either Integer Double) -naturalOrDouble' = highlight Number natDouble "number" - -natDouble, zeroNumFloat, decimalFloat :: MonadParser m => m (Either Integer Double) -natDouble - = char '0' *> zeroNumFloat - <|> decimalFloat -zeroNumFloat - = Left <$> (hexadecimal <|> octal) - <|> decimalFloat - <|> fractFloat 0 - <|> return (Left 0) -decimalFloat = do - n <- decimal - option (Left n) (fractFloat n) - -fractFloat :: MonadParser m => Integer -> m (Either Integer Double) -fractFloat n = Right <$> fractExponent n - --- | Parses a positive whole number in the decimal system. Returns the --- value of the number. - -decimal :: MonadParser m => m Integer -decimal = number 10 digit - --- | Parses a positive whole number in the hexadecimal system. The number --- should be prefixed with \"x\" or \"X\". Returns the value of the --- number. - -hexadecimal :: MonadParser m => m Integer -hexadecimal = oneOf "xX" *> number 16 hexDigit - --- | Parses a positive whole number in the octal system. The number --- should be prefixed with \"o\" or \"O\". Returns the value of the --- number. - -octal :: MonadParser m => m Integer -octal = oneOf "oO" *> number 8 octDigit diff --git a/src/Text/Trifecta/Parser/Token/Style.hs b/src/Text/Trifecta/Parser/Token/Style.hs deleted file mode 100644 --- a/src/Text/Trifecta/Parser/Token/Style.hs +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Parser.Token.Style --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : provisional --- Portability : non-portable --- ------------------------------------------------------------------------------ -module Text.Trifecta.Parser.Token.Style - ( CommentStyle(..) - , emptyCommentStyle - , javaCommentStyle - , haskellCommentStyle - , buildSomeSpaceParser - ) where - -import Control.Applicative -import Data.List (nub) -import qualified Data.ByteString.Char8 as B -import Text.Trifecta.Parser.Class -import Text.Trifecta.Parser.Char -import Text.Trifecta.Parser.Combinators -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Highlight.Prim - -data CommentStyle = CommentStyle - { commentStart :: String - , commentEnd :: String - , commentLine :: String - , commentNesting :: Bool - } - -emptyCommentStyle, javaCommentStyle, haskellCommentStyle :: CommentStyle -emptyCommentStyle = CommentStyle "" "" "" True -javaCommentStyle = CommentStyle "/*" "*/" "//" True -haskellCommentStyle = CommentStyle "{-" "-}" "--" True - --- | Use this to easily build the definition of whiteSpace for your MonadParser --- given a comment style and an underlying someWhiteSpace parser -buildSomeSpaceParser :: MonadParser m => m () -> CommentStyle -> m () -buildSomeSpaceParser simpleSpace (CommentStyle startStyle endStyle lineStyle nestingStyle) - | noLine && noMulti = skipSome (simpleSpace "") - | noLine = skipSome (simpleSpace <|> multiLineComment "") - | noMulti = skipSome (simpleSpace <|> oneLineComment "") - | otherwise = skipSome (simpleSpace <|> oneLineComment <|> multiLineComment "") - where - noLine = null lineStyle - noMulti = null startStyle - oneLineComment = highlight Comment $ do - _ <- try $ string lineStyle - r <- restOfLine - let b = B.length r - skipping $ if b /= 0 && B.last r == '\n' then Lines 1 0 (fromIntegral b) 0 else delta r - multiLineComment = highlight Comment $ do - _ <- try $ string startStyle - inComment - inComment - | nestingStyle = inCommentMulti - | otherwise = inCommentSingle - inCommentMulti - = () <$ try (string endStyle) - <|> multiLineComment *> inCommentMulti - <|> skipSome (noneOf startEnd) *> inCommentMulti - <|> oneOf startEnd *> inCommentMulti - "end of comment" - startEnd = nub (endStyle ++ startStyle) - inCommentSingle - = () <$ try (string endStyle) - <|> skipSome (noneOf startEnd) *> inCommentSingle - <|> oneOf startEnd *> inCommentSingle - "end of comment" diff --git a/src/Text/Trifecta/Rendering.hs b/src/Text/Trifecta/Rendering.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Rendering.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Trifecta.Rendering +-- Copyright : (C) 2011-2013 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 diff --git a/src/Text/Trifecta/Result.hs b/src/Text/Trifecta/Result.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Result.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Trifecta.Result +-- Copyright : (c) Edward Kmett 2011-2013 +-- 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(..) + , explain + , failing + ) 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.Sequence as Seq hiding (empty) +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 Err = Err + { _reason :: Maybe Doc + , _footnotes :: [Doc] + , _expected :: Set String + } + +makeClassy ''Err + +instance Semigroup Err where + Err md mds mes <> Err nd nds nes + = Err (nd <|> md) (if isJust nd then nds else if isJust md then mds else nds ++ mds) (mes <> nes) + +instance Monoid Err where + mempty = Err Nothing [] mempty + mappend = (<>) + +failing :: String -> Err +failing m = Err (Just (fillSep (pretty <$> words m))) [] mempty + +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 $ List.nub $ 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 + +data Result a + = Success a + | Failure Doc + deriving (Show,Functor,Foldable,Traversable) + +class AsResult p f s t a b | s -> a, t -> b, s b -> t, t a -> s where + _Result :: Overloaded p f s t (Result a) (Result b) + +instance AsResult p f (Result a) (Result b) a b where + _Result = id + {-# INLINE _Result #-} + +_Success :: (AsResult p f s t a b, Choice p, Applicative f) => Overloaded p f s t a b +_Success = _Result . dimap seta (either id id) . right' . rmap (fmap Success) where + seta (Success a) = Right a + seta (Failure d) = Left (pure (Failure d)) +{-# INLINE _Success #-} + +_Failure :: (AsResult p f s s a a, Choice p, Applicative f) => Overloaded' p f s Doc +_Failure = _Result . dimap seta (either id id) . right' . rmap (fmap Failure) where + seta (Failure d) = Right d + 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 xs + +instance Applicative Result where + pure = Success + {-# INLINE pure #-} + Success f <*> Success a = Success (f a) + Success _ <*> Failure ys = Failure ys + Failure xs <*> Success _ = Failure xs + Failure xs <*> Failure ys = Failure $ vsep [xs, ys] + {-# INLINE (<*>) #-} + +instance Alternative Result where + Failure xs <|> Failure ys = Failure $ vsep [xs, ys] + Success a <|> Success _ = Success a + Success a <|> Failure _ = Success a + Failure _ <|> Success a = Success a + {-# INLINE (<|>) #-} + empty = Failure mempty + {-# INLINE empty #-} 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,7 +1,8 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards, DeriveDataTypeable, DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Rope --- Copyright : (C) 2011 Edward Kmett, +-- Copyright : (C) 2011-2013 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -9,18 +10,104 @@ -- Portability : non-portable -- ---------------------------------------------------------------------------- -module Text.Trifecta.Rope - ( Rope, rope, strands - -- * Strands of a rope - , Strand(..), strand - -- * Properties - , Delta(..) - , HasDelta(..) - , HasBytes(..) - , HighlightedRope(..) +module Text.Trifecta.Rope + ( Rope(..) + , rope + , Strand(..) + , strand + , strands + , grabRest + , grabLine ) where -import Text.Trifecta.Rope.Prim -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Highlighted +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 Data.Int (Int64) +import Text.Trifecta.Util.Combinators as Util +import Text.Trifecta.Delta +import Data.Data + +data Strand + = Strand {-# UNPACK #-} !ByteString !Delta + | LineDirective {-# UNPACK #-} !ByteString {-# UNPACK #-} !Int64 + 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 (LineDirective p l) = delta (Directed p l 0 0 0) + +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 diff --git a/src/Text/Trifecta/Rope/Bytes.hs b/src/Text/Trifecta/Rope/Bytes.hs deleted file mode 100644 --- a/src/Text/Trifecta/Rope/Bytes.hs +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Rope.Bytes --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Rope.Bytes - ( HasBytes(..) - ) where - -import Data.ByteString as Strict -import Data.FingerTree -import Data.Int (Int64) - -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 diff --git a/src/Text/Trifecta/Rope/Delta.hs b/src/Text/Trifecta/Rope/Delta.hs deleted file mode 100644 --- a/src/Text/Trifecta/Rope/Delta.hs +++ /dev/null @@ -1,169 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Rope.Delta --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Rope.Delta - ( Delta(..) - , HasDelta(..) - , nextTab - , rewind - , near - , column - , columnByte - ) where - -import Control.Applicative -import Data.Semigroup -import Data.Hashable -import Data.Int -import Data.Word -import Data.Foldable -import Data.Function (on) -import Data.FingerTree hiding (empty) -import Data.ByteString hiding (empty) -import qualified Data.ByteString.UTF8 as UTF8 -import Text.Trifecta.Rope.Bytes -import Text.PrettyPrint.Free hiding (column) -import System.Console.Terminfo.PrettyPrint - -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 - -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 p = prettyTerm p *> empty - -instance PrettyTerm Delta where - prettyTerm 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 e -int64 = pretty . show - -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 #-} - -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 where - hash (Columns c a) = 0 `hashWithSalt` c `hashWithSalt` a - hash (Tab x y a) = 1 `hashWithSalt` x `hashWithSalt` y `hashWithSalt` a - hash (Lines l c b a) = 2 `hashWithSalt` l `hashWithSalt` c `hashWithSalt` b `hashWithSalt` a - hash (Directed p l c b a) = 3 `hashWithSalt` p `hashWithSalt` l `hashWithSalt` c `hashWithSalt` b `hashWithSalt` a - -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 - -nextTab :: Int64 -> Int64 -nextTab x = x + (8 - mod x 8) -{-# INLINE nextTab #-} - -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 #-} - -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 diff --git a/src/Text/Trifecta/Rope/Highlighted.hs b/src/Text/Trifecta/Rope/Highlighted.hs deleted file mode 100644 --- a/src/Text/Trifecta/Rope/Highlighted.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Rope.Highlighted --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Rope.Highlighted - ( HighlightedRope(..) - ) where - -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 -import Data.Foldable as F -import Data.Int (Int64) -import Text.Trifecta.IntervalMap as IM -import Data.Key hiding ((!)) -import Data.List (sort) -import Data.Semigroup -import Data.Semigroup.Union -import Prelude hiding (head) -import System.Console.Terminfo.PrettyPrint -import Text.Blaze -import Text.Blaze.Internal -import Text.Blaze.Html5 hiding (b,i) -import Text.Blaze.Html5.Attributes hiding (title) -import Text.Trifecta.Rope.Delta -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Prim -import Text.Trifecta.Highlight.Class -import Text.Trifecta.Highlight.Effects -import Text.Trifecta.Highlight.Prim -import Text.PrettyPrint.Free - -data HighlightedRope = HighlightedRope - { ropeHighlights :: !Highlights - , ropeContent :: {-# UNPACK #-} !Rope - } - -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 - -instance Highlightable HighlightedRope where - addHighlights h (HighlightedRope h' r) = HighlightedRope (h `union` h') r - -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 ToHtml HighlightedRope where - toHtml (HighlightedRope intervals r) = pre $ go 0 lbs effects where - lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)] - ln no = 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 - , preEscapedString "" :@ bytes hi - ] - ] ++ mapWithKey (\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 _ r) = hsep $ [ pretty bs | Strand bs _ <- F.toList (strands r)] - -instance PrettyTerm HighlightedRope where - prettyTerm (HighlightedRope intervals r) = go 0 lbs effects where - lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)] - effects = sort $ [ i | (Interval lo hi, tok) <- intersections mempty (delta r) intervals - , i <- [ pushToken tok :@ bytes lo - , popToken tok :@ bytes hi - ] - ] - go _ cs [] = prettyTerm (LazyUTF8.toString cs) - go b cs ((eff :@ eb) : es) - | eb <= b = eff <> go b cs es - | otherwise = prettyTerm (LazyUTF8.toString om) <> go eb nom es - where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs diff --git a/src/Text/Trifecta/Rope/Prim.hs b/src/Text/Trifecta/Rope/Prim.hs deleted file mode 100644 --- a/src/Text/Trifecta/Rope/Prim.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Text.Trifecta.Rope.Prim --- Copyright : (C) 2011 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- -module Text.Trifecta.Rope.Prim - ( 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 Data.Foldable (toList) -import Data.Hashable -import Data.Int (Int64) -import Text.Trifecta.Util.Combinators as Util -import Text.Trifecta.Rope.Bytes -import Text.Trifecta.Rope.Delta - -data Strand - = Strand {-# UNPACK #-} !ByteString !Delta - | LineDirective {-# UNPACK #-} !ByteString {-# UNPACK #-} !Int64 - deriving Show - -strand :: ByteString -> Strand -strand bs = Strand bs (delta bs) - -instance Measured Delta Strand where - measure (Strand _ s) = delta s - measure (LineDirective p l) = delta (Directed p l 0 0 0) - -instance Hashable Strand where - hash (Strand h _) = hashWithSalt 0 h - hash (LineDirective p l) = hash l `hashWithSalt` p - -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 diff --git a/src/Text/Trifecta/Util/Array.hs b/src/Text/Trifecta/Util/Array.hs --- a/src/Text/Trifecta/Util/Array.hs +++ b/src/Text/Trifecta/Util/Array.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.Array --- Copyright : Edward Kmett 2011 +-- Copyright : Edward Kmett 2011-2013 -- Johan Tibell 2011 -- License : BSD3 -- 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,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Util.Combinators --- Copyright : (C) 2011 Edward Kmett, +-- Copyright : (C) 2011-2013 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett diff --git a/src/Text/Trifecta/Util/IntervalMap.hs b/src/Text/Trifecta/Util/IntervalMap.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Util/IntervalMap.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Trifecta.Util.IntervalMap +-- Copyright : (c) Edward Kmett 2011-2013 +-- (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 + +import Control.Applicative hiding (empty) +import Control.Lens hiding ((<|),(|>)) +import qualified Data.FingerTree as FT +import Data.FingerTree (FingerTree, Measured(..), ViewL(..), (<|), (><)) +import Data.Foldable (Foldable(foldMap)) +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 + diff --git a/src/Text/Trifecta/Util/It.hs b/src/Text/Trifecta/Util/It.hs new file mode 100644 --- /dev/null +++ b/src/Text/Trifecta/Util/It.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Trifecta.Util.It +-- Copyright : (C) 2011-2013 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 + +import Control.Applicative +import Control.Comonad +import Control.Monad +import Data.Semigroup +import Data.ByteString as Strict +import Data.ByteString.Lazy as Lazy +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 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 diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,30 @@ +module Main where + +import Build_doctests (deps) +import Control.Applicative +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" + : "-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 diff --git a/trifecta.cabal b/trifecta.cabal --- a/trifecta.cabal +++ b/trifecta.cabal @@ -1,122 +1,86 @@ name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging -version: 0.53 +version: 1.0 license: BSD3 -cabal-version: >= 1.6 +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-2011 Edward A. Kmett +copyright: Copyright (C) 2010-2013 Edward A. Kmett synopsis: A modern parser combinator library with convenient diagnostics description: - A modern unicode-aware parser combinator library with slicing and Clang-style colored diagnostics + A modern parser combinator library with slicing and Clang-style colored diagnostics -build-type: Simple +build-type: Custom -extra-source-files: examples/RFC2616.hs .travis.yml +extra-source-files: examples/RFC2616.hs .travis.yml README.markdown source-repository head type: git location: git://github.com/ekmett/trifecta.git library - hs-source-dirs: src - exposed-modules: Text.Trifecta - Text.Trifecta.IntervalMap - Text.Trifecta.Rope - Text.Trifecta.Rope.Bytes - Text.Trifecta.Rope.Delta - Text.Trifecta.Rope.Prim - Text.Trifecta.Rope.Highlighted - Text.Trifecta.Diagnostic - Text.Trifecta.Diagnostic.Prim - Text.Trifecta.Diagnostic.Class - Text.Trifecta.Diagnostic.Combinators - Text.Trifecta.Diagnostic.Level - Text.Trifecta.Diagnostic.Err - Text.Trifecta.Diagnostic.Err.Log - Text.Trifecta.Diagnostic.Err.State - Text.Trifecta.Diagnostic.Rendering - Text.Trifecta.Diagnostic.Rendering.Prim - Text.Trifecta.Diagnostic.Rendering.Caret - Text.Trifecta.Diagnostic.Rendering.Fixit - Text.Trifecta.Diagnostic.Rendering.Span + Text.Trifecta.Combinators + Text.Trifecta.Delta Text.Trifecta.Highlight - Text.Trifecta.Highlight.Class - Text.Trifecta.Highlight.Prim - Text.Trifecta.Highlight.Effects - Text.Trifecta.Highlight.Rendering.HTML - Text.Trifecta.Language - Text.Trifecta.Language.Class - Text.Trifecta.Language.Combinators - Text.Trifecta.Language.Prim - Text.Trifecta.Language.Monad - Text.Trifecta.Language.Style - Text.Trifecta.Layout - Text.Trifecta.Layout.Class - Text.Trifecta.Layout.Combinators - Text.Trifecta.Layout.Monad - Text.Trifecta.Layout.Prim - Text.Trifecta.Literate - Text.Trifecta.Literate.Class - Text.Trifecta.Literate.Prim - Text.Trifecta.Literate.Combinators - Text.Trifecta.Literate.Monad Text.Trifecta.Parser - Text.Trifecta.Parser.ByteString - Text.Trifecta.Parser.Char - Text.Trifecta.Parser.Char8 - Text.Trifecta.Parser.Class - Text.Trifecta.Parser.Combinators - Text.Trifecta.Parser.Expr - Text.Trifecta.Parser.It - Text.Trifecta.Parser.Mark - Text.Trifecta.Parser.Perm - Text.Trifecta.Parser.Prim - Text.Trifecta.Parser.Result - Text.Trifecta.Parser.Rich - Text.Trifecta.Parser.Step - Text.Trifecta.Parser.Token - Text.Trifecta.Parser.Token.Combinators - Text.Trifecta.Parser.Token.Prim - Text.Trifecta.Parser.Token.Style - Text.Trifecta.Parser.Identifier - Text.Trifecta.Parser.Identifier.Style + 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 - ghc-options: -Wall - build-depends: - base == 4.*, + ansi-wl-pprint >= 0.6.6 && < 0.7, + ansi-terminal >= 0.6 && < 0.7, array >= 0.3.0.2 && < 0.5, - charset >= 0.3.2.1 && < 0.4, - containers >= 0.3 && < 0.6, - unordered-containers >= 0.2.1 && < 0.3, + base >= 4.4 && < 5, blaze-builder >= 0.3.0.1 && < 0.4, - blaze-html >= 0.4.1.6 && < 0.5, - bifunctors == 3.0.*, - deepseq >= 1.2.0.1 && < 1.4, - hashable >= 1.1.2.1 && < 1.2, + blaze-html >= 0.5 && < 0.6, + blaze-markup >= 0.5 && < 0.6, bytestring >= 0.9.1 && < 0.11, - mtl >= 2.0.1 && < 2.2, - semigroups >= 0.8.3.1 && < 0.9, + charset >= 0.3.2.1 && < 1, + comonad == 3.*, + containers >= 0.3 && < 0.6, + deepseq >= 1.2.0.1 && < 1.4, fingertree >= 0.0.1 && < 0.1, - reducers == 3.0.*, - profunctors == 3.0.*, - utf8-string >= 0.3.6 && < 0.4, - semigroupoids == 3.0.*, - pointed == 3.0.*, + ghc-prim, + hashable >= 1.2 && < 1.3, + lens >= 3.8.2 && < 4, + mtl >= 2.0.1 && < 2.2, + parsers >= 0.5 && < 1, + reducers == 3.*, + semigroups >= 0.8.3.1 && < 1, transformers >= 0.2 && < 0.4, - comonad == 3.0.*, - terminfo >= 0.3.2 && < 0.4, - keys == 3.0.*, - wl-pprint-extras == 3.0.*, - wl-pprint-terminfo == 3.0.* + unordered-containers >= 0.2.1 && < 0.3, + utf8-string >= 0.3.6 && < 0.4 + + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -O2 -threaded -Wall + + +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 + + if impl(ghc<7.6.1) + ghc-options: -Werror