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 :: !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 :@ !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