{-# language DeriveDataTypeable    #-}
{-# language DeriveGeneric         #-}
{-# language FlexibleInstances     #-}
{-# language MultiParamTypeClasses #-}
{-# language TemplateHaskell       #-}
{-# language TypeSynonymInstances  #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2019 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- The type for Lines will very likely change over time, to enable drawing
-- lit up multi-character versions of control characters for @^Z@, @^[@,
-- @<0xff>@, etc. This will make for much nicer diagnostics when
-- working with protocols.
--
----------------------------------------------------------------------------
module Text.Trifecta.Rendering
  ( Rendering(Rendering)
  , HasRendering(..)
  , nullRendering
  , emptyRendering
  , prettyRendering
  , Source(..)
  , rendered
  , Renderable(..)
  , Rendered(..)
  , gutterEffects
  -- * Carets
  , Caret(..)
  , HasCaret(..)
  , Careted(..)
  , drawCaret
  , addCaret
  , caretEffects
  , renderingCaret
  -- * Spans
  , Span(..)
  , HasSpan(..)
  , Spanned(..)
  , spanEffects
  , drawSpan
  , addSpan
  -- * Fixits
  , Fixit(..)
  , HasFixit(..)
  , drawFixit
  , addFixit
  -- * Drawing primitives
  , Lines
  , draw
  , ifNear
  , (.#)
  ) where

import           Control.Applicative
import           Control.Comonad
import           Control.Lens
import           Data.Array
import           Data.ByteString                              as B hiding (any, empty, groupBy)
import qualified Data.ByteString.UTF8                         as UTF8
import           Data.Data
import           Data.Foldable
import           Data.Function                                (on)
import           Data.Hashable
import           Data.Int                                     (Int64)
import           Data.List                                    (groupBy)
import           Data.Maybe
import           Data.Text.Prettyprint.Doc                    hiding (column, line')
import           Data.Text.Prettyprint.Doc.Render.Terminal    (color, bgColor, colorDull, bgColorDull)
import qualified Data.Text.Prettyprint.Doc.Render.Terminal    as Pretty
import           Data.Semigroup
import           Data.Semigroup.Reducer
import           GHC.Generics
import           Prelude                                      as P hiding (span)
import           System.Console.ANSI

import Text.Trifecta.Delta
import Text.Trifecta.Util.Combinators
import Text.Trifecta.Util.Pretty

-- $setup
--
-- >>> :set -XOverloadedStrings
-- >>> import Data.Text.Prettyprint.Doc (unAnnotate)
-- >>> import Data.ByteString (ByteString)
-- >>> import Data.Monoid (mempty)
-- >>> import Text.Trifecta.Delta
-- >>> let exampleRendering = rendered mempty ("int main(int argc, char ** argv) { int; }" :: ByteString)

outOfRangeEffects :: [SGR] -> [SGR]
outOfRangeEffects xs = SetConsoleIntensity BoldIntensity : xs

sgr :: [SGR] -> Doc AnsiStyle -> Doc AnsiStyle
sgr xs0 = go (P.reverse xs0) where
  go []                                         = id
  go (SetConsoleIntensity NormalIntensity : xs) = annotate debold . go xs
  go (SetConsoleIntensity BoldIntensity   : xs) = annotate bold . go xs
  go (SetUnderlining NoUnderline          : xs) = annotate deunderline . go xs
  go (SetUnderlining SingleUnderline      : xs) = annotate underlined . go xs
  go (SetColor f i c                      : xs) = case f of
    Foreground -> case i of
      Dull -> case c of
        Black   -> annotate (color Pretty.Black) . go xs
        Red     -> annotate (color Pretty.Red) . go xs
        Green   -> annotate (color Pretty.Green) . go xs
        Yellow  -> annotate (color Pretty.Yellow) . go xs
        Blue    -> annotate (color Pretty.Blue) . go xs
        Magenta -> annotate (color Pretty.Magenta) . go xs
        Cyan    -> annotate (color Pretty.Cyan) . go xs
        White   -> annotate (color Pretty.White) . go xs
      Vivid -> case c of
        Black   -> annotate (colorDull Pretty.Black) . go xs
        Red     -> annotate (colorDull Pretty.Red) . go xs
        Green   -> annotate (colorDull Pretty.Green) . go xs
        Yellow  -> annotate (colorDull Pretty.Yellow) . go xs
        Blue    -> annotate (colorDull Pretty.Blue) . go xs
        Magenta -> annotate (colorDull Pretty.Magenta) . go xs
        Cyan    -> annotate (colorDull Pretty.Cyan) . go xs
        White   -> annotate (colorDull Pretty.White) . go xs
    Background -> case i of
      Dull -> case c of
        Black   -> annotate (bgColorDull Pretty.Black) . go xs
        Red     -> annotate (bgColorDull Pretty.Red) . go xs
        Green   -> annotate (bgColorDull Pretty.Green) . go xs
        Yellow  -> annotate (bgColorDull Pretty.Yellow) . go xs
        Blue    -> annotate (bgColorDull Pretty.Blue) . go xs
        Magenta -> annotate (bgColorDull Pretty.Magenta) . go xs
        Cyan    -> annotate (bgColorDull Pretty.Cyan) . go xs
        White   -> annotate (bgColorDull Pretty.White) . go xs
      Vivid -> case c of
        Black   -> annotate (bgColor Pretty.Black) . go xs
        Red     -> annotate (bgColor Pretty.Red) . go xs
        Green   -> annotate (bgColor Pretty.Green) . go xs
        Yellow  -> annotate (bgColor Pretty.Yellow) . go xs
        Blue    -> annotate (bgColor Pretty.Blue) . go xs
        Magenta -> annotate (bgColor Pretty.Magenta) . go xs
        Cyan    -> annotate (bgColor Pretty.Cyan) . go xs
        White   -> annotate (bgColor Pretty.White) . go xs
  go (_                                   : xs) = go xs

-- | A raw canvas to paint ANSI-styled characters on.
type Lines = Array (Int,Int64) ([SGR], Char)

-- | Remove a number of @(index, element)@ values from an @'Array'@.
(///) :: Ix i => Array i e -> [(i, e)] -> Array i e
a /// xs = a // P.filter (inRange (bounds a) . fst) xs

grow :: Int -> Lines -> Lines
grow y a
  | inRange (t,b) y = a
  | otherwise = array new [ (i, if inRange old i then a ! i else ([],' ')) | i <- range new ]
  where old@((t,lo),(b,hi)) = bounds a
        new = ((min t y,lo),(max b y,hi))

draw
    :: [SGR]  -- ^ ANSI style to use
    -> Int    -- ^ Line; 0 is at the top
    -> Int64  -- ^ Column; 0 is on the left
    -> String -- ^ Data to be written
    -> Lines  -- ^ Canvas to draw on
    -> Lines
draw _ _ _ "" a0 = a0
draw e y n xs a0 = gt $ lt (a /// out)
  where
    a = grow y a0
    ((_,lo),(_,hi)) = bounds a
    out = P.zipWith (\i c -> ((y,i),(e,c))) [n..] xs
    lt | P.any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))])
       | otherwise = id
    gt | P.any (\el -> snd (fst el) > hi) out = (// [((y,hi),(outOfRangeEffects e,'>'))])
       | otherwise = id

-- | A 'Rendering' is a canvas of text that output can be written to.
data Rendering = Rendering
  { _renderingDelta :: !Delta
    -- ^ focus, the render will keep this visible

  , _renderingLineLen :: {-# UNPACK #-} !Int64
    -- ^ actual line length

  , _renderingLineBytes :: {-# UNPACK #-} !Int64
    -- ^ line length in bytes

  , _renderingLine :: Lines -> Lines

  , _renderingOverlays :: Delta -> Lines -> Lines
  }

makeClassy ''Rendering

instance Show Rendering where
  showsPrec d (Rendering p ll lb _ _) = showParen (d > 10) $
    showString "Rendering " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showChar ' ' . showsPrec 11 lb . showString " ... ..."

-- | Is the 'Rendering' empty?
--
-- >>> nullRendering emptyRendering
-- True
--
-- >>> nullRendering exampleRendering
-- False
nullRendering :: Rendering -> Bool
nullRendering (Rendering (Columns 0 0) 0 0 _ _) = True
nullRendering _ = False

-- | The empty 'Rendering', which contains nothing at all.
--
-- >>> show (prettyRendering emptyRendering)
-- ""
emptyRendering :: Rendering
emptyRendering = Rendering (Columns 0 0) 0 0 id (const id)

instance Semigroup Rendering where
  -- an unprincipled hack
  Rendering (Columns 0 0) 0 0 _ f <> Rendering del len lb dc g = Rendering del len lb dc $ \d l -> f d (g d l)
  Rendering del len lb dc f <> Rendering _ _ _ _ g = Rendering del len lb dc $ \d l -> f d (g d l)

instance Monoid Rendering where
  mappend = (<>)
  mempty = emptyRendering

ifNear
    :: Delta            -- ^ Position 1
    -> (Lines -> Lines) -- ^ Modify the fallback result if the positions are 'near' each other
    -> Delta            -- ^ Position 2
    -> Lines            -- ^ Fallback result if the positions are not 'near' each other
    -> Lines
ifNear d f d' l | near d d' = f l
                | otherwise = l

instance HasDelta Rendering where
  delta = _renderingDelta

class Renderable t where
  render :: t -> Rendering

instance Renderable Rendering where
  render = id

class Source t where
  source :: t -> (Int64, Int64, Lines -> Lines)
  -- ^ @
  -- ( Number of (padded) columns
  -- , number of bytes
  -- , line )
  -- @

instance Source String where
  source s
    | P.elem '\n' s = (ls, bs, draw [] 0 0 s')
    | otherwise           = ( ls + fromIntegral (P.length end), bs, draw [SetColor Foreground Vivid Blue, SetConsoleIntensity BoldIntensity] 0 ls end . draw [] 0 0 s')
    where
      end = "<EOF>"
      s' = go 0 s
      bs = fromIntegral $ B.length $ UTF8.fromString $ P.takeWhile (/='\n') s
      ls = fromIntegral $ P.length s'
      go n ('\t':xs) = let t = 8 - mod n 8 in P.replicate t ' ' ++ go (n + t) xs
      go _ ('\n':_)  = []
      go n (x:xs)    = x : go (n + 1) xs
      go _ []        = []

instance Source ByteString where
  source = source . UTF8.toString

-- | create a drawing surface
rendered :: Source s => Delta -> s -> Rendering
rendered del s = case source s of
  (len, lb, dc) -> Rendering del len lb dc (\_ l -> l)

(.#) :: (Delta -> Lines -> Lines) -> Rendering -> Rendering
f .# Rendering d ll lb s g = Rendering d ll lb s $ \e l -> f e $ g e l

prettyRendering :: Rendering -> Doc AnsiStyle
prettyRendering (Rendering d ll _ l f) = nesting $ \k -> columns $ \mn -> go (fromIntegral (fromMaybe 80 mn - k)) where
  go cols = align (vsep (P.map ln [t..b])) where
    (lo, hi) = window (column d) ll (min (max (cols - 5 - fromIntegral gutterWidth) 30) 200)
    a = f d $ l $ array ((0,lo),(-1,hi)) []
    ((t,_),(b,_)) = bounds a
    n = show $ case d of
      Lines      n' _ _ _ -> 1 + n'
      Directed _ n' _ _ _ -> 1 + n'
      _                   -> 1
    separator = char '|'
    gutterWidth = P.length n
    gutter = pretty n <+> separator
    margin = fill gutterWidth space <+> separator
    ln y = (sgr gutterEffects (if y == 0 then gutter else margin) <+>)
         $ hcat
         $ P.map (\g -> sgr (fst (P.head g)) (pretty (P.map snd g)))
         $ groupBy ((==) `on` fst)
         [ a ! (y,i) | i <- [lo..hi] ]

window :: Int64 -> Int64 -> Int64 -> (Int64, Int64)
window c l w
  | c <= w2     = (0, min w l)
  | c + w2 >= l = if l > w then (l-w, l)
                           else (0  , w)
  | otherwise   = (c-w2, c+w2)
  where w2 = div w 2

-- | ANSI terminal style for rendering the gutter.
gutterEffects :: [SGR]
gutterEffects = [SetColor Foreground Vivid Blue]

data Rendered a = a :@ Rendering
  deriving Show

instance Functor Rendered where
  fmap f (a :@ s) = f a :@ s

instance HasDelta (Rendered a) where
  delta = delta . render

instance HasBytes (Rendered a) where
  bytes = bytes . delta

instance Comonad Rendered where
  extend f as@(_ :@ s) = f as :@ s
  extract (a :@ _) = a

instance ComonadApply Rendered where
  (f :@ s) <@> (a :@ t) = f a :@ (s <> t)

instance Foldable Rendered where
  foldMap f (a :@ _) = f a

instance Traversable Rendered where
  traverse f (a :@ s) = (:@ s) <$> f a

instance Renderable (Rendered a) where
  render (_ :@ s) = s

-- | A 'Caret' marks a point in the input with a simple @^@ character.
--
-- >>> unAnnotate (prettyRendering (addCaret (Columns 35 35) exampleRendering))
-- 1 | int main(int argc, char ** argv) { int; }<EOF>
--   |                                    ^
data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic)

class HasCaret t where
  caret :: Lens' t Caret

instance HasCaret Caret where
  caret = id

instance Hashable Caret

-- | ANSI terminal style for rendering the caret.
caretEffects :: [SGR]
caretEffects = [SetColor Foreground Vivid Green]

drawCaret :: Delta -> Delta -> Lines -> Lines
drawCaret p = ifNear p $ draw caretEffects 1 (fromIntegral (column p)) "^"

-- | Render a caret at a certain position in a 'Rendering'.
addCaret :: Delta -> Rendering -> Rendering
addCaret p r = drawCaret p .# r

instance HasBytes Caret where
  bytes = bytes . delta

instance HasDelta Caret where
  delta (Caret d _) = d

instance Renderable Caret where
  render (Caret d bs) = addCaret d $ rendered d bs

instance Reducer Caret Rendering where
  unit = render

instance Semigroup Caret where
  a <> _ = a

renderingCaret :: Delta -> ByteString -> Rendering
renderingCaret d bs = addCaret d $ rendered d bs

data Careted a = a :^ Caret deriving (Eq,Ord,Show,Data,Typeable,Generic)

instance HasCaret (Careted a) where
  caret f (a :^ c) = (a :^) <$> f c

instance Functor Careted where
  fmap f (a :^ s) = f a :^ s

instance HasDelta (Careted a) where
  delta (_ :^ c) = delta c

instance HasBytes (Careted a) where
  bytes (_ :^ c) = bytes c

instance Comonad Careted where
  extend f as@(_ :^ s) = f as :^ s
  extract (a :^ _) = a

instance ComonadApply Careted where
  (a :^ c) <@> (b :^ d) = a b :^ (c <> d)

instance Foldable Careted where
  foldMap f (a :^ _) = f a

instance Traversable Careted where
  traverse f (a :^ s) = (:^ s) <$> f a

instance Renderable (Careted a) where
  render (_ :^ a) = render a

instance Reducer (Careted a) Rendering where
  unit = render

instance Hashable a => Hashable (Careted a)

-- | ANSI terminal style to render spans with.
spanEffects :: [SGR]
spanEffects  = [SetColor Foreground Dull Green]

drawSpan
    :: Delta -- ^ Start of the region of interest
    -> Delta -- ^ End of the region of interest
    -> Delta -- ^ Currrent location
    -> Lines -- ^ 'Lines' to add the rendering to
    -> Lines
drawSpan start end d a
  | nearLo && nearHi = go (column lo) (rep (max (column hi - column lo) 0) '~') a
  | nearLo           = go (column lo) (rep (max (snd (snd (bounds a)) - column lo + 1) 0) '~') a
  |           nearHi = go (-1)        (rep (max (column hi + 1) 0) '~') a
  | otherwise        = a
  where
    go = draw spanEffects 1 . fromIntegral
    lo = argmin bytes start end
    hi = argmax bytes start end
    nearLo = near lo d
    nearHi = near hi d
    rep = P.replicate . fromIntegral

addSpan :: Delta -> Delta -> Rendering -> Rendering
addSpan s e r = drawSpan s e .# r

-- | A 'Span' marks a range of input characters. If 'Caret' is a point, then
-- 'Span' is a line.
--
-- >>> unAnnotate (prettyRendering (addSpan (Columns 35 35) (Columns 38 38) exampleRendering))
-- 1 | int main(int argc, char ** argv) { int; }<EOF>
--   |                                    ~~~
data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show,Data,Typeable,Generic)

class HasSpan t where
  span :: Lens' t Span

instance HasSpan Span where
  span = id

instance Renderable Span where
  render (Span s e bs) = addSpan s e $ rendered s bs

instance Semigroup Span where
  Span s _ b <> Span _ e _ = Span s e b

instance Reducer Span Rendering where
  unit = render

instance Hashable Span

-- | Annotate an arbitrary piece of data with a 'Span', typically its
-- corresponding input location.
data Spanned a = a :~ Span deriving (Eq,Ord,Show,Data,Typeable,Generic)

instance HasSpan (Spanned a) where
  span f (a :~ c) = (a :~) <$> f c

instance Functor Spanned where
  fmap f (a :~ s) = f a :~ s

instance Comonad Spanned where
  extend f as@(_ :~ s) = f as :~ s
  extract (a :~ _) = a

instance ComonadApply Spanned where
  (a :~ c) <@> (b :~ d) = a b :~ (c <> d)

instance Foldable Spanned where
  foldMap f (a :~ _) = f a

instance Traversable Spanned where
  traverse f (a :~ s) = (:~ s) <$> f a

instance Reducer (Spanned a) Rendering where
  unit = render

instance Renderable (Spanned a) where
  render (_ :~ s) = render s

instance Hashable a => Hashable (Spanned a)

drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines
drawFixit s e rpl d a = ifNear l (draw [SetColor Foreground Dull Blue] 2 (fromIntegral (column l)) rpl) d
                      $ drawSpan s e d a
  where l = argmin bytes s e

addFixit :: Delta -> Delta -> String -> Rendering -> Rendering
addFixit s e rpl r = drawFixit s e rpl .# r

-- | A 'Fixit' is a 'Span' with a suggestion.
--
-- >>> unAnnotate (prettyRendering (addFixit (Columns 35 35) (Columns 38 38) "Fix this!" exampleRendering))
-- 1 | int main(int argc, char ** argv) { int; }<EOF>
--   |                                    ~~~
--   |                                    Fix this!
data Fixit = Fixit
  { _fixitSpan :: {-# UNPACK #-} !Span
    -- ^ 'Span' where the error occurred
  , _fixitReplacement :: !ByteString
    -- ^ Replacement suggestion
  } deriving (Eq,Ord,Show,Data,Typeable,Generic)

makeClassy ''Fixit

instance HasSpan Fixit where
  span = fixitSpan

instance Hashable Fixit

instance Reducer Fixit Rendering where
  unit = render

instance Renderable Fixit where
  render (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ rendered s bs