packages feed

trifecta 0.53 → 1.0

raw patch · 77 files changed

+2121/−5666 lines, 77 filesdep +ansi-terminaldep +ansi-wl-pprintdep +blaze-markupdep −bifunctorsdep −keysdep −pointeddep ~basedep ~blaze-htmldep ~charsetbuild-type:Customsetup-changed

Dependencies added: ansi-terminal, ansi-wl-pprint, blaze-markup, directory, doctest, filepath, ghc-prim, lens, parsers

Dependencies removed: bifunctors, keys, pointed, profunctors, semigroupoids, terminfo, wl-pprint-extras, wl-pprint-terminfo

Dependency ranges changed: base, blaze-html, charset, comonad, hashable, reducers, semigroups

Files

.travis.yml view
@@ -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"
LICENSE view
@@ -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
+ README.markdown view
@@ -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
Setup.lhs view
@@ -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}
examples/RFC2616.hs view
@@ -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
src/Text/Trifecta.hs view
@@ -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 <ekmett@gmail.com>@@ -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
+ src/Text/Trifecta/Combinators.hs view
@@ -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 #-}
+ src/Text/Trifecta/Delta.hs view
@@ -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 <ekmett@gmail.com>+-- 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
− src/Text/Trifecta/Diagnostic.hs 
@@ -1,40 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Diagnostic--- Copyright   :  (C) 2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Diagnostic/Class.hs 
@@ -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 <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Diagnostic/Combinators.hs 
@@ -1,57 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Diagnostic.Combinators--- Copyright   :  (C) 2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Diagnostic/Err.hs 
@@ -1,87 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Diagnostic.Err--- Copyright   :  (C) 2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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 = (<!>)
− src/Text/Trifecta/Diagnostic/Err/Log.hs 
@@ -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 <ekmett@gmail.com>--- 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 = (<!>)
− src/Text/Trifecta/Diagnostic/Err/State.hs 
@@ -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 <ekmett@gmail.com>--- 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 = (<!>)
− src/Text/Trifecta/Diagnostic/Level.hs 
@@ -1,66 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Diagnostic.Level--- Copyright   :  (C) 2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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"
− src/Text/Trifecta/Diagnostic/Prim.hs 
@@ -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 <ekmett@gmail.com>--- 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)
− src/Text/Trifecta/Diagnostic/Rendering.hs 
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Diagnostic.Rendering--- Copyright   :  (C) 2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Diagnostic/Rendering/Caret.hs 
@@ -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 <ekmett@gmail.com>--- 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-
− src/Text/Trifecta/Diagnostic/Rendering/Fixit.hs 
@@ -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 <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Diagnostic/Rendering/Prim.hs 
@@ -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 <ekmett@gmail.com>--- 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 = "<EOF>"-      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
− src/Text/Trifecta/Diagnostic/Rendering/Span.hs 
@@ -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 <ekmett@gmail.com>--- 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
src/Text/Trifecta/Highlight.hs view
@@ -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 <ekmett@gmail.com>@@ -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" "<span" ">" ! class_ (toValue $ show tok)) :@ bytes lo+                            , preEscapedString "</span>" :@ 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 "<!-- Generated by trifecta, http://github.com/ekmett/trifecta/ -->\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+-}
− src/Text/Trifecta/Highlight/Class.hs 
@@ -1,19 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Highlight.Class--- Copyright   :  (C) 2011 Edward Kmett,--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Highlight/Effects.hs 
@@ -1,44 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Highlight.Effects--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Highlight/Prim.hs 
@@ -1,47 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Highlight.Prim--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Highlight/Rendering/HTML.hs 
@@ -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 <ekmett@gmail.com>--- 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 "<!-- Generated by trifecta, http://github.com/ekmett/trifecta/ -->\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)
+ src/Text/Trifecta/Instances.hs view
@@ -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+  (<>) = (<>)
− src/Text/Trifecta/IntervalMap.hs 
@@ -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.---      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>------ 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-
− src/Text/Trifecta/Language.hs 
@@ -1,34 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Language--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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-
− src/Text/Trifecta/Language/Class.hs 
@@ -1,59 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Language.Class--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Language/Combinators.hs 
@@ -1,42 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Language.Combinators--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Language/Monad.hs 
@@ -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 <ekmett@gmail.com>--- 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)
− src/Text/Trifecta/Language/Prim.hs 
@@ -1,28 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Language.Prim--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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)
− src/Text/Trifecta/Language/Style.hs 
@@ -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
− src/Text/Trifecta/Layout.hs 
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Parser.Layout--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Layout/Class.hs 
@@ -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 <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Layout/Combinators.hs 
@@ -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 <ekmett@gmail.com>--- 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)-
− src/Text/Trifecta/Layout/Monad.hs 
@@ -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 <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Layout/Prim.hs 
@@ -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 <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Literate.hs 
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Parser.Literate--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Literate/Class.hs 
@@ -1,54 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Literate.Class--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Literate/Combinators.hs 
@@ -1,85 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Literate.Combinators--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Literate/Monad.hs 
@@ -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 <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Literate/Prim.hs 
@@ -1,60 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Literate.Prim--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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)
src/Text/Trifecta/Parser.hs view
@@ -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 <ekmett@gmail.com>+-- 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)
− src/Text/Trifecta/Parser/ByteString.hs 
@@ -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-
− src/Text/Trifecta/Parser/Char.hs 
@@ -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 <ekmett@gmail.com>--- 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)
− src/Text/Trifecta/Parser/Char8.hs 
@@ -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)
− src/Text/Trifecta/Parser/Class.hs 
@@ -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 #-}
− src/Text/Trifecta/Parser/Combinators.hs 
@@ -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 "<!--"--- >                      ; manyTill anyChar (try (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 ())
− src/Text/Trifecta/Parser/Expr.hs 
@@ -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)
− src/Text/Trifecta/Parser/Identifier.hs 
@@ -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
− src/Text/Trifecta/Parser/Identifier/Style.hs 
@@ -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"-  ]
− src/Text/Trifecta/Parser/It.hs 
@@ -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 <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Parser/Mark.hs 
@@ -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-
− src/Text/Trifecta/Parser/Perm.hs 
@@ -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'
− src/Text/Trifecta/Parser/Prim.hs 
@@ -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
− src/Text/Trifecta/Parser/Result.hs 
@@ -1,82 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Parser.Result--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Parser/Rich.hs 
@@ -1,26 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Parser.Rich--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Parser/Step.hs 
@@ -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 <ekmett@gmail.com>--- 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-
− src/Text/Trifecta/Parser/Token.hs 
@@ -1,24 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Parser.Token--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Parser/Token/Combinators.hs 
@@ -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
− src/Text/Trifecta/Parser/Token/Prim.hs 
@@ -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
− src/Text/Trifecta/Parser/Token/Style.hs 
@@ -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"
+ src/Text/Trifecta/Rendering.hs view
@@ -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 <ekmett@gmail.com>+-- 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 = "<EOF>"+      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
+ src/Text/Trifecta/Result.hs view
@@ -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 #-}
src/Text/Trifecta/Rope.hs view
@@ -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 <ekmett@gmail.com>@@ -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
− src/Text/Trifecta/Rope/Bytes.hs 
@@ -1,27 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Rope.Bytes--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Rope/Delta.hs 
@@ -1,169 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Rope.Delta--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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
− src/Text/Trifecta/Rope/Highlighted.hs 
@@ -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 <ekmett@gmail.com>--- 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" "<span" ">" ! class_ (toValue $ show tok)) :@ bytes lo-                            , preEscapedString "</span>" :@ 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
− src/Text/Trifecta/Rope/Prim.hs 
@@ -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 <ekmett@gmail.com>--- 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
src/Text/Trifecta/Util/Array.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.Trifecta.Util.Array--- Copyright   :  Edward Kmett 2011+-- Copyright   :  Edward Kmett 2011-2013 --                Johan Tibell 2011 -- License     :  BSD3 --
src/Text/Trifecta/Util/Combinators.hs view
@@ -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 <ekmett@gmail.com>
+ src/Text/Trifecta/Util/IntervalMap.hs view
@@ -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.+--      <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--+-- 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+
+ src/Text/Trifecta/Util/It.hs view
@@ -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 <ekmett@gmail.com>+-- 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
+ tests/doctests.hs view
@@ -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
trifecta.cabal view
@@ -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 <ekmett@gmail.com> 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