diff --git a/Text/Trifecta/Diagnostic/Err/Log.hs b/Text/Trifecta/Diagnostic/Err/Log.hs --- a/Text/Trifecta/Diagnostic/Err/Log.hs +++ b/Text/Trifecta/Diagnostic/Err/Log.hs @@ -6,13 +6,14 @@ import Data.Semigroup import Text.PrettyPrint.Free import Text.Trifecta.Diagnostic.Prim +import Text.Trifecta.Rope.Delta import Text.Trifecta.Parser.Token.Highlight import Data.IntervalMap.FingerTree as IntervalMap import Data.Sequence (Seq) data ErrLog e = ErrLog { errLog :: !(Seq (Diagnostic e)) - , errHighlights :: !(IntervalMap (Int, Int) TokenHighlight) + , errHighlights :: !(IntervalMap Delta TokenHighlight) } instance Functor ErrLog where diff --git a/Text/Trifecta/Highlighter/Class.hs b/Text/Trifecta/Highlighter/Class.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Highlighter/Class.hs @@ -0,0 +1,48 @@ +module Text.Trifecta.Highlighter.Class + ( MonadHighlighter(..) + ) where + +import Data.IntervalMap.FingerTree +import Data.Monoid +import Text.Trifecta.Rope.Delta +import Text.Trifecta.Parser.Token.Highlight +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict +import Control.Monad.Trans.Class +import Control.Monad.Trans.Error +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader + +class Monad m => MonadHighlighter m where + highlights :: m (IntervalMap Delta TokenHighlight) + +instance MonadHighlighter m => MonadHighlighter (Lazy.StateT s m) where + highlights = lift highlights + +instance MonadHighlighter m => MonadHighlighter (Strict.StateT s m) where + highlights = lift highlights + +instance (MonadHighlighter m, Monoid w) => MonadHighlighter (Lazy.WriterT w m) where + highlights = lift highlights + +instance (MonadHighlighter m, Monoid w) => MonadHighlighter (Strict.WriterT w m) where + highlights = lift highlights + +instance MonadHighlighter m => MonadHighlighter (ReaderT e m) where + highlights = lift highlights + +instance (MonadHighlighter m, Monoid w) => MonadHighlighter (Lazy.RWST r w s m) where + highlights = lift highlights + +instance (MonadHighlighter m, Monoid w) => MonadHighlighter (Strict.RWST r w s m) where + highlights = lift highlights + +instance MonadHighlighter m => MonadHighlighter (MaybeT m) where + highlights = lift highlights + +instance (MonadHighlighter m, Error e) => MonadHighlighter (ErrorT e m) where + highlights = lift highlights diff --git a/Text/Trifecta/Parser/Prim.hs b/Text/Trifecta/Parser/Prim.hs --- a/Text/Trifecta/Parser/Prim.hs +++ b/Text/Trifecta/Parser/Prim.hs @@ -46,6 +46,7 @@ import Text.Trifecta.Diagnostic.Err.Log import Text.Trifecta.Diagnostic.Rendering.Prim import Text.Trifecta.Diagnostic.Rendering.Caret +import Text.Trifecta.Highlighter.Class import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.It import Text.Trifecta.Parser.Step @@ -125,6 +126,7 @@ fail s = Parser $ \ _ ee _ _ -> ee mempty { errMessage = FailErr s } {-# INLINE fail #-} + instance MonadPlus (Parser e) where mzero = empty mplus = (<|>) @@ -172,16 +174,13 @@ ascii :: ByteString -> Bool ascii = Strict.all (<=0x7f) -short :: Delta -> (Int, Int) -short d = (bytes d, Delta.column d) - instance MonadParser (Parser e) where -- commit (Parser m) = Parser $ \ _ _ co ce -> m co ce co ce try (Parser m) = Parser $ \ eo ee co ce -> m eo ee co $ \e -> if fatalErr (errMessage e) then ce e else ee e {-# INLINE try #-} highlightToken t (Parser m) = Parser $ \eo ee co ce l b8 d bs -> - m eo ee (\a e l' b8' d' -> co a e l' { errHighlights = IntervalMap.insert (Interval (short d) (short d')) t (errHighlights l') } b8' d') ce l b8 d bs + m eo ee (\a e l' b8' d' -> co a e l' { errHighlights = IntervalMap.insert (Interval d d') t (errHighlights l') } b8' d') ce l b8 d bs unexpected s = Parser $ \ _ ee _ _ -> ee mempty { errMessage = FailErr $ "unexpected " ++ s } @@ -248,6 +247,9 @@ ddc | otherwise -> co c mempty l b8 (d <> delta c) bs else ee mempty { errMessage = FailErr "unexpected EOF" } l b8 d bs + +instance MonadHighlighter (Parser e) where + highlights = Parser $ \eo _ _ _ l -> eo (errHighlights l) mempty l data St e a = JuSt a !(ErrState e) !(ErrLog e) !Bool !Delta !ByteString | NoSt !(ErrState e) !(ErrLog e) !Bool !Delta !ByteString diff --git a/Text/Trifecta/Rope/Delta.hs b/Text/Trifecta/Rope/Delta.hs --- a/Text/Trifecta/Rope/Delta.hs +++ b/Text/Trifecta/Rope/Delta.hs @@ -13,6 +13,7 @@ import Data.Hashable 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 @@ -35,7 +36,13 @@ {-# UNPACK #-} !Int -- the number of characters since the last newline {-# UNPACK #-} !Int -- number of bytes {-# UNPACK #-} !Int -- the number of bytes since the last newline - deriving (Eq, Ord, Show) + 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 diff --git a/trifecta.cabal b/trifecta.cabal --- a/trifecta.cabal +++ b/trifecta.cabal @@ -1,6 +1,6 @@ name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging -version: 0.34 +version: 0.35 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE @@ -52,6 +52,7 @@ Text.Trifecta.Diagnostic.Rendering.Caret Text.Trifecta.Diagnostic.Rendering.Fixit Text.Trifecta.Diagnostic.Rendering.Span + Text.Trifecta.Highlighter.Class Text.Trifecta.Parser Text.Trifecta.Parser.ByteString Text.Trifecta.Parser.Char @@ -96,8 +97,8 @@ parallel >= 3.1.0.1 && < 3.2, transformers >= 0.2.2 && < 0.3, kan-extensions >= 2.0.1 && < 2.1, - comonad >= 1.1.1 && < 1.2, + comonad >= 1.1.1.1 && < 1.2, terminfo >= 0.3.2 && < 0.4, keys >= 2.1 && < 2.2, wl-pprint-extras >= 1.5 && < 1.6, - wl-pprint-terminfo >= 0.6 && < 0.7 + wl-pprint-terminfo >= 0.7 && < 0.8