packages feed

trifecta 0.30 → 0.31

raw patch · 13 files changed

+246/−90 lines, 13 filesdep +kan-extensions

Dependencies added: kan-extensions

Files

Text/Trifecta/CharSet.hs view
@@ -10,11 +10,10 @@ -- -- Fast set membership tests for 'Char' values ----- Stored as a (possibly negated IntMap) and a fast set for the ASCII range.+-- Stored as a (possibly negated) IntMap and a fast set used for the head byte. ----- The ASCII range is unboxed for efficiency. For small (complemented) sets, we--- test for membership using a binary search. For larger (complemented) sets--- we use a lookup table. +-- The set of valid (possibly negated) head bytes is stored unboxed as a 32-byte+-- bytestring-based lookup table. -- -- Designed to be imported qualified: --
+ Text/Trifecta/Diagnostic/Err/Log.hs view
@@ -0,0 +1,34 @@+module Text.Trifecta.Diagnostic.Err.Log+  ( ErrLog(..)+  ) where++import Data.Functor.Plus+import Data.Semigroup+import Data.Monoid+import Text.PrettyPrint.Free+import Text.Trifecta.Diagnostic.Prim+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) +  }++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') (IntervalMap.union b b')+  {-# INLINE (<!>) #-}++instance Plus ErrLog where+  zero = ErrLog mempty IntervalMap.empty+ +instance Semigroup (ErrLog e) where+  (<>) = (<!>) ++instance Monoid (ErrLog e) where+  mempty = zero+  mappend = (<!>)
Text/Trifecta/Parser/ByteString.hs view
@@ -70,7 +70,7 @@   i <- B.readFile fn   case starve      $ feed (rope (F.fromList [LineDirective (UTF8.fromString fn) 0, strand i]))-     $ stepParser (fmap prettyTerm) (why prettyTerm) (release (Directed n 0 0 0 0) *> p) mempty mempty mempty of+     $ stepParser (fmap prettyTerm) (why prettyTerm) (release (Directed n 0 0 0 0) *> p) mempty True mempty mempty of      Success xs a -> return (xs,      Just a )      Failure xs e -> return (xs |> e, Nothing)   where n = UTF8.fromString fn
Text/Trifecta/Parser/Class.hs view
@@ -33,11 +33,9 @@ import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity-import Control.Monad.Trans.Codensity+import Data.Functor.Yoneda import Data.Monoid import Data.Word--- import Control.Monad.Trans.Maybe.Strict as Strict--- import Control.Monad.Trans.Either.Strict as Strict import Data.ByteString as Strict import Data.ByteString.Internal (w2c) import Data.Semigroup@@ -45,26 +43,53 @@ import Text.Trifecta.Rope.Delta import Text.Trifecta.Rope.Prim import Text.Trifecta.Parser.It+import Text.Trifecta.Parser.Token.Highlight import Text.Trifecta.Diagnostic.Rendering.Prim+-- import Control.Monad.Trans.Maybe.Strict as Strict+-- import Control.Monad.Trans.Either.Strict as Strict+-- import Control.Monad.Codensity  infix 0 <?>  class ( Alternative m, MonadPlus m) => MonadParser m where-  -- non-committal actions-  try        :: m a -> m a+  -- | 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 -> Set String -> m a+  -- | Lift an operation from the primitive It monad   liftIt     :: It Rope a -> m a+ +  -- | mark the current location so it can be used in constructing a span, or for later seeking   mark       :: m Delta+  -- | Used to emit an error on an unexpected token   unexpected :: MonadParser m => String -> m a++  -- | Retrieve the contents of the current line (from the beginning of the line)   line       :: m ByteString++  -- | 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     -- actions that definitely commit++  -- | Seek back to previously marked location   release  :: Delta -> m ()++  -- | 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 +  -- | @highlightToken@ 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.+  highlightToken :: TokenHighlight -> m a -> m a+  highlightToken _ m = m+ 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@@ -75,6 +100,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (Lazy.StateT m) = Lazy.StateT $ \e -> highlightToken t (m e)   instance MonadParser m => MonadParser (Strict.StateT s m) where   try (Strict.StateT m) = Strict.StateT $ try . m@@ -86,6 +112,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (Strict.StateT m) = Strict.StateT $ \e -> highlightToken t (m e)   instance MonadParser m => MonadParser (ReaderT e m) where   try (ReaderT m) = ReaderT $ try . m@@ -97,6 +124,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (ReaderT m) = ReaderT $ \e -> highlightToken t (m e)   instance (MonadParser m, Monoid w) => MonadParser (Strict.WriterT w m) where   try (Strict.WriterT m) = Strict.WriterT $ try m@@ -108,6 +136,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (Strict.WriterT m) = Strict.WriterT $ highlightToken t m  instance (MonadParser m, Monoid w) => MonadParser (Lazy.WriterT w m) where   try (Lazy.WriterT m) = Lazy.WriterT $ try m@@ -119,6 +148,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (Lazy.WriterT m) = Lazy.WriterT $ highlightToken t 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)@@ -130,6 +160,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (Lazy.RWST m) = Lazy.RWST $ \r s -> highlightToken t (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)@@ -141,6 +172,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (Strict.RWST m) = Strict.RWST $ \r s -> highlightToken t (m r s)  instance MonadParser m => MonadParser (IdentityT m) where   try (IdentityT m) = IdentityT $ try m@@ -152,15 +184,41 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8+  highlightToken t (IdentityT m) = IdentityT $ highlightToken t m +instance MonadParser m => MonadParser (Yoneda m) where+  try = lift . try . lowerYoneda+  labels m ss = lift $ labels (lowerYoneda m) ss+  line = lift line+  liftIt = lift . liftIt+  mark = lift mark +  release = lift . release+  unexpected = lift . unexpected+  satisfy = lift . satisfy+  satisfy8 = lift . satisfy8+  highlightToken t (Yoneda m) = Yoneda $ \f -> highlightToken t (m f)++{-+instance MonadParser m => MonadParser (Codensity m) where+  try = lift . try . lowerCodensity+  labels m ss = lift $ labels (lowerCodensity m) ss+  line = lift line+  liftIt = lift . liftIt+  mark = lift mark +  release = lift . release+  unexpected = lift . unexpected+  satisfy = lift . satisfy+  satisfy8 = lift . satisfy8+-}+-- instance (MonadParser m, Monoid w) => MonadParser (MaybeT m) where+-- instance (Error e, MonadParser m, Monoid w) => MonadParser (ErrorT e m) where+ satisfyAscii :: MonadParser m => (Char -> Bool) -> m Char satisfyAscii p = w2c <$> satisfy8 (\w -> w <= 0x7f && p (w2c w)) {-# INLINE satisfyAscii #-} --- instance (MonadParser m, Monoid w) => MonadParser (MaybeT m) where--- instance (Error e, MonadParser m, Monoid w) => MonadParser (ErrorT e m) where -  -- useful when we've just recognized something out of band using access to the current line +-- useful when we've just recognized something out of band using access to the current line  skipping :: MonadParser m => Delta -> m () skipping d = do   m <- mark@@ -194,3 +252,5 @@ rend :: MonadParser m => m Rendering rend = rendering <$> mark <*> line {-# INLINE rend #-}++
Text/Trifecta/Parser/Prim.hs view
@@ -29,12 +29,14 @@ import Data.Foldable import Data.Monoid import Data.Functor.Bind (Apply(..), Bind((>>-)))+import Data.IntervalMap.FingerTree (Interval(..))+import qualified Data.IntervalMap.FingerTree 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.Rope.Delta+import Text.Trifecta.Rope.Delta as Delta import Text.Trifecta.Rope.Prim import Text.Trifecta.Rope.Bytes import Text.Trifecta.Diagnostic.Class@@ -42,6 +44,7 @@ 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.Prim import Text.Trifecta.Diagnostic.Rendering.Caret import Text.Trifecta.Parser.Class@@ -50,15 +53,13 @@ import Text.Trifecta.Parser.Result import System.Console.Terminfo.PrettyPrint -type ErrLog e = Seq (Diagnostic e) -- use a fingertree to sort them?- data Parser e a = Parser    { unparser :: forall r.-    (a -> ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- uncommitted ok-    (     ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- uncommitted err-    (a -> ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- committed ok-    (     ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- committed err-                        ErrLog e -> Delta -> ByteString -> It Rope r+    (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 e) where@@ -129,7 +130,7 @@   mzero = empty   mplus = (<|>)  -instance MonadWriter (Seq (Diagnostic e)) (Parser e) where+instance MonadWriter (ErrLog e) (Parser e) where   tell w = Parser $ \eo _ _ _ l -> eo () mempty (l <> w)   {-# INLINE tell #-}   listen (Parser m) = Parser $ \eo ee co ce l -> @@ -159,8 +160,8 @@     ce mempty { errMessage = Err rs Fatal e ds }   errWith ds rs e = Parser $ \_ ee _ _ ->      ee mempty { errMessage = Err rs Error e ds }-  logWith v ds rs e = Parser $ \eo _ _ _ l d bs -> -    eo () mempty (l |> Diagnostic (Right $ addCaret d $ Prelude.foldr (<>) (rendering d bs) rs) v e ds) d bs+  logWith v ds rs e = Parser $ \eo _ _ _ l b8 d bs -> +    eo () mempty l { errLog = errLog l |> Diagnostic (Right $ addCaret d $ Prelude.foldr (<>) (rendering d bs) rs) v e ds } b8 d bs      instance MonadError (ErrState e) (Parser e) where   throwError m = Parser $ \_ ee _ _ -> ee m@@ -169,11 +170,20 @@     m eo (\e -> unparser (k e) eo ee co ce) co ce   {-# INLINE catchError #-} +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+   unexpected s = Parser $ \ _ ee _ _ -> ee mempty { errMessage = FailErr $ "unexpected " ++ s }    labels (Parser p) msgs = Parser $ \ eo ee -> p@@ -182,72 +192,89 @@                      else e)      (\e -> ee e { errExpected = msgs })   {-# INLINE labels #-}-  liftIt m = Parser $ \ eo _ _ _ l d bs -> do +  liftIt m = Parser $ \ eo _ _ _ l b8 d bs -> do       a <- m-     eo a mempty l d bs+     eo a mempty l b8 d bs   {-# INLINE liftIt #-}-  mark = Parser $ \eo _ _ _ l d -> eo d mempty l d+  mark = Parser $ \eo _ _ _ l b8 d -> eo d mempty l b8 d   {-# INLINE mark #-}-  release d' = Parser $ \_ ee co _ l d bs -> do+  release d' = Parser $ \_ ee co _ l b8 d bs -> do     mbs <- rewindIt d'     case mbs of-      Just bs' -> co () mempty l d' bs'+      Just bs' -> co () mempty l (ascii bs') d' bs'       Nothing -        | bytes d' == bytes (rewind d) + Strict.length bs -> co () mempty l d' $ -                                                             if near d d' then bs else mempty-        | otherwise -> ee mempty l d bs-  {-# INLINE release #-}-  line = Parser $ \eo _ _ _ l d bs -> eo bs mempty l d bs+        | bytes d' == bytes (rewind d) + 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+  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 d bs ->-    case UTF8.uncons $ Strict.drop (columnByte d) bs of-      Nothing             -> ee mempty { errMessage = FailErr "unexpected EOF" } l d bs+  satisfy f = Parser $ \ _ ee co _ l b8 d bs ->+    if b8 -- fast path+    then let b = columnByte d in (+         if b >= 0 && b < Strict.length bs +         then case toEnum $ fromEnum $ Strict.index bs b of+           c | not (f c)                 -> ee mempty l b8 d bs+             | b == 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 "unexpected EOF" } l b8 d bs)+    else case UTF8.uncons $ Strict.drop (columnByte d) bs of+      Nothing             -> ee mempty { errMessage = FailErr "unexpected EOF" } l b8 d bs       Just (c, xs) -        | not (f c)       -> ee mempty l d bs+        | not (f c)       -> ee mempty l b8 d bs         | Strict.null xs  -> let !ddc = d <> delta c -                                 !bs' = if c == '\n' then mempty else bs-                             in join $ fillIt (co c mempty l ddc bs') (co c mempty l) ddc-        | otherwise       -> co c mempty l (d <> delta c) bs -  {-# INLINE satisfy #-}-  satisfy8 f = Parser $ \ _ ee co _ l d bs ->+                             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 < Strict.length bs      then case toEnum $ fromEnum $ Strict.index bs b of-      c | not (f c)                 -> ee mempty l d bs+      c | not (f c)                 -> ee mempty l b8 d bs         | b == Strict.length bs - 1 -> let !ddc = d <> delta c-                                           !bs' = if c == 10 then mempty else bs-                                       in join $ fillIt (co c mempty l ddc bs') (co c mempty l) ddc-        | otherwise                 -> co c mempty l (d <> delta c) bs-    else ee mempty { errMessage = FailErr "unexpected EOF" } l d bs-  {-# INLINE satisfy8 #-}+                                       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 "unexpected EOF" } l b8 d bs -data St e a = JuSt a !(ErrState e) !(ErrLog e) !Delta !ByteString-            | NoSt !(ErrState e) !(ErrLog e) !Delta !ByteString+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 -> Delta -> ByteString -> Diagnostic t) ->-              Parser e a -> ErrLog e -> Delta -> ByteString -> Step t a-stepParser yl y (Parser p) l0 d0 bs0 = -  go mempty $ p ju no ju no l0 d0 bs0+              (ErrState e -> Bool -> Delta -> ByteString -> Diagnostic t) ->+              Parser 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 d bs = Pure (JuSt a e l d bs)-    no e l d bs = Pure (NoSt e l d bs)-    go r (Pure (JuSt a _ l _ _)) = StepDone r (yl <$> l) a-    go r (Pure (NoSt e l d bs))   = StepFail r (yl <$> l) $ y e d bs+    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 <$> errLog l) a+    go r (Pure (NoSt e l b8 d bs)) = StepFail r (yl <$> errLog l) $ y e b8 d bs     go r (It ma k) = StepCont r (case ma of-                                   JuSt a _ l _ _  -> Success (yl <$> l) a-                                   NoSt e l d bs   -> Failure (yl <$> l) $ y e d bs) +                                   JuSt a _ l _ _ _  -> Success (yl <$> errLog l) a+                                   NoSt e l b8 d bs  -> Failure (yl <$> errLog l) $ y e b8 d bs)                                  (go <*> k) -why :: Pretty e => (e -> Doc t) -> ErrState e -> Delta -> ByteString -> Diagnostic (Doc t)-why pp (ErrState ss m) d bs +why :: Pretty e => (e -> Doc t) -> ErrState e -> Bool -> Delta -> ByteString -> Diagnostic (Doc t)+why pp (ErrState ss m) _ d bs    | Set.null ss = explicateWith empty m    | knownErr m  = explicateWith (char ',' <+> ex) m   | otherwise   = Diagnostic r Error ex []   where-    ex = text "expected" <+> fillSep (punctuate (char ',') $ text <$> toList ss) -- for once I wish I was writing this in Inform 7+    ex = text "expected:" <+> fillSep (punctuate (char ',') $ text <$> toList ss) -- TODO: oxford comma, "or" etc...     r = Right $ addCaret d $ rendering d bs     explicateWith x EmptyErr        = Diagnostic r  Error ((text "unspecified error") <> x)  []     explicateWith x (FailErr s)     = Diagnostic r  Error ((fillSep $ text <$> words s) <> x) []@@ -258,7 +285,7 @@ parseTest :: Show a => Parser String a -> String -> IO () parseTest p s = case starve                     $ feed (UTF8.fromString s) -                   $ stepParser (fmap prettyTerm) (why prettyTerm) (release mempty *> p) mempty mempty mempty of+                   $ stepParser (fmap prettyTerm) (why prettyTerm) (release mempty *> p) mempty True mempty mempty of   Failure xs e -> displayLn $ prettyTerm $ toList (xs |> e)   Success xs a -> do     unless (Seq.null xs) $ displayLn $ prettyTerm $ toList xs
Text/Trifecta/Parser/Token/Class.hs view
@@ -11,6 +11,7 @@ ----------------------------------------------------------------------------- module Text.Trifecta.Parser.Token.Class   ( MonadTokenParser(..)+  , TokenHighlight   ) where  import Control.Applicative@@ -24,6 +25,7 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity import Data.Monoid+import Text.Trifecta.Parser.Token.Highlight import Text.Trifecta.Parser.Class  class MonadParser m => MonadTokenParser m where
Text/Trifecta/Parser/Token/Combinators.hs view
@@ -40,6 +40,7 @@ import Text.Trifecta.Parser.Combinators import Text.Trifecta.Parser.Token.Class import Text.Trifecta.Parser.Token.Prim+import Text.Trifecta.Parser.Token.Highlight  -- | This lexeme parser parses a single literal character. Returns the -- literal character value. This parsers deals correctly with escape@@ -80,7 +81,7 @@   sign = negate <$ char '-'     <|> id <$ char '+'     <|> pure id-  int = lexeme sign <*> natural'+  int = lexeme (highlightToken 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@@ -101,13 +102,13 @@ -- trailing white space.   symbol :: MonadTokenParser m => ByteString -> m ByteString-symbol name = lexeme (byteString name)+symbol name = lexeme (highlightToken Symbol (byteString name))  -- | Lexeme parser @symbolic s@ parses 'char' @s@ and skips -- trailing white space.   symbolic :: MonadTokenParser m => Char -> m Char-symbolic name = lexeme (char name)+symbolic name = lexeme (highlightToken Symbol (char name))  -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis, -- returning the value of @p@.
+ Text/Trifecta/Parser/Token/Highlight.hs view
@@ -0,0 +1,19 @@+module Text.Trifecta.Parser.Token.Highlight +  ( TokenHighlight(..)+  ) where++data TokenHighlight+  = EscapeCode+  | Number +  | Comment+  | CharLiteral+  | StringLiteral+  | Constant+  | Statement+  | Special+  | Symbol+  | Identifier+  | ReservedIdentifier+  | Operator+  | ReservedOperator+  deriving (Eq,Ord,Show,Read)
Text/Trifecta/Parser/Token/Identifier.hs view
@@ -27,10 +27,12 @@ import Text.Trifecta.Parser.Token.Class  data IdentifierStyle m = IdentifierStyle-  { styleName         :: String-  , styleStart        :: m ()-  , styleLetter       :: m ()-  , styleReserved     :: HashSet ByteString+  { styleName              :: String+  , styleStart             :: m ()+  , styleLetter            :: m ()+  , styleReserved          :: HashSet ByteString+  , styleHighlight         :: TokenHighlight+  , styleReservedHighlight :: TokenHighlight   }  -- | parse a reserved operator or identifier@@ -40,13 +42,13 @@ -- | parse a reserved operator or identifier specified by bytestring reservedByteString :: MonadTokenParser m => IdentifierStyle m -> ByteString -> m () reservedByteString s name = lexeme $ try $ do-   _ <- byteString name +   _ <- highlightToken (styleReservedHighlight s) $ byteString name     notFollowedBy (styleLetter s) <?> "end of " ++ show name  -- | parse an non-reserved identifier or symbol ident :: MonadTokenParser m => IdentifierStyle m -> m ByteString ident s = lexeme $ try $ do-  name <- sliced (styleStart s *> skipMany (styleLetter s)) <?> styleName s+  name <- highlightToken (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/Token/Identifier/Style.hs view
@@ -25,6 +25,7 @@ import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Token.Class import Text.Trifecta.Parser.Token.Identifier+import Text.Trifecta.Parser.Token.Highlight  set :: [String] -> HashSet ByteString set = HashSet.fromList . fmap UTF8.fromString@@ -35,6 +36,8 @@   , styleStart    = styleLetter emptyOps   , styleLetter   = () <$ oneOf ":!#$%&*+./<=>?@\\^|-~"   , styleReserved = mempty+  , styleHighlight = Operator+  , styleReservedHighlight = ReservedOperator   } haskell98Ops = emptyOps    { styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"]@@ -46,7 +49,9 @@   { styleName     = "identifier"   , styleStart    = () <$ (letter <|> char '_')   , styleLetter   = () <$ (alphaNum <|> oneOf "_'")-  , styleReserved = set [] }+  , styleReserved = set []+  , styleHighlight = Identifier+  , styleReservedHighlight = ReservedIdentifier }   haskell98Idents = emptyIdents   { styleReserved = set haskell98ReservedIdents }
Text/Trifecta/Parser/Token/Prim.hs view
@@ -29,6 +29,7 @@ import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Combinators+import Text.Trifecta.Parser.Token.Highlight  -- | This parser parses a single literal character. Returns the -- literal character value. This parsers deals correctly with escape@@ -38,13 +39,13 @@ -- -- This parser does NOT swallow trailing whitespace.  charLiteral' :: MonadParser m => m Char-charLiteral' = between (char '\'') (char '\'' <?> "end of character") characterChar+charLiteral' = highlightToken CharLiteral (between (char '\'') (char '\'' <?> "end of character") characterChar)           <?> "character"   characterChar, charEscape, charLetter :: MonadParser m => m Char characterChar = charLetter <|> charEscape             <?> "literal character"-charEscape = char '\\' *> escapeCode+charEscape = highlightToken EscapeCode $ char '\\' *> escapeCode charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))  -- | This parser parses a literal string. Returns the literal@@ -55,7 +56,7 @@ -- -- This parser does NOT swallow trailing whitespace stringLiteral' :: MonadParser m => m String-stringLiteral' = lit where+stringLiteral' = highlightToken StringLiteral lit where   lit = Prelude.foldr (maybe id (:)) "" <$> between (char '"') (char '"' <?> "end of string") (many stringChar)      <?> "literal string"   stringChar = Just <$> stringLetter @@ -63,7 +64,7 @@        <?> "string character"   stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) -  stringEscape = char '\\' *> esc where+  stringEscape = highlightToken EscapeCode $ char '\\' *> esc where     esc = Nothing <$ escapeGap        <|> Nothing <$ escapeEmpty        <|> Just <$> escapeCode@@ -107,7 +108,7 @@ -- -- This parser does NOT swallow trailing whitespace.  natural' :: MonadParser m => m Integer-natural' = nat <?> "natural"+natural' = highlightToken Number nat <?> "natural"  number :: MonadParser m => Integer -> m Char -> m Integer number base baseDigit = do@@ -130,12 +131,13 @@ integer' = int <?> "integer"  sign :: MonadParser m => m (Integer -> Integer)-sign = negate <$ char '-'+sign = highlightToken Operator+     $ negate <$ char '-'    <|> id <$ char '+'    <|> pure id  int :: MonadParser m => m Integer-int = {-lexeme-} sign <*> nat+int = {-lexeme-} sign <*> highlightToken Number nat nat, zeroNumber :: MonadParser m => m Integer nat = zeroNumber <|> decimal zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> return 0) <?> ""@@ -147,7 +149,7 @@ -- This parser does NOT swallow trailing whitespace.   double' :: MonadParser m => m Double-double' = floating <?> "double"+double' = highlightToken Number floating <?> "double"  floating :: MonadParser m => m Double floating = decimal >>= fractExponent@@ -167,7 +169,8 @@     | e < 0     = 1.0/power(-e)     | otherwise = fromInteger (10^e) --- | This parser parses either 'natural' or a 'float'.++-- | 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. @@ -175,7 +178,7 @@ -- This parser does NOT swallow trailing whitespace.   naturalOrDouble' :: MonadParser m => m (Either Integer Double)-naturalOrDouble' = natDouble <?> "number"+naturalOrDouble' = highlightToken Number natDouble <?> "number"  natDouble, zeroNumFloat, decimalFloat :: MonadParser m => m (Either Integer Double) natDouble @@ -200,14 +203,14 @@ decimal = number 10 digit  -- | Parses a positive whole number in the hexadecimal system. The number--- should be prefixed with \"0x\" or \"0X\". Returns the value of the+-- 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 \"0o\" or \"0O\". Returns the value of the+-- should be prefixed with \"o\" or \"O\". Returns the value of the -- number.   octal :: MonadParser m => m Integer
Text/Trifecta/Parser/Token/Style.hs view
@@ -23,6 +23,7 @@ import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Combinators+import Text.Trifecta.Parser.Token.Highlight  data CommentStyle = CommentStyle    { commentStart   :: String@@ -47,11 +48,11 @@     noLine  = null lineStyle     noMulti = null startStyle     simpleSpace = skipSome (satisfy isSpace)-    oneLineComment = do+    oneLineComment = highlightToken Comment $ do       _ <- try $ string lineStyle       skipMany (satisfyAscii (/= '\n')) -- TODO: use skipping/restOfLine and fiddle with the last byte       return ()-    multiLineComment = do+    multiLineComment = highlightToken Comment $ do       _ <- try $ string startStyle       inComment     inComment
trifecta.cabal view
@@ -1,6 +1,6 @@ name:          trifecta category:      Text, Parsing, Diagnostics, Pretty Printer, Logging-version:       0.30+version:       0.31 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -41,6 +41,7 @@     Text.Trifecta.Diagnostic.Combinators     Text.Trifecta.Diagnostic.Level     Text.Trifecta.Diagnostic.Err+    Text.Trifecta.Diagnostic.Err.Log     Text.Trifecta.Diagnostic.Err.State     Text.Trifecta.Diagnostic.Rendering     Text.Trifecta.Diagnostic.Rendering.Prim@@ -63,6 +64,7 @@     Text.Trifecta.Parser.Token.Combinators     Text.Trifecta.Parser.Token.Prim     Text.Trifecta.Parser.Token.Style+    Text.Trifecta.Parser.Token.Highlight     Text.Trifecta.Parser.Token.Identifier     Text.Trifecta.Parser.Token.Identifier.Style @@ -88,6 +90,7 @@     semigroupoids        >= 1.2.4   && < 1.3,     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,     terminfo             >= 0.3.2   && < 0.4,     keys                 >= 2.1     && < 2.2,