{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
module Skylighting.Format.ANSI (
         formatANSI
       ) where
import Control.Monad (mplus)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing, maybeToList)
import Data.Text (Text)
import qualified Data.Text as Text
import Skylighting.Types
import qualified System.Console.ANSI.Codes as ANSI
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif

formatANSI :: FormatOptions -> Style -> [SourceLine] -> Text
formatANSI :: FormatOptions -> Style -> [SourceLine] -> Text
formatANSI FormatOptions
opts Style
sty = (Text
beforeText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
                        (Text -> Text) -> ([SourceLine] -> Text) -> [SourceLine] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
afterText)
                        (Text -> Text) -> ([SourceLine] -> Text) -> [SourceLine] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate (Char -> Text
Text.singleton Char
'\n')
                        ([Text] -> Text)
-> ([SourceLine] -> [Text]) -> [SourceLine] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineNo -> SourceLine -> Text)
-> [LineNo] -> [SourceLine] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (FormatOptions -> Style -> LineNo -> SourceLine -> Text
sourceLineToANSI FormatOptions
opts Style
sty) [LineNo
startNum..]
    where beforeText :: Text
beforeText = Text
ansiResetText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ANSIColorLevel
-> Maybe Color -> Maybe Color -> Bool -> Bool -> Bool -> Text
ansiStyleText ANSIColorLevel
clv (Style -> Maybe Color
defaultColor Style
sty) (Style -> Maybe Color
backgroundColor Style
sty) Bool
False Bool
False Bool
False
          afterText :: Text
afterText = Text
ansiResetText
          startNum :: LineNo
startNum = Int -> LineNo
LineNo (Int -> LineNo) -> Int -> LineNo
forall a b. (a -> b) -> a -> b
$ FormatOptions -> Int
startNumber FormatOptions
opts
          clv :: ANSIColorLevel
clv = FormatOptions -> ANSIColorLevel
ansiColorLevel FormatOptions
opts

sourceLineToANSI :: FormatOptions -> Style -> LineNo -> SourceLine -> Text
sourceLineToANSI :: FormatOptions -> Style -> LineNo -> SourceLine -> Text
sourceLineToANSI FormatOptions
opts Style
sty LineNo
lno = Text -> Text
prependLineNoText
                                 (Text -> Text) -> (SourceLine -> Text) -> SourceLine -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                                 ([Text] -> Text) -> (SourceLine -> [Text]) -> SourceLine -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Text) -> SourceLine -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (ANSIColorLevel -> Style -> Token -> Text
tokenToANSI ANSIColorLevel
clv Style
sty)
    where prependLineNoText :: Text -> Text
prependLineNoText = if FormatOptions -> Bool
numberLines FormatOptions
opts
                                 then (Text
lineNoText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
                                 else Text -> Text
forall a. a -> a
id
          lineNoText :: Text
lineNoText = ANSIColorLevel
-> Maybe Color -> Maybe Color -> Bool -> Bool -> Bool -> Text
ansiStyleText ANSIColorLevel
clv Maybe Color
lineNoFgc Maybe Color
lineNoBgc Bool
False Bool
False Bool
False
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ LineNo -> Int
lineNo LineNo
lno)
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ANSIColorLevel
-> Maybe Color -> Maybe Color -> Bool -> Bool -> Bool -> Text
ansiStyleText ANSIColorLevel
clv (Style -> Maybe Color
defaultColor Style
sty) (Style -> Maybe Color
backgroundColor Style
sty) Bool
False Bool
False Bool
False
                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\t"
          lineNoFgc :: Maybe Color
lineNoFgc = Style -> Maybe Color
lineNumberColor Style
sty Maybe Color -> Maybe Color -> Maybe Color
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
defaultColor Style
sty
          lineNoBgc :: Maybe Color
lineNoBgc = Style -> Maybe Color
lineNumberBackgroundColor Style
sty Maybe Color -> Maybe Color -> Maybe Color
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
backgroundColor Style
sty
          clv :: ANSIColorLevel
clv = FormatOptions -> ANSIColorLevel
ansiColorLevel FormatOptions
opts

tokenToANSI :: ANSIColorLevel -> Style -> Token -> Text
tokenToANSI :: ANSIColorLevel -> Style -> Token -> Text
tokenToANSI ANSIColorLevel
clv Style
sty (TokenType
tokTy, Text
tokText) = ANSIColorLevel
-> Maybe Color -> Maybe Color -> Bool -> Bool -> Bool -> Text
ansiStyleText ANSIColorLevel
clv Maybe Color
tokFgc Maybe Color
tokBgc Bool
tokB Bool
tokI Bool
tokU
                                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tokText
                                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ANSIColorLevel
-> Maybe Color -> Maybe Color -> Bool -> Bool -> Bool -> Text
ansiStyleText ANSIColorLevel
clv (Style -> Maybe Color
defaultColor Style
sty) (Style -> Maybe Color
backgroundColor Style
sty) Bool
False Bool
False Bool
False
    where TokenStyle Maybe Color
tokFgcRaw Maybe Color
tokBgcRaw Bool
tokB Bool
tokI Bool
tokU = TokenStyle -> Maybe TokenStyle -> TokenStyle
forall a. a -> Maybe a -> a
fromMaybe TokenStyle
defStyle (Maybe TokenStyle -> TokenStyle)
-> (Map TokenType TokenStyle -> Maybe TokenStyle)
-> Map TokenType TokenStyle
-> TokenStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TokenType
tokTy (Map TokenType TokenStyle -> TokenStyle)
-> Map TokenType TokenStyle -> TokenStyle
forall a b. (a -> b) -> a -> b
$ Style -> Map TokenType TokenStyle
tokenStyles Style
sty
          tokFgc :: Maybe Color
tokFgc = Maybe Color
tokFgcRaw Maybe Color -> Maybe Color -> Maybe Color
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
defaultColor Style
sty
          tokBgc :: Maybe Color
tokBgc = Maybe Color
tokBgcRaw Maybe Color -> Maybe Color -> Maybe Color
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
backgroundColor Style
sty

ansiStyleText :: ANSIColorLevel -- ^ color support level
            -> Maybe Color -- ^ foreground
            -> Maybe Color -- ^ background
            -> Bool -- ^ bold
            -> Bool -- ^ italic
            -> Bool -- ^ underlined
            -> Text
ansiStyleText :: ANSIColorLevel
-> Maybe Color -> Maybe Color -> Bool -> Bool -> Bool -> Text
ansiStyleText ANSIColorLevel
clv Maybe Color
fgc Maybe Color
bgc Bool
b Bool
i Bool
u = Text
optReset Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sgrTextFg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sgrTextBg
                                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> ([SGR] -> String) -> [SGR] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SGR] -> String
ANSI.setSGRCode ([SGR] -> Text) -> [SGR] -> Text
forall a b. (a -> b) -> a -> b
$ [[SGR]] -> [SGR]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SGR]
sgrCodeFg,
                                                                              [SGR]
sgrCodeBg,
                                                                              [SGR]
sgrCodeBold,
                                                                              [SGR]
sgrCodeItal,
                                                                              [SGR]
sgrCodeUndl])
    -- FIXME: the @ansi-terminal@ library should do the 256-color parts more cleanly someday
    where ([SGR]
sgrCodeFg, Text
sgrTextFg) = case ANSIColorLevel
clv of
            ANSIColorLevel
ANSITrueColor -> (Maybe SGR -> [SGR]
forall a. Maybe a -> [a]
maybeToList (Maybe SGR -> [SGR]) -> Maybe SGR -> [SGR]
forall a b. (a -> b) -> a -> b
$ (Color -> SGR) -> Maybe Color -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConsoleLayer -> Colour Float -> SGR
ANSI.SetRGBColor ConsoleLayer
ANSI.Foreground (Colour Float -> SGR) -> (Color -> Colour Float) -> Color -> SGR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Colour Float
forall a. FromColor a => Color -> a
fromColor) Maybe Color
fgc, Text
"")
            ANSIColorLevel
ANSI256Color -> ([], Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Color -> Text) -> Maybe Color -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Color
c -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [Int] -> String -> String
ANSI.csi [Int
38, Int
5,
              Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int)
-> (Xterm256ColorCode -> Word8) -> Xterm256ColorCode -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Xterm256ColorCode -> Word8
getXterm256ColorCode (Xterm256ColorCode -> Int) -> Xterm256ColorCode -> Int
forall a b. (a -> b) -> a -> b
$ Color -> Xterm256ColorCode
forall a. FromColor a => Color -> a
fromColor Color
c] String
"m") Maybe Color
fgc)
            ANSIColorLevel
ANSI16Color -> (Maybe SGR -> [SGR]
forall a. Maybe a -> [a]
maybeToList (Maybe SGR -> [SGR]) -> Maybe SGR -> [SGR]
forall a b. (a -> b) -> a -> b
$ (Color -> SGR) -> Maybe Color -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground) ((ColorIntensity, Color) -> SGR)
-> (Color -> (ColorIntensity, Color)) -> Color -> SGR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> (ColorIntensity, Color)
forall a. FromColor a => Color -> a
fromColor) Maybe Color
fgc, Text
"")
          ([SGR]
sgrCodeBg, Text
sgrTextBg) = case ANSIColorLevel
clv of
            ANSIColorLevel
ANSITrueColor -> (Maybe SGR -> [SGR]
forall a. Maybe a -> [a]
maybeToList (Maybe SGR -> [SGR]) -> Maybe SGR -> [SGR]
forall a b. (a -> b) -> a -> b
$ (Color -> SGR) -> Maybe Color -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConsoleLayer -> Colour Float -> SGR
ANSI.SetRGBColor ConsoleLayer
ANSI.Background (Colour Float -> SGR) -> (Color -> Colour Float) -> Color -> SGR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Colour Float
forall a. FromColor a => Color -> a
fromColor) Maybe Color
bgc, Text
"")
            ANSIColorLevel
ANSI256Color -> ([], Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Color -> Text) -> Maybe Color -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Color
c -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [Int] -> String -> String
ANSI.csi [Int
48, Int
5,
              Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int)
-> (Xterm256ColorCode -> Word8) -> Xterm256ColorCode -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Xterm256ColorCode -> Word8
getXterm256ColorCode (Xterm256ColorCode -> Int) -> Xterm256ColorCode -> Int
forall a b. (a -> b) -> a -> b
$ Color -> Xterm256ColorCode
forall a. FromColor a => Color -> a
fromColor Color
c] String
"m") Maybe Color
bgc)
            ANSIColorLevel
ANSI16Color -> (Maybe SGR -> [SGR]
forall a. Maybe a -> [a]
maybeToList (Maybe SGR -> [SGR]) -> Maybe SGR -> [SGR]
forall a b. (a -> b) -> a -> b
$ (Color -> SGR) -> Maybe Color -> Maybe SGR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Background) ((ColorIntensity, Color) -> SGR)
-> (Color -> (ColorIntensity, Color)) -> Color -> SGR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> (ColorIntensity, Color)
forall a. FromColor a => Color -> a
fromColor) Maybe Color
bgc, Text
"")
          optReset :: Text
optReset = if Maybe Color -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Color
fgc Bool -> Bool -> Bool
&& Maybe Color -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Color
bgc then Text
ansiResetText else Text
""
          sgrCodeBold :: [SGR]
sgrCodeBold = [ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity (ConsoleIntensity -> SGR) -> ConsoleIntensity -> SGR
forall a b. (a -> b) -> a -> b
$ if Bool
b then ConsoleIntensity
ANSI.BoldIntensity else ConsoleIntensity
ANSI.NormalIntensity]
          sgrCodeItal :: [SGR]
sgrCodeItal = [Bool -> SGR
ANSI.SetItalicized Bool
i] -- FIXME: Not very widely supported in terminals
          sgrCodeUndl :: [SGR]
sgrCodeUndl = [Underlining -> SGR
ANSI.SetUnderlining (Underlining -> SGR) -> Underlining -> SGR
forall a b. (a -> b) -> a -> b
$ if Bool
u then Underlining
ANSI.SingleUnderline else Underlining
ANSI.NoUnderline]

ansiResetText :: Text
ansiResetText :: Text
ansiResetText = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
ANSI.setSGRCode [SGR
ANSI.Reset]