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

-----------------------------------------------------------------------------
-- |
-- 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 hiding (Empty)
import Data.Foldable as F
import Data.Int (Int64)
import Data.List (sort)
import Data.Semigroup
import Data.Semigroup.Union
import Prelude hiding (head)
import Prettyprinter
import Prettyprinter.Render.Terminal (color)
import qualified Prettyprinter.Render.Terminal as Pretty
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 Highlight
Comment                     = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Blue)
withHighlight Highlight
ReservedIdentifier          = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight Highlight
ReservedConstructor         = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight Highlight
EscapeCode                  = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight Highlight
Operator                    = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
CharLiteral                 = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Cyan)
withHighlight Highlight
StringLiteral               = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Cyan)
withHighlight Highlight
Constructor                 = forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
Pretty.bold
withHighlight Highlight
ReservedOperator            = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
ConstructorOperator         = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
ReservedConstructorOperator = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
_                           = 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 = forall t. HasDelta t => t -> Delta
delta forall b c a. (b -> c) -> (a -> b) -> a -> c
. HighlightedRope -> Rope
_ropeContent

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

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

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

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

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

    emptyMarkup :: Markup
emptyMarkup = forall a. a -> MarkupM a
Empty ()
    leafMarkup :: StaticString -> StaticString -> StaticString -> Markup
leafMarkup StaticString
a StaticString
b StaticString
c = forall a.
StaticString -> StaticString -> StaticString -> a -> MarkupM a
Leaf StaticString
a StaticString
b StaticString
c ()

-- | 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 [Char]
t HighlightedRope
r = [Char] -> [Char] -> HighlightedRope -> HighlightDoc
HighlightDoc [Char]
t [Char]
"trifecta.css" HighlightedRope
r

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