packages feed

trifecta 0.52 → 0.53

raw patch · 127 files changed

+6050/−6081 lines, 127 filesdep −data-lensdep −data-lens-fddep ~bifunctorsdep ~bytestringdep ~charset

Dependencies removed: data-lens, data-lens-fd

Dependency ranges changed: bifunctors, bytestring, charset, comonad, keys, pointed, profunctors, reducers, semigroupoids, wl-pprint-extras, wl-pprint-terminfo

Files

− Text/Trifecta.hs 
@@ -1,30 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta--- 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-  ( module Text.Trifecta.Diagnostic-  , module Text.Trifecta.Highlight-  , module Text.Trifecta.Language-  , module Text.Trifecta.Layout-  , module Text.Trifecta.Literate-  , module Text.Trifecta.Parser-  , module Text.Trifecta.Rope-  , module System.Console.Terminfo.PrettyPrint-  ) where--import Text.Trifecta.Diagnostic-import Text.Trifecta.Highlight-import Text.Trifecta.Language-import Text.Trifecta.Layout-import Text.Trifecta.Literate-import Text.Trifecta.Parser-import Text.Trifecta.Rope-import System.Console.Terminfo.PrettyPrint
− 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
− 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
− 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
− 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 = (<!>)
− 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 = (<!>)
− 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 = (<!>)
− 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"
− Text/Trifecta/Diagnostic/Prim.hs 
@@ -1,104 +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 Extend Diagnostic where-  extend f d@(Diagnostic r l _ xs) = Diagnostic r l (f d) (map (extend f) xs)--instance Comonad Diagnostic where-  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)
− 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
− Text/Trifecta/Diagnostic/Rendering/Caret.hs 
@@ -1,128 +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.Functor.Bind-import Data.Hashable-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-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 Extend Careted where-  extend f as@(_ :^ s) = f as :^ s--instance HasDelta (Careted a) where-  delta (_ :^ c) = delta c--instance HasBytes (Careted a) where-  bytes (_ :^ c) = bytes c--instance Comonad Careted where-  extract (a :^ _) = a--instance Foldable Careted where-  foldMap f (a :^ _) = f a--instance Traversable Careted where-  traverse f (a :^ s) = (:^ s) <$> f a--instance Foldable1 Careted where-  foldMap1 f (a :^ _) = f a--instance Traversable1 Careted where-  traverse1 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-
− 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
− Text/Trifecta/Diagnostic/Rendering/Prim.hs 
@@ -1,240 +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 Extend Rendered where-  extend f as@(_ :@ s) = f as :@ s--instance Comonad Rendered where-  extract (a :@ _) = a--instance Apply 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
− Text/Trifecta/Diagnostic/Rendering/Span.hs 
@@ -1,125 +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.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Foldable-import Data.Traversable-import Control.Comonad-import Data.Functor.Bind-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 Extend Spanned where-  extend f as@(_ :~ s) = f as :~ s--instance Comonad Spanned where-  extract (a :~ _) = a--instance Apply Spanned where-  (f :~ s) <.> (a :~ t) = f a :~ (s <> t)--instance Bind Spanned where-  (a :~ s) >>- f = case f a of-     b :~ t -> b :~ (s <> t)--instance Foldable Spanned where-  foldMap f (a :~ _) = f a--instance Traversable Spanned where-  traverse f (a :~ s) = (:~ s) <$> f a--instance Foldable1 Spanned where-  foldMap1 f (a :~ _) = f a--instance Traversable1 Spanned where-  traverse1 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
− Text/Trifecta/Highlight.hs 
@@ -1,22 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Highlight--- 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 -  ( -  -- * Text.Trifecta.Highlight.Class-    Highlightable(..)-  -- * Text.Trifecta.Highlight.Prim-  , Highlight-  , Highlights-  ) where--import Text.Trifecta.Highlight.Class-import Text.Trifecta.Highlight.Prim
− 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
− 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
− 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
− 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)
− 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-
− 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-
− 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
− 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
− 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)
− 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)
− 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
− 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
− 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
− Text/Trifecta/Layout/Combinators.hs 
@@ -1,67 +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 Data.Lens.Common-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--getLayout :: MonadLayout m => Lens LayoutState t -> m t-getLayout l = layoutState $ \s -> (getL l s, s)--setLayout :: MonadLayout m => Lens LayoutState t -> t -> m ()-setLayout l t = layoutState $ \s -> ((), setL l t s)--modLayout :: MonadLayout m => Lens LayoutState t -> (t -> t) -> m ()-modLayout l f = layoutState $ \s -> ((), modL l 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)-
− 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
− Text/Trifecta/Layout/Prim.hs 
@@ -1,86 +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.Lens.Common-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 :: Lens LayoutState Bool-layoutBol = lens _layoutBol (\s l -> l { _layoutBol = s})--layoutStack :: Lens LayoutState [LayoutContext]-layoutStack = lens _layoutStack (\s l -> l { _layoutStack = s})--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
− 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
− 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
− 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
− 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
− 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)
− Text/Trifecta/Parser.hs 
@@ -1,47 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Parser--- 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-  ( 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--  ) 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 Prelude ()
− 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-
− 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)
− 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)
− 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 #-}
− 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 ())
− 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)
− 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
− 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"-  ]
− Text/Trifecta/Parser/It.hs 
@@ -1,147 +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 (>>-) = (>>=) --instance Extend (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)---- | It is a cofree comonad-instance Comonad (It r) where-  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
− 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-
− 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'
− 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
− 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
− 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
− 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-
− 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
− 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
− 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
− 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"
− Text/Trifecta/Rope.hs 
@@ -1,26 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Rope--- 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 -  ( Rope, rope, strands-  -- * Strands of a rope-  , Strand(..), strand-  -- * Properties-  , Delta(..)-  , HasDelta(..)-  , HasBytes(..)-  , HighlightedRope(..)-  ) where--import Text.Trifecta.Rope.Prim-import Text.Trifecta.Rope.Delta-import Text.Trifecta.Rope.Bytes-import Text.Trifecta.Rope.Highlighted
− 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
− 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
− 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
− 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
− Text/Trifecta/Util/Array.hs 
@@ -1,378 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Util.Array--- Copyright   :  Edward Kmett 2011---                Johan Tibell 2011--- License     :  BSD3------ Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  unknown------ Fast zero based arrays, based on the implementation in the HAMT-branch of--- unordered-containers-------------------------------------------------------------------------------module Text.Trifecta.Util.Array-  ( Array-  , MArray--    -- * Creation-  , new-  , new_-  , empty-  , singleton--    -- * Basic interface-  , length-  , lengthM-  , read-  , write-  , index-  , index_-  , indexM_-  , update-  , insert-  , delete--  , unsafeFreeze-  , run-  , run2-  , copy-  , copyM--    -- * Folds-  , foldl'-  , foldr--  , thaw-  , map-  , map'-  , traverse-  , filter-  ) where--import qualified Data.Traversable as Traversable-import Control.Applicative (Applicative)-import Control.DeepSeq-import Control.Monad.ST-import GHC.Exts-import GHC.ST (ST(..))-import Prelude hiding (filter, foldr, length, map, read)----------------------------------------------------------------------------#if defined(ASSERTS)--- This fugly hack is brought by GHC's apparent reluctance to deal--- with MagicHash and UnboxedTuples when inferring types. Eek!-# define CHECK_BOUNDS(_func_,_len_,_k_) \-if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else-# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \-if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else-# define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_)-# define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_)-#else-# define CHECK_BOUNDS(_func_,_len_,_k_)-# define CHECK_OP(_func_,_op_,_lhs_,_rhs_)-# define CHECK_GT(_func_,_lhs_,_rhs_)-# define CHECK_LE(_func_,_lhs_,_rhs_)-#endif--data Array a = Array {-  unArray :: !(Array# a)-#if __GLASGOW_HASKELL__ < 702-  , length :: {-# UNPACK #-} !Int-#endif-  }--#if __GLASGOW_HASKELL__ >= 702-length :: Array a -> Int-length ary = I# (sizeofArray# (unArray ary))-{-# INLINE length #-}-#endif---- | Smart constructor-array :: Array# a -> Int -> Array a-#if __GLASGOW_HASKELL__ >= 702-array ary _n = Array ary-#else-array = Array-#endif-{-# INLINE array #-}--data MArray s a = MArray {-  unMArray :: !(MutableArray# s a)-#if __GLASGOW_HASKELL__ < 702-  , lengthM :: {-# UNPACK #-} !Int-#endif-  }--#if __GLASGOW_HASKELL__ >= 702-lengthM :: MArray s a -> Int-lengthM mary = I# (sizeofMutableArray# (unMArray mary))-{-# INLINE lengthM #-}-#endif---- | Smart constructor-marray :: MutableArray# s a -> Int -> MArray s a-#if __GLASGOW_HASKELL__ >= 702-marray mary _n = MArray mary-#else-marray = MArray-#endif-{-# INLINE marray #-}----------------------------------------------------------------------------instance NFData a => NFData (Array a) where-  rnf = rnfArray--rnfArray :: NFData a => Array a -> ()-rnfArray ary0 = go ary0 n0 0 where-  n0 = length ary0-  go !ary !n !i-    | i >= n = ()-    | otherwise = rnf (index ary i) `seq` go ary n (i+1)-{-# INLINE rnfArray #-}---- | Create a new mutable array of specified size, in the specified--- state thread, with each element containing the specified initial--- value.-new :: Int -> a -> ST s (MArray s a)-new n@(I# n#) b =-  CHECK_GT("new",n,(0 :: Int))-  ST $ \s -> case newArray# n# b s of-    (# s', ary #) -> (# s', marray ary n #)-{-# INLINE new #-}--new_ :: Int -> ST s (MArray s a)-new_ n = new n undefinedElem--empty :: Array a-empty = run (new_ 0)--singleton :: a -> Array a-singleton x = run (new 1 x)-{-# INLINE singleton #-}--read :: MArray s a -> Int -> ST s a-read ary _i@(I# i#) = ST $ \ s ->-  CHECK_BOUNDS("read", lengthM ary, _i)-  readArray# (unMArray ary) i# s-{-# INLINE read #-}--write :: MArray s a -> Int -> a -> ST s ()-write ary _i@(I# i#) b = ST $ \ s ->-  CHECK_BOUNDS("write", lengthM ary, _i)-  case writeArray# (unMArray ary) i# b s of-    s' -> (# s' , () #)-{-# INLINE write #-}--index :: Array a -> Int -> a-index ary _i@(I# i#) =-  CHECK_BOUNDS("index", length ary, _i)-  case indexArray# (unArray ary) i# of (# b #) -> b-{-# INLINE index #-}--index_ :: Array a -> Int -> ST s a-index_ ary _i@(I# i#) =-  CHECK_BOUNDS("index_", length ary, _i)-  case indexArray# (unArray ary) i# of (# b #) -> return b-{-# INLINE index_ #-}--indexM_ :: MArray s a -> Int -> ST s a-indexM_ ary _i@(I# i#) =-  CHECK_BOUNDS("index_", lengthM ary, _i)-  ST $ \ s# -> readArray# (unMArray ary) i# s#-{-# INLINE indexM_ #-}--unsafeFreeze :: MArray s a -> ST s (Array a)-unsafeFreeze mary = -  ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of-    (# s', ary #) -> (# s', array ary (lengthM mary) #)-{-# INLINE unsafeFreeze #-}--run :: (forall s . ST s (MArray s e)) -> Array e-run act = runST $ act >>= unsafeFreeze-{-# INLINE run #-}--run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a)-run2 k = runST $ do-  (marr,b) <- k-  arr <- unsafeFreeze marr-  return (arr,b)---- | Unsafely copy the elements of an array. Array bounds are not checked.-copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s ()-#if __GLASGOW_HASKELL__ >= 702-copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =-  CHECK_LE("copy", _sidx + _n, length src)-  CHECK_LE("copy", _didx + _n, lengthM dst)-  ST $ \ s# -> case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of-    s2 -> (# s2, () #)-#else-copy !src !sidx !dst !didx n =-  CHECK_LE("copy", sidx + n, length src)-  CHECK_LE("copy", didx + n, lengthM dst)-  copy_loop sidx didx 0 where-  copy_loop !i !j !c-    | c >= n = return ()-    | otherwise = do-      b <- index_ src i-      write dst j b-      copy_loop (i+1) (j+1) (c+1)-#endif---- | Unsafely copy the elements of an array. Array bounds are not checked.-copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()-#if __GLASGOW_HASKELL__ >= 702-copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =-  CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1)-  CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1)-  ST $ \ s# -> case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of-    s2 -> (# s2, () #)-#else-copyM !src !sidx !dst !didx n =-  CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1)-  CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1)-  copy_loop sidx didx 0 where-  copy_loop !i !j !c-    | c >= n = return ()-    | otherwise = do -      b <- indexM_ src i-      write dst j b-      copy_loop (i+1) (j+1) (c+1)-#endif---- | /O(n)/ Insert an element at the given position in this array,--- increasing its size by one.-insert :: Array e -> Int -> e -> Array e-insert ary idx b =-  CHECK_BOUNDS("insert", count + 1, idx)-  run $ do-    mary <- new_ (count+1)-    copy ary 0 mary 0 idx-    write mary idx b-    copy ary idx mary (idx+1) (count-idx)-    return mary -  where !count = length ary-{-# INLINE insert #-}---- | /O(n)/ Update the element at the given position in this array.-update :: Array e -> Int -> e -> Array e-update ary idx b =-  CHECK_BOUNDS("update", count, idx)-  run $ do-    mary <- thaw ary 0 count-    write mary idx b-    return mary-  where !count = length ary-{-# INLINE update #-}--foldl' :: (b -> a -> b) -> b -> Array a -> b-foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where-  go ary n i !z-    | i >= n    = z-    | otherwise = go ary n (i+1) (f z (index ary i))-{-# INLINE foldl' #-}--foldr :: (a -> b -> b) -> b -> Array a -> b-foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where-  go ary n i z-    | i >= n    = z-    | otherwise = f (index ary i) (go ary n (i+1) z)-{-# INLINE foldr #-}--undefinedElem :: a-undefinedElem = error "Undefined element"--thaw :: Array e -> Int -> Int -> ST s (MArray s e)-#if __GLASGOW_HASKELL__ >= 702-thaw !ary !_o@(I# o#) !n@(I# n#) =-  CHECK_LE("thaw", _o + n, length ary)-  ST $ \ s -> case thawArray# (unArray ary) o# n# s of-    (# s2, mary# #) -> (# s2, marray mary# n #)-#else-thaw !ary !o !n =-  CHECK_LE("thaw", o + n, length ary)-  do mary <- new_ n-     copy ary o mary 0 n-     return mary-#endif-{-# INLINE thaw #-}---- | /O(n)/ Delete an element at the given position in this array,--- decreasing its size by one.-delete :: Array e -> Int -> Array e-delete ary idx = run $ do-    mary <- new_ (count-1)-    copy ary 0 mary 0 idx-    copy ary (idx+1) mary idx (count-(idx+1))-    return mary-  where !count = length ary-{-# INLINE delete #-}--map :: (a -> b) -> Array a -> Array b-map f = \ ary ->-  let !n = length ary-  in run $ do-    mary <- new_ n-    go ary mary 0 n-  where-    go ary mary i n-        | i >= n    = return mary-        | otherwise = do-             write mary i $ f (index ary i)-             go ary mary (i+1) n-{-# INLINE map #-}---- | Strict version of 'map'.-map' :: (a -> b) -> Array a -> Array b-map' f = \ ary ->-  let !n = length ary-  in run $ do-    mary <- new_ n-    go ary mary 0 n-  where-    go ary mary i n-      | i >= n    = return mary-      | otherwise = do-        write mary i $! f (index ary i)-        go ary mary (i+1) n-{-# INLINE map' #-}--fromList :: Int -> [a] -> Array a-fromList n xs0 = run $ do-  mary <- new_ n-  go xs0 mary 0-  where-    go [] !mary !_   = return mary-    go (x:xs) mary i = do write mary i x-                          go xs mary (i+1)--toList :: Array a -> [a]-toList = foldr (:) []--traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)-traverse f = \ ary ->-  fromList (length ary) `fmap`-  Traversable.traverse f (toList ary)-{-# INLINE traverse #-}--filter :: (a -> Bool) -> Array a -> Array a-filter p = \ ary ->-  let !n = length ary-  in run $ do-    mary <- new_ n-    go ary mary 0 0 n-  where-    go ary mary i j n-      | i >= n    = if i == j-                    then return mary-                    else do mary2 <- new_ j-                            copyM mary 0 mary2 0 j-                            return mary2-      | p el      = write mary j el >> go ary mary (i+1) (j+1) n-      | otherwise = go ary mary (i+1) j n-      where el = index ary i-{-# INLINE filter #-}
− Text/Trifecta/Util/Combinators.hs 
@@ -1,52 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Util.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.Util.Combinators-  ( argmin-  , argmax-  -- * ByteString conversions-  , fromLazy-  , toLazy-  , takeLine-  , (<$!>)-  ) where--import Data.ByteString.Lazy as Lazy-import Data.ByteString as Strict--argmin :: Ord b => (a -> b) -> a -> a -> a-argmin f a b-  | f a <= f b = a-  | otherwise = b-{-# INLINE argmin #-}--argmax :: Ord b => (a -> b) -> a -> a -> a-argmax f a b-  | f a > f b = a-  | otherwise = b-{-# INLINE argmax #-}--fromLazy :: Lazy.ByteString -> Strict.ByteString-fromLazy = Strict.concat . Lazy.toChunks-     -toLazy :: Strict.ByteString -> Lazy.ByteString-toLazy = Lazy.fromChunks . return--takeLine :: Lazy.ByteString -> Lazy.ByteString-takeLine s = case Lazy.elemIndex 10 s of-  Just i -> Lazy.take (i + 1) s-  Nothing -> s--infixl 4 <$!>-(<$!>) :: Monad m => (a -> b) -> m a -> m b-f <$!> m = do-  a <- m -  return $! f a
+ src/Text/Trifecta.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta+-- 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+  ( module Text.Trifecta.Diagnostic+  , module Text.Trifecta.Highlight+  , module Text.Trifecta.Language+  , module Text.Trifecta.Layout+  , module Text.Trifecta.Literate+  , module Text.Trifecta.Parser+  , module Text.Trifecta.Rope+  , module System.Console.Terminfo.PrettyPrint+  ) where++import Text.Trifecta.Diagnostic+import Text.Trifecta.Highlight+import Text.Trifecta.Language+import Text.Trifecta.Layout+import Text.Trifecta.Literate+import Text.Trifecta.Parser+import Text.Trifecta.Rope+import System.Console.Terminfo.PrettyPrint
+ src/Text/Trifecta/Diagnostic.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,64 @@+{-# 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 view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,102 @@+{-# 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 view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,117 @@+{-# 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 view
@@ -0,0 +1,63 @@+{-# 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 view
@@ -0,0 +1,241 @@+{-# 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 view
@@ -0,0 +1,107 @@+{-# 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
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.Highlight+-- 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 +  ( +  -- * Text.Trifecta.Highlight.Class+    Highlightable(..)+  -- * Text.Trifecta.Highlight.Prim+  , Highlight+  , Highlights+  ) where++import Text.Trifecta.Highlight.Class+import Text.Trifecta.Highlight.Prim
+ src/Text/Trifecta/Highlight/Class.hs view
@@ -0,0 +1,19 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,48 @@+{-# 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/IntervalMap.hs view
@@ -0,0 +1,275 @@+{-# 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 view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,79 @@+{-# 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 view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,64 @@+{-# 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 view
@@ -0,0 +1,68 @@+{-# 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 view
@@ -0,0 +1,112 @@+{-# 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 view
@@ -0,0 +1,87 @@+{-# 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 view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,94 @@+{-# 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 view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+-- |+-- 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
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.Parser+-- 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+  ( 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++  ) 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 Prelude ()
+ src/Text/Trifecta/Parser/ByteString.hs view
@@ -0,0 +1,93 @@+{-# 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 view
@@ -0,0 +1,204 @@+{-# 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 view
@@ -0,0 +1,213 @@+{-# 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 view
@@ -0,0 +1,271 @@+{-# 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 view
@@ -0,0 +1,207 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,167 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,144 @@+{-# 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 view
@@ -0,0 +1,67 @@+{-# 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 view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,322 @@+{-# 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 view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,63 @@+{-# 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 view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,217 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------+-- |+-- 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/Rope.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.Rope+-- 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 +  ( Rope, rope, strands+  -- * Strands of a rope+  , Strand(..), strand+  -- * Properties+  , Delta(..)+  , HasDelta(..)+  , HasBytes(..)+  , HighlightedRope(..)+  ) where++import Text.Trifecta.Rope.Prim+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Highlighted
+ src/Text/Trifecta/Rope/Bytes.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,169 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,98 @@+{-# 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 view
@@ -0,0 +1,114 @@+{-# 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
@@ -0,0 +1,378 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.Util.Array+-- Copyright   :  Edward Kmett 2011+--                Johan Tibell 2011+-- License     :  BSD3+--+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Fast zero based arrays, based on the implementation in the HAMT-branch of+-- unordered-containers+-----------------------------------------------------------------------------+module Text.Trifecta.Util.Array+  ( Array+  , MArray++    -- * Creation+  , new+  , new_+  , empty+  , singleton++    -- * Basic interface+  , length+  , lengthM+  , read+  , write+  , index+  , index_+  , indexM_+  , update+  , insert+  , delete++  , unsafeFreeze+  , run+  , run2+  , copy+  , copyM++    -- * Folds+  , foldl'+  , foldr++  , thaw+  , map+  , map'+  , traverse+  , filter+  ) where++import qualified Data.Traversable as Traversable+import Control.Applicative (Applicative)+import Control.DeepSeq+import Control.Monad.ST+import GHC.Exts+import GHC.ST (ST(..))+import Prelude hiding (filter, foldr, length, map, read)++------------------------------------------------------------------------++#if defined(ASSERTS)+-- This fugly hack is brought by GHC's apparent reluctance to deal+-- with MagicHash and UnboxedTuples when inferring types. Eek!+# define CHECK_BOUNDS(_func_,_len_,_k_) \+if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else+# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \+if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else+# define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_)+# define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_)+#else+# define CHECK_BOUNDS(_func_,_len_,_k_)+# define CHECK_OP(_func_,_op_,_lhs_,_rhs_)+# define CHECK_GT(_func_,_lhs_,_rhs_)+# define CHECK_LE(_func_,_lhs_,_rhs_)+#endif++data Array a = Array {+  unArray :: !(Array# a)+#if __GLASGOW_HASKELL__ < 702+  , length :: {-# UNPACK #-} !Int+#endif+  }++#if __GLASGOW_HASKELL__ >= 702+length :: Array a -> Int+length ary = I# (sizeofArray# (unArray ary))+{-# INLINE length #-}+#endif++-- | Smart constructor+array :: Array# a -> Int -> Array a+#if __GLASGOW_HASKELL__ >= 702+array ary _n = Array ary+#else+array = Array+#endif+{-# INLINE array #-}++data MArray s a = MArray {+  unMArray :: !(MutableArray# s a)+#if __GLASGOW_HASKELL__ < 702+  , lengthM :: {-# UNPACK #-} !Int+#endif+  }++#if __GLASGOW_HASKELL__ >= 702+lengthM :: MArray s a -> Int+lengthM mary = I# (sizeofMutableArray# (unMArray mary))+{-# INLINE lengthM #-}+#endif++-- | Smart constructor+marray :: MutableArray# s a -> Int -> MArray s a+#if __GLASGOW_HASKELL__ >= 702+marray mary _n = MArray mary+#else+marray = MArray+#endif+{-# INLINE marray #-}++------------------------------------------------------------------------++instance NFData a => NFData (Array a) where+  rnf = rnfArray++rnfArray :: NFData a => Array a -> ()+rnfArray ary0 = go ary0 n0 0 where+  n0 = length ary0+  go !ary !n !i+    | i >= n = ()+    | otherwise = rnf (index ary i) `seq` go ary n (i+1)+{-# INLINE rnfArray #-}++-- | Create a new mutable array of specified size, in the specified+-- state thread, with each element containing the specified initial+-- value.+new :: Int -> a -> ST s (MArray s a)+new n@(I# n#) b =+  CHECK_GT("new",n,(0 :: Int))+  ST $ \s -> case newArray# n# b s of+    (# s', ary #) -> (# s', marray ary n #)+{-# INLINE new #-}++new_ :: Int -> ST s (MArray s a)+new_ n = new n undefinedElem++empty :: Array a+empty = run (new_ 0)++singleton :: a -> Array a+singleton x = run (new 1 x)+{-# INLINE singleton #-}++read :: MArray s a -> Int -> ST s a+read ary _i@(I# i#) = ST $ \ s ->+  CHECK_BOUNDS("read", lengthM ary, _i)+  readArray# (unMArray ary) i# s+{-# INLINE read #-}++write :: MArray s a -> Int -> a -> ST s ()+write ary _i@(I# i#) b = ST $ \ s ->+  CHECK_BOUNDS("write", lengthM ary, _i)+  case writeArray# (unMArray ary) i# b s of+    s' -> (# s' , () #)+{-# INLINE write #-}++index :: Array a -> Int -> a+index ary _i@(I# i#) =+  CHECK_BOUNDS("index", length ary, _i)+  case indexArray# (unArray ary) i# of (# b #) -> b+{-# INLINE index #-}++index_ :: Array a -> Int -> ST s a+index_ ary _i@(I# i#) =+  CHECK_BOUNDS("index_", length ary, _i)+  case indexArray# (unArray ary) i# of (# b #) -> return b+{-# INLINE index_ #-}++indexM_ :: MArray s a -> Int -> ST s a+indexM_ ary _i@(I# i#) =+  CHECK_BOUNDS("index_", lengthM ary, _i)+  ST $ \ s# -> readArray# (unMArray ary) i# s#+{-# INLINE indexM_ #-}++unsafeFreeze :: MArray s a -> ST s (Array a)+unsafeFreeze mary = +  ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of+    (# s', ary #) -> (# s', array ary (lengthM mary) #)+{-# INLINE unsafeFreeze #-}++run :: (forall s . ST s (MArray s e)) -> Array e+run act = runST $ act >>= unsafeFreeze+{-# INLINE run #-}++run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a)+run2 k = runST $ do+  (marr,b) <- k+  arr <- unsafeFreeze marr+  return (arr,b)++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s ()+#if __GLASGOW_HASKELL__ >= 702+copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+  CHECK_LE("copy", _sidx + _n, length src)+  CHECK_LE("copy", _didx + _n, lengthM dst)+  ST $ \ s# -> case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of+    s2 -> (# s2, () #)+#else+copy !src !sidx !dst !didx n =+  CHECK_LE("copy", sidx + n, length src)+  CHECK_LE("copy", didx + n, lengthM dst)+  copy_loop sidx didx 0 where+  copy_loop !i !j !c+    | c >= n = return ()+    | otherwise = do+      b <- index_ src i+      write dst j b+      copy_loop (i+1) (j+1) (c+1)+#endif++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()+#if __GLASGOW_HASKELL__ >= 702+copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+  CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1)+  CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1)+  ST $ \ s# -> case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of+    s2 -> (# s2, () #)+#else+copyM !src !sidx !dst !didx n =+  CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1)+  CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1)+  copy_loop sidx didx 0 where+  copy_loop !i !j !c+    | c >= n = return ()+    | otherwise = do +      b <- indexM_ src i+      write dst j b+      copy_loop (i+1) (j+1) (c+1)+#endif++-- | /O(n)/ Insert an element at the given position in this array,+-- increasing its size by one.+insert :: Array e -> Int -> e -> Array e+insert ary idx b =+  CHECK_BOUNDS("insert", count + 1, idx)+  run $ do+    mary <- new_ (count+1)+    copy ary 0 mary 0 idx+    write mary idx b+    copy ary idx mary (idx+1) (count-idx)+    return mary +  where !count = length ary+{-# INLINE insert #-}++-- | /O(n)/ Update the element at the given position in this array.+update :: Array e -> Int -> e -> Array e+update ary idx b =+  CHECK_BOUNDS("update", count, idx)+  run $ do+    mary <- thaw ary 0 count+    write mary idx b+    return mary+  where !count = length ary+{-# INLINE update #-}++foldl' :: (b -> a -> b) -> b -> Array a -> b+foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where+  go ary n i !z+    | i >= n    = z+    | otherwise = go ary n (i+1) (f z (index ary i))+{-# INLINE foldl' #-}++foldr :: (a -> b -> b) -> b -> Array a -> b+foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where+  go ary n i z+    | i >= n    = z+    | otherwise = f (index ary i) (go ary n (i+1) z)+{-# INLINE foldr #-}++undefinedElem :: a+undefinedElem = error "Undefined element"++thaw :: Array e -> Int -> Int -> ST s (MArray s e)+#if __GLASGOW_HASKELL__ >= 702+thaw !ary !_o@(I# o#) !n@(I# n#) =+  CHECK_LE("thaw", _o + n, length ary)+  ST $ \ s -> case thawArray# (unArray ary) o# n# s of+    (# s2, mary# #) -> (# s2, marray mary# n #)+#else+thaw !ary !o !n =+  CHECK_LE("thaw", o + n, length ary)+  do mary <- new_ n+     copy ary o mary 0 n+     return mary+#endif+{-# INLINE thaw #-}++-- | /O(n)/ Delete an element at the given position in this array,+-- decreasing its size by one.+delete :: Array e -> Int -> Array e+delete ary idx = run $ do+    mary <- new_ (count-1)+    copy ary 0 mary 0 idx+    copy ary (idx+1) mary idx (count-(idx+1))+    return mary+  where !count = length ary+{-# INLINE delete #-}++map :: (a -> b) -> Array a -> Array b+map f = \ ary ->+  let !n = length ary+  in run $ do+    mary <- new_ n+    go ary mary 0 n+  where+    go ary mary i n+        | i >= n    = return mary+        | otherwise = do+             write mary i $ f (index ary i)+             go ary mary (i+1) n+{-# INLINE map #-}++-- | Strict version of 'map'.+map' :: (a -> b) -> Array a -> Array b+map' f = \ ary ->+  let !n = length ary+  in run $ do+    mary <- new_ n+    go ary mary 0 n+  where+    go ary mary i n+      | i >= n    = return mary+      | otherwise = do+        write mary i $! f (index ary i)+        go ary mary (i+1) n+{-# INLINE map' #-}++fromList :: Int -> [a] -> Array a+fromList n xs0 = run $ do+  mary <- new_ n+  go xs0 mary 0+  where+    go [] !mary !_   = return mary+    go (x:xs) mary i = do write mary i x+                          go xs mary (i+1)++toList :: Array a -> [a]+toList = foldr (:) []++traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)+traverse f = \ ary ->+  fromList (length ary) `fmap`+  Traversable.traverse f (toList ary)+{-# INLINE traverse #-}++filter :: (a -> Bool) -> Array a -> Array a+filter p = \ ary ->+  let !n = length ary+  in run $ do+    mary <- new_ n+    go ary mary 0 0 n+  where+    go ary mary i j n+      | i >= n    = if i == j+                    then return mary+                    else do mary2 <- new_ j+                            copyM mary 0 mary2 0 j+                            return mary2+      | p el      = write mary j el >> go ary mary (i+1) (j+1) n+      | otherwise = go ary mary (i+1) j n+      where el = index ary i+{-# INLINE filter #-}
+ src/Text/Trifecta/Util/Combinators.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.Util.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.Util.Combinators+  ( argmin+  , argmax+  -- * ByteString conversions+  , fromLazy+  , toLazy+  , takeLine+  , (<$!>)+  ) where++import Data.ByteString.Lazy as Lazy+import Data.ByteString as Strict++argmin :: Ord b => (a -> b) -> a -> a -> a+argmin f a b+  | f a <= f b = a+  | otherwise = b+{-# INLINE argmin #-}++argmax :: Ord b => (a -> b) -> a -> a -> a+argmax f a b+  | f a > f b = a+  | otherwise = b+{-# INLINE argmax #-}++fromLazy :: Lazy.ByteString -> Strict.ByteString+fromLazy = Strict.concat . Lazy.toChunks+     +toLazy :: Strict.ByteString -> Lazy.ByteString+toLazy = Lazy.fromChunks . return++takeLine :: Lazy.ByteString -> Lazy.ByteString+takeLine s = case Lazy.elemIndex 10 s of+  Just i -> Lazy.take (i + 1) s+  Nothing -> s++infixl 4 <$!>+(<$!>) :: Monad m => (a -> b) -> m a -> m b+f <$!> m = do+  a <- m +  return $! f a
trifecta.cabal view
@@ -1,6 +1,6 @@ name:          trifecta category:      Text, Parsing, Diagnostics, Pretty Printer, Logging-version:       0.52+version:       0.53 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -23,6 +23,8 @@   location: git://github.com/ekmett/trifecta.git  library+  hs-source-dirs: src+   exposed-modules:     Text.Trifecta     Text.Trifecta.IntervalMap@@ -93,30 +95,28 @@   ghc-options: -Wall    build-depends:-    base                 >= 4       && < 5,+    base                 == 4.*,     array                >= 0.3.0.2 && < 0.5,-    charset              >= 0.3.2   && < 0.4,+    charset              >= 0.3.2.1 && < 0.4,     containers           >= 0.3     && < 0.6,     unordered-containers >= 0.2.1   && < 0.3,     blaze-builder        >= 0.3.0.1 && < 0.4,     blaze-html           >= 0.4.1.6 && < 0.5,-    bifunctors           >= 0.1.3.1 && < 0.2,-    data-lens            >= 2.0.3   && < 2.11,-    data-lens-fd         >= 2.0.1   && < 2.11,+    bifunctors           == 3.0.*,     deepseq              >= 1.2.0.1 && < 1.4,     hashable             >= 1.1.2.1 && < 1.2,-    bytestring           >= 0.9.1   && < 0.10,+    bytestring           >= 0.9.1   && < 0.11,     mtl                  >= 2.0.1   && < 2.2,     semigroups           >= 0.8.3.1 && < 0.9,     fingertree           >= 0.0.1   && < 0.1,-    reducers             >= 0.3     && < 0.4,-    profunctors          >= 0.1.2.2 && < 0.2,+    reducers             == 3.0.*,+    profunctors          == 3.0.*,     utf8-string          >= 0.3.6   && < 0.4,-    semigroupoids        >= 1.3.1.2 && < 1.4,-    pointed              >= 2.1.0.1 && < 2.2,+    semigroupoids        == 3.0.*,+    pointed              == 3.0.*,     transformers         >= 0.2     && < 0.4,-    comonad              >= 1.1.1.3 && < 1.2,+    comonad              == 3.0.*,     terminfo             >= 0.3.2   && < 0.4,-    keys                 >= 2.1.3.1 && < 2.2,-    wl-pprint-extras     >= 1.6.3.1 && < 1.7,-    wl-pprint-terminfo   >= 0.8.3.1 && < 0.9+    keys                 == 3.0.*,+    wl-pprint-extras     == 3.0.*,+    wl-pprint-terminfo   == 3.0.*