{-# language CPP #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell #-}

#ifndef MIN_VERSION_lens
#define MIN_VERSION_lens(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2019 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Text.Trifecta.Highlight
  ( Highlight
  , HighlightedRope(HighlightedRope)
  , HasHighlightedRope(..)
  , withHighlight
  , HighlightDoc(HighlightDoc)
  , HasHighlightDoc(..)
  , doc
  ) where

import Control.Lens
#if MIN_VERSION_lens(4,13,0) && __GLASGOW_HASKELL__ >= 710
  hiding (Empty)
#endif
import Data.Foldable as F
import Data.Int (Int64)
import Data.List (sort)
import Data.Semigroup
import Data.Semigroup.Union
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal (color)
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty
import Prelude hiding (head)
import Text.Blaze
import Text.Blaze.Html5 hiding (a,b,i)
import qualified Text.Blaze.Html5 as Html5
import Text.Blaze.Html5.Attributes hiding (title,id)
import Text.Blaze.Internal (MarkupM(Empty, Leaf))
import Text.Parser.Token.Highlight
import qualified Data.ByteString.Lazy.Char8 as L

import Text.Trifecta.Delta
import Text.Trifecta.Rope
import Text.Trifecta.Util.IntervalMap as IM
import Text.Trifecta.Util.Pretty

-- | Convert a 'Highlight' into a coloration on a 'Doc'.
withHighlight :: Highlight -> Doc AnsiStyle -> Doc AnsiStyle
withHighlight :: Highlight -> Doc AnsiStyle -> Doc AnsiStyle
withHighlight Comment                     = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Blue)
withHighlight ReservedIdentifier          = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight ReservedConstructor         = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight EscapeCode                  = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight Operator                    = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight CharLiteral                 = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Cyan)
withHighlight StringLiteral               = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Cyan)
withHighlight Constructor                 = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
Pretty.bold
withHighlight ReservedOperator            = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight ConstructorOperator         = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight ReservedConstructorOperator = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight _                           = Doc AnsiStyle -> Doc AnsiStyle
forall a. a -> a
id

-- | A 'HighlightedRope' is a 'Rope' with an associated 'IntervalMap' full of highlighted regions.
data HighlightedRope = HighlightedRope
  { HighlightedRope -> IntervalMap Delta Highlight
_ropeHighlights :: !(IM.IntervalMap Delta Highlight)
  , HighlightedRope -> Rope
_ropeContent    :: {-# UNPACK #-} !Rope
  }

makeClassy ''HighlightedRope

instance HasDelta HighlightedRope where
  delta :: HighlightedRope -> Delta
delta = Rope -> Delta
forall t. HasDelta t => t -> Delta
delta (Rope -> Delta)
-> (HighlightedRope -> Rope) -> HighlightedRope -> Delta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HighlightedRope -> Rope
_ropeContent

instance HasBytes HighlightedRope where
  bytes :: HighlightedRope -> Int64
bytes = Rope -> Int64
forall t. HasBytes t => t -> Int64
bytes (Rope -> Int64)
-> (HighlightedRope -> Rope) -> HighlightedRope -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HighlightedRope -> Rope
_ropeContent

instance Semigroup HighlightedRope where
  HighlightedRope h :: IntervalMap Delta Highlight
h bs :: Rope
bs <> :: HighlightedRope -> HighlightedRope -> HighlightedRope
<> HighlightedRope h' :: IntervalMap Delta Highlight
h' bs' :: Rope
bs' = IntervalMap Delta Highlight -> Rope -> HighlightedRope
HighlightedRope (IntervalMap Delta Highlight
h IntervalMap Delta Highlight
-> IntervalMap Delta Highlight -> IntervalMap Delta Highlight
forall f. HasUnion f => f -> f -> f
`union` Delta -> IntervalMap Delta Highlight -> IntervalMap Delta Highlight
forall v a.
(Ord v, Monoid v) =>
v -> IntervalMap v a -> IntervalMap v a
IM.offset (Rope -> Delta
forall t. HasDelta t => t -> Delta
delta Rope
bs) IntervalMap Delta Highlight
h') (Rope
bs Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
bs')

instance Monoid HighlightedRope where
  mappend :: HighlightedRope -> HighlightedRope -> HighlightedRope
mappend = HighlightedRope -> HighlightedRope -> HighlightedRope
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: HighlightedRope
mempty = IntervalMap Delta Highlight -> Rope -> HighlightedRope
HighlightedRope IntervalMap Delta Highlight
forall a. Monoid a => a
mempty Rope
forall a. Monoid a => a
mempty

data Located a = a :@ {-# UNPACK #-} !Int64
infix 5 :@
instance Eq (Located a) where
  _ :@ m :: Int64
m == :: Located a -> Located a -> Bool
== _ :@ n :: Int64
n = Int64
m Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
n
instance Ord (Located a) where
  compare :: Located a -> Located a -> Ordering
compare (_ :@ m :: Int64
m) (_ :@ n :: Int64
n) = Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int64
m Int64
n

instance ToMarkup HighlightedRope where
  toMarkup :: HighlightedRope -> Markup
toMarkup (HighlightedRope intervals :: IntervalMap Delta Highlight
intervals r :: Rope
r) = Markup -> Markup
Html5.pre (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> [Located Markup] -> Markup
forall a. Int64 -> ByteString -> [Located (MarkupM a)] -> Markup
go 0 ByteString
lbs [Located Markup]
effects where
    lbs :: ByteString
lbs = [ByteString] -> ByteString
L.fromChunks [ByteString
bs | Strand bs :: ByteString
bs _ <- FingerTree Delta Strand -> [Strand]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Rope -> FingerTree Delta Strand
strands Rope
r)]
    ln :: a -> Markup
ln no :: a
no = Markup -> Markup
Html5.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
name ([Char] -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ "line-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
no) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
emptyMarkup
    effects :: [Located Markup]
effects = [Located Markup] -> [Located Markup]
forall a. Ord a => [a] -> [a]
sort ([Located Markup] -> [Located Markup])
-> [Located Markup] -> [Located Markup]
forall a b. (a -> b) -> a -> b
$ [ Located Markup
i | (Interval lo :: Delta
lo hi :: Delta
hi, tok :: Highlight
tok) <- Delta
-> Delta
-> IntervalMap Delta Highlight
-> [(Interval Delta, Highlight)]
forall v a. Ord v => v -> v -> IntervalMap v a -> [(Interval v, a)]
intersections Delta
forall a. Monoid a => a
mempty (Rope -> Delta
forall t. HasDelta t => t -> Delta
delta Rope
r) IntervalMap Delta Highlight
intervals
                     , Located Markup
i <- [ (StaticString -> StaticString -> StaticString -> Markup
leafMarkup "span" "<span" ">" Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ ([Char] -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Highlight -> [Char]
forall a. Show a => a -> [Char]
show Highlight
tok)) Markup -> Int64 -> Located Markup
forall a. a -> Int64 -> Located a
:@ Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes Delta
lo
                            , [Char] -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToHtml ("</span>" :: String) Markup -> Int64 -> Located Markup
forall a. a -> Int64 -> Located a
:@ Delta -> Int64
forall t. HasBytes t => t -> Int64
bytes Delta
hi
                            ]
                     ] [Located Markup] -> [Located Markup] -> [Located Markup]
forall a. [a] -> [a] -> [a]
++ (Int -> Int64 -> Located Markup) -> [Int64] -> [Located Markup]
forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap (\k :: Int
k i :: Int64
i -> Int -> Markup
forall a. Show a => a -> Markup
ln Int
k Markup -> Int64 -> Located Markup
forall a. a -> Int64 -> Located a
:@ Int64
i) (Char -> ByteString -> [Int64]
L.elemIndices '\n' ByteString
lbs)
    go :: Int64 -> ByteString -> [Located (MarkupM a)] -> Markup
go _ cs :: ByteString
cs [] = ByteString -> Markup
unsafeLazyByteString ByteString
cs
    go b :: Int64
b cs :: ByteString
cs ((eff :: MarkupM a
eff :@ eb :: Int64
eb) : es :: [Located (MarkupM a)]
es)
      | Int64
eb Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
b = MarkupM a
eff MarkupM a -> Markup -> Markup
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int64 -> ByteString -> [Located (MarkupM a)] -> Markup
go Int64
b ByteString
cs [Located (MarkupM a)]
es
      | Bool
otherwise = ByteString -> Markup
unsafeLazyByteString ByteString
om Markup -> Markup -> Markup
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int64 -> ByteString -> [Located (MarkupM a)] -> Markup
go Int64
eb ByteString
nom [Located (MarkupM a)]
es
         where (om :: ByteString
om,nom :: ByteString
nom) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
eb Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
b)) ByteString
cs

#if MIN_VERSION_blaze_markup(0,8,0)
    emptyMarkup :: Markup
emptyMarkup = () -> Markup
forall a. a -> MarkupM a
Empty ()
    leafMarkup :: StaticString -> StaticString -> StaticString -> Markup
leafMarkup a :: StaticString
a b :: StaticString
b c :: StaticString
c = StaticString -> StaticString -> StaticString -> () -> Markup
forall a.
StaticString -> StaticString -> StaticString -> a -> MarkupM a
Leaf StaticString
a StaticString
b StaticString
c ()
#else
    emptyMarkup = Empty
    leafMarkup a b c = Leaf a b c
#endif

-- | Represents a source file like an HsColour rendered document
data HighlightDoc = HighlightDoc
  { HighlightDoc -> [Char]
_docTitle   :: String
  , HighlightDoc -> [Char]
_docCss     :: String -- href for the css file
  , HighlightDoc -> HighlightedRope
_docContent :: HighlightedRope
  }

makeClassy ''HighlightDoc

-- | Generate an HTML document from a title and a 'HighlightedRope'.
doc :: String -> HighlightedRope -> HighlightDoc
doc :: [Char] -> HighlightedRope -> HighlightDoc
doc t :: [Char]
t r :: HighlightedRope
r = [Char] -> [Char] -> HighlightedRope -> HighlightDoc
HighlightDoc [Char]
t "trifecta.css" HighlightedRope
r

instance ToMarkup HighlightDoc where
  toMarkup :: HighlightDoc -> Markup
toMarkup (HighlightDoc t :: [Char]
t css :: [Char]
css cs :: HighlightedRope
cs) = Markup -> Markup
docTypeHtml (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
    Markup -> Markup
head (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToHtml ("<!-- Generated by trifecta, http://github.com/ekmett/trifecta/ -->\n" :: String)
      Markup -> Markup
title (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Char] -> Markup
forall a. ToMarkup a => a -> Markup
toHtml [Char]
t
      Markup
link Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel "stylesheet" Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ "text/css" Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href ([Char] -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue [Char]
css)
    Markup -> Markup
body (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ HighlightedRope -> Markup
forall a. ToMarkup a => a -> Markup
toHtml HighlightedRope
cs