{-# 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 Highlight
Comment                     = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Blue)
withHighlight Highlight
ReservedIdentifier          = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight Highlight
ReservedConstructor         = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight Highlight
EscapeCode                  = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Magenta)
withHighlight Highlight
Operator                    = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
CharLiteral                 = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Cyan)
withHighlight Highlight
StringLiteral               = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Cyan)
withHighlight Highlight
Constructor                 = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
Pretty.bold
withHighlight Highlight
ReservedOperator            = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
ConstructorOperator         = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
ReservedConstructorOperator = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Pretty.Yellow)
withHighlight Highlight
_                           = 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 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 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
  a
_ :@ Int64
m == :: Located a -> Located a -> Bool
== a
_ :@ 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 (a
_ :@ Int64
m) (a
_ :@ 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 IntervalMap Delta Highlight
intervals 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 Int64
0 ByteString
lbs [Located Markup]
effects where
    lbs :: ByteString
lbs = [ByteString] -> ByteString
L.fromChunks [ByteString
bs | Strand ByteString
bs Delta
_ <- 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 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
$ [Char]
"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 Delta
lo Delta
hi, 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 StaticString
"span" StaticString
"<span" StaticString
">" 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 ([Char]
"</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 (\Int
k 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 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 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 (ByteString
om,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 StaticString
a StaticString
b 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 [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 (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 ([Char]
"<!-- 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 AttributeValue
"stylesheet" Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"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