    {-# 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                     = 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 = [StrictByteString] -> ByteString
    L.fromChunks [StrictByteString
    bs | Strand StrictByteString
    bs Delta
    _ <- FingerTree Delta Strand -> [Strand]
    forall a. FingerTree Delta a -> [a]
    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 a b. (Int -> a -> b) -> [a] -> [b]
    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 a b. MarkupM a -> MarkupM b -> MarkupM b
    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 a b. MarkupM a -> MarkupM b -> MarkupM b
    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

        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 ()

    -- | 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