packages feed

trifecta 0.35 → 0.36

raw patch · 29 files changed

+614/−201 lines, 29 filesdep +blaze-builderdep +blaze-htmldep +pointeddep ~basedep ~wl-pprint-extras

Dependencies added: blaze-builder, blaze-html, pointed

Dependency ranges changed: base, wl-pprint-extras

Files

LICENSE view
@@ -1,5 +1,6 @@ Copyright 2010-2011 Edward Kmett Copyright 2008 Bryan O'Sullivan+Copyright 2008 Ross Patterson Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen
Text/Trifecta/Diagnostic/Err/Log.hs view
@@ -4,27 +4,26 @@  import Data.Functor.Plus import Data.Semigroup-import Text.PrettyPrint.Free+import Text.PrettyPrint.Free hiding (empty) import Text.Trifecta.Diagnostic.Prim-import Text.Trifecta.Rope.Delta-import Text.Trifecta.Parser.Token.Highlight-import Data.IntervalMap.FingerTree as IntervalMap+import Text.Trifecta.Highlight.Prim+import Data.Semigroup.Union (union, empty) import Data.Sequence (Seq)  data ErrLog e = ErrLog   { errLog        :: !(Seq (Diagnostic e))-  , errHighlights :: !(IntervalMap Delta TokenHighlight) +  , 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') (IntervalMap.union b b')+  ErrLog a b <!> ErrLog a' b' = ErrLog (a <> a') (union b b')   {-# INLINE (<!>) #-}  instance Plus ErrLog where-  zero = ErrLog mempty IntervalMap.empty+  zero = ErrLog mempty empty   instance Semigroup (ErrLog e) where   (<>) = (<!>)
Text/Trifecta/Diagnostic/Level.hs view
@@ -43,7 +43,7 @@   pretty p = prettyTerm p *> empty  instance PrettyTerm DiagnosticLevel where-  prettyTerm (Verbose n) = blue    $ text "verbose (" <> int n <> char ')'+  prettyTerm (Verbose n) = blue    $ text "verbose (" <> prettyTerm n <> char ')'   prettyTerm Note        = black   $ text "note"   prettyTerm Warning     = magenta $ text "warning"   prettyTerm Error       = red            $ text "error"
Text/Trifecta/Diagnostic/Prim.hs view
@@ -22,12 +22,16 @@ 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)
Text/Trifecta/Diagnostic/Rendering/Caret.hs view
@@ -44,7 +44,7 @@ caretEffects = [soft (Foreground Green), soft Bold]  drawCaret :: Delta -> Delta -> Lines -> Lines-drawCaret p = ifNear p $ draw caretEffects 1 (column p) "^"+drawCaret p = ifNear p $ draw caretEffects 1 (fromIntegral (column p)) "^"  addCaret :: Delta -> Rendering -> Rendering addCaret p r = drawCaret p .# r
Text/Trifecta/Diagnostic/Rendering/Fixit.hs view
@@ -27,7 +27,7 @@ -- >                  ^ -- >                  , drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines-drawFixit s e rpl d a = ifNear l (draw [soft (Foreground Blue)] 2 (column l) rpl) d +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
Text/Trifecta/Diagnostic/Rendering/Prim.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}  -- | Diagnostics rendering --@@ -40,6 +40,7 @@ import Text.PrettyPrint.Free hiding (column) import Text.Trifecta.Rope.Bytes import Text.Trifecta.Rope.Delta+import Text.Trifecta.Highlight.Class import qualified Data.ByteString.UTF8 as UTF8   outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect]@@ -50,7 +51,6 @@ (///) :: 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@@ -78,6 +78,9 @@   , renderingOverlays :: Delta -> Lines -> Lines   } +instance Highlightable Rendering where+  addHighlights _h r = r -- TODO+ instance Show Rendering where   showsPrec d (Rendering p ll _ _) = showParen (d > 10) $      showString "Rendering " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showString " ... ..."@@ -145,11 +148,11 @@ instance PrettyTerm Rendering where   prettyTerm (Rendering d ll l f) = nesting $ \k -> columns $ \n -> go (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)+      (lo, hi) = window (fromIntegral $ 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 (string (P.map snd g)) (fst (P.head g)))+           $ P.map (\g -> P.foldr with (pretty (P.map snd g)) (fst (P.head g)))            $ groupBy ((==) `on` fst)             [ a ! (y,i) | i <- [lo..hi] ]
Text/Trifecta/Diagnostic/Rendering/Span.hs view
@@ -36,12 +36,12 @@  drawSpan :: Delta -> Delta -> Delta -> Lines -> Lines drawSpan s e d a-  | nl && nh  = go (column l) (P.replicate (max (column h - column l) 0) '~') a-  | nl        = go (column l) (P.replicate (max (snd (snd (bounds a)) - column l + 1) 0) '~') a-  |       nh  = go (-1)       (P.replicate (max (column h + 1) 0) '~') a+  | nl && nh  = go (column l) (P.replicate (fromIntegral (max (column h - column l) 0)) '~') a+  | nl        = go (column l) (P.replicate (max (snd (snd (bounds a)) - fromIntegral (column l) + 1) 0) '~') a+  |       nh  = go (-1)       (P.replicate (fromIntegral (max (column h + 1) 0)) '~') a   | otherwise = a   where-    go = draw spanEffects 1+    go = draw spanEffects 1 . fromIntegral     l = argmin bytes s e     h = argmax bytes s e     nl = near l d
+ Text/Trifecta/Highlight/Class.hs view
@@ -0,0 +1,8 @@+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 view
@@ -0,0 +1,30 @@+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 Green]+highlightEffects ReservedIdentifier = [soft $ Foreground Blue]+highlightEffects Operator           = [soft $ Foreground Yellow]+highlightEffects ReservedOperator   = [soft $ Foreground Yellow]+highlightEffects EscapeCode         = [soft $ Foreground Magenta, soft Bold]+highlightEffects CharLiteral        = [soft $ Foreground Cyan]+highlightEffects StringLiteral      = [soft $ Foreground Cyan]+-- highlightEffects Identifier      = []+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 view
@@ -0,0 +1,28 @@+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+  deriving (Eq,Ord,Show,Read,Enum,Ix,Bounded)++type Highlights = IntervalMap Delta Highlight++
+ Text/Trifecta/Highlight/Rendering/HTML.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+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/Highlighter/Class.hs 
@@ -1,48 +0,0 @@-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
+ Text/Trifecta/IntervalMap.hs view
@@ -0,0 +1,276 @@+{-# 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.Functor.Apply+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/Parser/Class.hs view
@@ -42,7 +42,7 @@ import Text.Trifecta.Rope.Delta import Text.Trifecta.Rope.Prim import Text.Trifecta.Parser.It-import Text.Trifecta.Parser.Token.Highlight+import Text.Trifecta.Highlight.Prim import Text.Trifecta.Diagnostic.Rendering.Prim -- import Control.Monad.Trans.Maybe.Strict as Strict -- import Control.Monad.Trans.Either.Strict as Strict@@ -55,39 +55,36 @@   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+  -- | 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+  -- | @highlight@ 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.+  highlight :: Highlight -> m a -> m a+  highlight _ m = m+++   -- | 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@@ -99,7 +96,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (Lazy.StateT m) = Lazy.StateT $ \e -> highlightToken t (m e) +  highlight t (Lazy.StateT m) = Lazy.StateT $ \e -> highlight t (m e)   instance MonadParser m => MonadParser (Strict.StateT s m) where   try (Strict.StateT m) = Strict.StateT $ try . m@@ -111,7 +108,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (Strict.StateT m) = Strict.StateT $ \e -> highlightToken t (m e) +  highlight t (Strict.StateT m) = Strict.StateT $ \e -> highlight t (m e)   instance MonadParser m => MonadParser (ReaderT e m) where   try (ReaderT m) = ReaderT $ try . m@@ -123,7 +120,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (ReaderT m) = ReaderT $ \e -> highlightToken t (m e) +  highlight t (ReaderT m) = ReaderT $ \e -> highlight t (m e)   instance (MonadParser m, Monoid w) => MonadParser (Strict.WriterT w m) where   try (Strict.WriterT m) = Strict.WriterT $ try m@@ -135,7 +132,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (Strict.WriterT m) = Strict.WriterT $ highlightToken t m+  highlight t (Strict.WriterT m) = Strict.WriterT $ highlight t m  instance (MonadParser m, Monoid w) => MonadParser (Lazy.WriterT w m) where   try (Lazy.WriterT m) = Lazy.WriterT $ try m@@ -147,7 +144,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (Lazy.WriterT m) = Lazy.WriterT $ highlightToken t m+  highlight t (Lazy.WriterT m) = Lazy.WriterT $ highlight 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)@@ -159,7 +156,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (Lazy.RWST m) = Lazy.RWST $ \r s -> highlightToken t (m r s)+  highlight t (Lazy.RWST m) = Lazy.RWST $ \r s -> highlight 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)@@ -171,7 +168,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (Strict.RWST m) = Strict.RWST $ \r s -> highlightToken t (m r s)+  highlight t (Strict.RWST m) = Strict.RWST $ \r s -> highlight t (m r s)  instance MonadParser m => MonadParser (IdentityT m) where   try (IdentityT m) = IdentityT $ try m@@ -183,7 +180,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (IdentityT m) = IdentityT $ highlightToken t m+  highlight t (IdentityT m) = IdentityT $ highlight t m  instance MonadParser m => MonadParser (Yoneda m) where   try = lift . try . lowerYoneda@@ -195,7 +192,7 @@   unexpected = lift . unexpected   satisfy = lift . satisfy   satisfy8 = lift . satisfy8-  highlightToken t (Yoneda m) = Yoneda $ \f -> highlightToken t (m f)+  highlight t (Yoneda m) = Yoneda $ \f -> highlight t (m f)  {- instance MonadParser m => MonadParser (Codensity m) where@@ -228,7 +225,7 @@ restOfLine :: MonadParser m => m ByteString restOfLine = do   m <- mark-  Strict.drop (columnByte m) <$> line+  Strict.drop (fromIntegral (columnByte m)) <$> line {-# INLINE restOfLine #-}  -- | label a parser with a name
Text/Trifecta/Parser/Prim.hs view
@@ -28,8 +28,7 @@ import Data.Semigroup import Data.Foldable import Data.Functor.Bind (Apply(..), Bind((>>-)))-import Data.IntervalMap.FingerTree (Interval(..))-import qualified Data.IntervalMap.FingerTree as IntervalMap+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)@@ -46,7 +45,8 @@ 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.Highlight.Class+import Text.Trifecta.Highlight.Prim import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.It import Text.Trifecta.Parser.Step@@ -179,8 +179,8 @@   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 d d') t (errHighlights l') } b8' d') ce l b8 d bs+  highlight 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 d d' t (errHighlights l') } b8' d') ce l b8 d bs    unexpected s = Parser $ \ _ ee _ _ -> ee mempty { errMessage = FailErr $ "unexpected " ++ s } @@ -201,7 +201,7 @@     case mbs of       Just bs' -> co () mempty l (ascii bs') d' bs'       Nothing -        | bytes d' == bytes (rewind d) + Strict.length bs -> if near d d' +        | 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@@ -212,10 +212,10 @@   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+         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 == Strict.length bs - 1 -> let !ddc = d <> delta c+             | 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 )@@ -223,7 +223,7 @@                                                              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+    else case UTF8.uncons $ Strict.drop (fromIntegral (columnByte d)) bs of       Nothing             -> ee mempty { errMessage = FailErr "unexpected EOF" } l b8 d bs       Just (c, xs)          | not (f c)       -> ee mempty l b8 d bs@@ -236,10 +236,10 @@         | 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+    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 == Strict.length bs - 1 -> let !ddc = d <> delta c+        | 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 )@@ -248,40 +248,40 @@         | 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+-- instance MonadHighlight (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  stepParser :: (Diagnostic e -> Diagnostic t) -> -              (ErrState e -> Bool -> Delta -> ByteString -> Diagnostic t) ->+              (ErrState e -> Highlights -> 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 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 (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 <$> errLog l) a-                                   NoSt e l b8 d bs  -> Failure ((yl <$> errLog l) |> y e b8 d bs)) +                                   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 -> Bool -> Delta -> ByteString -> Diagnostic (Doc t)-why pp (ErrState ss m) _ d bs +why :: Pretty e => (e -> Doc t) -> ErrState e -> Highlights -> Bool -> Delta -> ByteString -> Diagnostic (Doc t)+why pp (ErrState ss m) hs _ 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) -- 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) []-    explicateWith x (PanicErr s)    = Diagnostic r  Panic ((fillSep $ text <$> words s) <> x) []-    explicateWith x (Err rs l e es) = Diagnostic r' l (pp e <> x) (fmap (fmap pp) es)-      where r' = Right $ addCaret d $ Prelude.foldr (<>) (rendering d bs) rs+    r = Right $ addCaret d $ addHighlights hs $ 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) []+    explicateWith x (PanicErr s)    = Diagnostic r Panic ((fillSep $ text <$> words s) <> x) []+    explicateWith x (Err rs l e es) = Diagnostic r' l (pp e <> x) (fmap (addHighlights hs . fmap pp) es)+      where r' = Right $ addCaret d $ Prelude.foldr (<>) (addHighlights hs $ rendering d bs) rs  parseTest :: Show a => Parser String a -> String -> IO () parseTest p s = case starve
Text/Trifecta/Parser/Result.hs view
@@ -21,14 +21,14 @@  instance (Pretty e, Show a) => Pretty (Result e a) where   pretty (Success xs a) -    | Seq.null xs = string (show a)-    | otherwise   = prettyList (toList xs) `above` string (show 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 = string (show a)-    | otherwise   = prettyTermList (toList xs) `above` string (show 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
Text/Trifecta/Parser/Token/Class.hs view
@@ -11,7 +11,6 @@ ----------------------------------------------------------------------------- module Text.Trifecta.Parser.Token.Class   ( MonadTokenParser(..)-  , TokenHighlight   ) where  import Control.Applicative@@ -25,7 +24,6 @@ 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,7 +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+import Text.Trifecta.Highlight.Prim  -- | This lexeme parser parses a single literal character. Returns the -- literal character value. This parsers deals correctly with escape@@ -81,7 +81,7 @@   sign = negate <$ char '-'     <|> id <$ char '+'     <|> pure id-  int = lexeme (highlightToken Operator sign) <*> natural'+  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@@ -102,13 +102,13 @@ -- trailing white space.   symbol :: MonadTokenParser m => ByteString -> m ByteString-symbol name = lexeme (highlightToken Symbol (byteString name))+symbol name = lexeme (highlight Symbol (byteString name))  -- | Lexeme parser @symbolic s@ parses 'char' @s@ and skips -- trailing white space.   symbolic :: MonadTokenParser m => Char -> m Char-symbolic name = lexeme (highlightToken Symbol (char name))+symbolic name = lexeme (highlight Symbol (char name))  -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis, -- returning the value of @p@.
− Text/Trifecta/Parser/Token/Highlight.hs 
@@ -1,19 +0,0 @@-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
@@ -29,14 +29,15 @@ import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Combinators import Text.Trifecta.Parser.Token.Class+import Text.Trifecta.Highlight.Prim  data IdentifierStyle m = IdentifierStyle   { styleName              :: String   , styleStart             :: m ()   , styleLetter            :: m ()   , styleReserved          :: HashSet ByteString-  , styleHighlight         :: TokenHighlight-  , styleReservedHighlight :: TokenHighlight+  , styleHighlight         :: Highlight+  , styleReservedHighlight :: Highlight   }  -- | parse a reserved operator or identifier using a given style@@ -46,13 +47,13 @@ -- | parse a reserved operator or identifier using a given style specified by bytestring reserveByteString :: MonadTokenParser m => IdentifierStyle m -> ByteString -> m () reserveByteString s name = lexeme $ try $ do-   _ <- highlightToken (styleReservedHighlight s) $ byteString name +   _ <- highlight (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 <- highlightToken (styleHighlight s) (sliced (styleStart s *> skipMany (styleLetter s))) <?> styleName s+  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/Token/Identifier/Style.hs view
@@ -25,7 +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+import Text.Trifecta.Highlight.Prim  set :: [String] -> HashSet ByteString set = HashSet.fromList . fmap UTF8.fromString
Text/Trifecta/Parser/Token/Prim.hs view
@@ -29,7 +29,7 @@ import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Combinators-import Text.Trifecta.Parser.Token.Highlight+import Text.Trifecta.Highlight.Prim  -- | This parser parses a single literal character. Returns the -- literal character value. This parsers deals correctly with escape@@ -39,13 +39,13 @@ -- -- This parser does NOT swallow trailing whitespace.  charLiteral' :: MonadParser m => m Char-charLiteral' = highlightToken CharLiteral (between (char '\'') (char '\'' <?> "end of character") characterChar)+charLiteral' = highlight CharLiteral (between (char '\'') (char '\'' <?> "end of character") characterChar)           <?> "character"   characterChar, charEscape, charLetter :: MonadParser m => m Char characterChar = charLetter <|> charEscape             <?> "literal character"-charEscape = highlightToken EscapeCode $ char '\\' *> escapeCode+charEscape = highlight EscapeCode $ char '\\' *> escapeCode charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))  -- | This parser parses a literal string. Returns the literal@@ -56,7 +56,7 @@ -- -- This parser does NOT swallow trailing whitespace stringLiteral' :: MonadParser m => m String-stringLiteral' = highlightToken StringLiteral lit where+stringLiteral' = highlight StringLiteral lit where   lit = Prelude.foldr (maybe id (:)) "" <$> between (char '"') (char '"' <?> "end of string") (many stringChar)      <?> "literal string"   stringChar = Just <$> stringLetter @@ -64,7 +64,7 @@        <?> "string character"   stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) -  stringEscape = highlightToken EscapeCode $ char '\\' *> esc where+  stringEscape = highlight EscapeCode $ char '\\' *> esc where     esc = Nothing <$ escapeGap        <|> Nothing <$ escapeEmpty        <|> Just <$> escapeCode@@ -108,7 +108,7 @@ -- -- This parser does NOT swallow trailing whitespace.  natural' :: MonadParser m => m Integer-natural' = highlightToken Number nat <?> "natural"+natural' = highlight Number nat <?> "natural"  number :: MonadParser m => Integer -> m Char -> m Integer number base baseDigit = do@@ -131,13 +131,13 @@ integer' = int <?> "integer"  sign :: MonadParser m => m (Integer -> Integer)-sign = highlightToken Operator+sign = highlight Operator      $ negate <$ char '-'    <|> id <$ char '+'    <|> pure id  int :: MonadParser m => m Integer-int = {-lexeme-} sign <*> highlightToken Number nat+int = {-lexeme-} sign <*> highlight Number nat nat, zeroNumber :: MonadParser m => m Integer nat = zeroNumber <|> decimal zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> return 0) <?> ""@@ -149,7 +149,7 @@ -- This parser does NOT swallow trailing whitespace.   double' :: MonadParser m => m Double-double' = highlightToken Number floating <?> "double"+double' = highlight Number floating <?> "double"  floating :: MonadParser m => m Double floating = decimal >>= fractExponent@@ -178,7 +178,7 @@ -- This parser does NOT swallow trailing whitespace.   naturalOrDouble' :: MonadParser m => m (Either Integer Double)-naturalOrDouble' = highlightToken Number natDouble <?> "number"+naturalOrDouble' = highlight Number natDouble <?> "number"  natDouble, zeroNumFloat, decimalFloat :: MonadParser m => m (Either Integer Double) natDouble
Text/Trifecta/Parser/Token/Style.hs view
@@ -23,7 +23,7 @@ import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Combinators-import Text.Trifecta.Parser.Token.Highlight+import Text.Trifecta.Highlight.Prim  data CommentStyle = CommentStyle    { commentStart   :: String@@ -48,11 +48,11 @@     noLine  = null lineStyle     noMulti = null startStyle     simpleSpace = skipSome (satisfy isSpace)-    oneLineComment = highlightToken Comment $ do+    oneLineComment = highlight Comment $ do       _ <- try $ string lineStyle       skipMany (satisfyAscii (/= '\n')) -- TODO: use skipping/restOfLine and fiddle with the last byte       return ()-    multiLineComment = highlightToken Comment $ do+    multiLineComment = highlight Comment $ do       _ <- try $ string startStyle       inComment     inComment
Text/Trifecta/Rope/Bytes.hs view
@@ -4,12 +4,13 @@  import Data.ByteString as Strict import Data.FingerTree+import Data.Int (Int64)  class HasBytes t where-  bytes :: t -> Int+  bytes :: t -> Int64  instance HasBytes ByteString where-  bytes = Strict.length+  bytes = fromIntegral . Strict.length  instance (Measured v a, HasBytes v) => HasBytes (FingerTree v a) where   bytes = bytes . measure
Text/Trifecta/Rope/Delta.hs view
@@ -11,6 +11,7 @@ import Control.Applicative import Data.Semigroup import Data.Hashable+import Data.Int import Data.Word import Data.Foldable import Data.Function (on)@@ -22,20 +23,20 @@ import System.Console.Terminfo.PrettyPrint  data Delta-  = Columns   {-# UNPACK #-} !Int  -- the number of characters-              {-# UNPACK #-} !Int  -- the number of bytes-  | Tab       {-# UNPACK #-} !Int  -- the number of characters before the tab-              {-# UNPACK #-} !Int  -- the number of characters after the tab-              {-# UNPACK #-} !Int  -- the number of bytes-  | Lines     {-# UNPACK #-} !Int  -- the number of newlines contained-              {-# 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-  | Directed  !ByteString          -- current file name-              {-# UNPACK #-} !Int  -- the number of lines since the last line directive-              {-# 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+  = 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@@ -57,10 +58,13 @@     Lines l c _ _ -> k f l c     Directed fn l c _ _ -> k (UTF8.toString fn) l c     where -      k fn ln cn = bold (string fn) <> char ':' <> bold (int (ln+1)) <> char ':' <> bold (int (cn+1))+      k fn ln cn = bold (pretty fn) <> char ':' <> bold (int64 (ln+1)) <> char ':' <> bold (int64 (cn+1))       f = "(interactive)" -column :: HasDelta t => t -> Int+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@@ -68,7 +72,7 @@   Directed _ _ c _ _ -> c {-# INLINE column #-} -columnByte :: Delta -> Int+columnByte :: Delta -> Int64 columnByte (Columns _ b) = b columnByte (Tab _ _ b) = b columnByte (Lines _ _ _ b) = b@@ -109,7 +113,7 @@   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 :: Int -> Int+nextTab :: Int64 -> Int64 nextTab x = x + (8 - mod x 8) {-# INLINE nextTab #-}
+ Text/Trifecta/Rope/Highlighted.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+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 view
@@ -18,13 +18,14 @@ import Data.FingerTree as FingerTree import Data.Foldable (toList) import Data.Hashable+import Data.Int (Int64) import Text.Trifecta.Util as Util import Text.Trifecta.Rope.Bytes import Text.Trifecta.Rope.Delta  data Strand   = Strand        {-# UNPACK #-} !ByteString !Delta-  | LineDirective {-# UNPACK #-} !ByteString {-# UNPACK #-} !Int+  | LineDirective {-# UNPACK #-} !ByteString {-# UNPACK #-} !Int64   deriving Show  strand :: ByteString -> Strand@@ -36,7 +37,7 @@  instance Hashable Strand where   hash (Strand h _) = hashWithSalt 0 h-  hash (LineDirective p l)   = l `hashWithSalt` p+  hash (LineDirective p l) = hash l `hashWithSalt` p  instance HasDelta Strand where   delta = measure@@ -57,7 +58,7 @@ 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 k 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 ]@@ -100,5 +101,3 @@   unit = unit . strand . UTF8.fromString   cons = cons . strand . UTF8.fromString   snoc r = snoc r . strand . UTF8.fromString--
trifecta.cabal view
@@ -1,6 +1,6 @@ name:          trifecta category:      Text, Parsing, Diagnostics, Pretty Printer, Logging-version:       0.35+version:       0.36 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -35,10 +35,12 @@     Text.Trifecta.CharSet.Unicode     Text.Trifecta.CharSet.Unicode.Block     Text.Trifecta.CharSet.Unicode.Category+    Text.Trifecta.IntervalMap     Text.Trifecta.Rope     Text.Trifecta.Rope.Bytes     Text.Trifecta.Rope.Delta     Text.Trifecta.Rope.Prim+    Text.Trifecta.Rope.Highlighted     Text.Trifecta.Diagnostic     Text.Trifecta.Diagnostic.Prim     Text.Trifecta.Diagnostic.Class@@ -52,7 +54,10 @@     Text.Trifecta.Diagnostic.Rendering.Caret     Text.Trifecta.Diagnostic.Rendering.Fixit     Text.Trifecta.Diagnostic.Rendering.Span-    Text.Trifecta.Highlighter.Class+    Text.Trifecta.Highlight.Class+    Text.Trifecta.Highlight.Prim+    Text.Trifecta.Highlight.Effects+    Text.Trifecta.Highlight.Rendering.HTML     Text.Trifecta.Parser     Text.Trifecta.Parser.ByteString     Text.Trifecta.Parser.Char@@ -70,7 +75,6 @@     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 @@ -84,6 +88,8 @@     array                >= 0.3.0.2 && < 0.4,      containers           >= 0.3     && < 0.5,     unordered-containers >= 0.1.4   && < 0.2,+    blaze-builder        >= 0.3.0.1 && < 0.4,+    blaze-html           >= 0.4.1.6 && < 0.5,     bifunctors           >= 0.1.1.3 && < 0.2,     hashable             >= 1.1.2.1 && < 1.2,     bytestring           >= 0.9.1   && < 0.10,@@ -95,10 +101,11 @@     utf8-string          >= 0.3.6   && < 0.4,     semigroupoids        >= 1.2.4   && < 1.3,     parallel             >= 3.1.0.1 && < 3.2,+    pointed              >= 2       && < 2.1,     transformers         >= 0.2.2   && < 0.3,     kan-extensions       >= 2.0.1   && < 2.1,     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-extras     >= 1.6     && < 1.7,     wl-pprint-terminfo   >= 0.7     && < 0.8