content: {-# 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 Comment                     = annotate (color Pretty.Blue)
  withHighlight ReservedIdentifier          = annotate (color Pretty.Magenta)
  withHighlight ReservedConstructor         = annotate (color Pretty.Magenta)
  withHighlight EscapeCode                  = annotate (color Pretty.Magenta)
  withHighlight Operator                    = annotate (color Pretty.Yellow)
  withHighlight CharLiteral                 = annotate (color Pretty.Cyan)
  withHighlight StringLiteral               = annotate (color Pretty.Cyan)
  withHighlight Constructor                 = annotate Pretty.bold
  withHighlight ReservedOperator            = annotate (color Pretty.Yellow)
  withHighlight ConstructorOperator         = annotate (color Pretty.Yellow)
  withHighlight ReservedConstructorOperator = annotate (color Pretty.Yellow)
  withHighlight _                           = id
  
  -- | A 'HighlightedRope' is a 'Rope' with an associated 'IntervalMap' full of highlighted regions.
  data HighlightedRope = HighlightedRope
    { _ropeHighlights :: !(IM.IntervalMap Delta Highlight)
    , _ropeContent    :: {-# UNPACK #-} !Rope
    }
  
  makeClassy ''HighlightedRope
  
  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
  
  data Located a = a :@ {-# UNPACK #-} !Int64
  infix 5 :@
  instance Eq (Located a) where
    _ :@ m == _ :@ n = m == n
  instance Ord (Located a) where
    compare (_ :@ m) (_ :@ n) = compare m n
  
  instance ToMarkup HighlightedRope where
    toMarkup (HighlightedRope intervals r) = Html5.pre $ go 0 lbs effects where
      lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)]
      ln no = Html5.a ! name (toValue $ "line-" ++ show no) $ emptyMarkup
      effects = sort $ [ i | (Interval lo hi, tok) <- intersections mempty (delta r) intervals
                       , i <- [ (leafMarkup "span" "<span" ">" ! class_ (toValue $ show tok)) :@ bytes lo
                              , preEscapedToHtml ("</span>" :: String) :@ bytes hi
                              ]
                       ] ++ imap (\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
  
      emptyMarkup = Empty ()
      leafMarkup a b c = Leaf a b c ()
  
  -- | Represents a source file like an HsColour rendered document
  data HighlightDoc = HighlightDoc
    { _docTitle   :: String
    , _docCss     :: String -- href for the css file
    , _docContent :: HighlightedRope
    }
  
  makeClassy ''HighlightDoc
  
  -- | Generate an HTML document from a title and a 'HighlightedRope'.
  doc :: String -> HighlightedRope -> HighlightDoc
  doc t r = HighlightDoc t "trifecta.css" r
  
  instance ToMarkup HighlightDoc where
    toMarkup (HighlightDoc t css cs) = docTypeHtml $ do
      head $ do
        preEscapedToHtml ("<!-- Generated by trifecta, http://github.com/ekmett/trifecta/ -->\n" :: String)
        title $ toHtml t
        link ! rel "stylesheet" ! type_ "text/css" ! href (toValue css)
      body $ toHtml cs
  