{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

module Unison.Util.ColorText
  ( ColorText,
    Color (..),
    style,
    toANSI,
    toPlain,
    toHTML,
    defaultColors,
    black,
    red,
    green,
    yellow,
    blue,
    purple,
    cyan,
    white,
    hiBlack,
    hiRed,
    hiGreen,
    hiYellow,
    hiBlue,
    hiPurple,
    hiCyan,
    hiWhite,
    bold,
    underline,
    invert,
    background,
    unstyled,
    module Unison.Util.AnnotatedText,
  )
where

import System.Console.ANSI qualified as ANSI
import Unison.Prelude
import Unison.Util.AnnotatedText
  ( AnnotatedText (..),
    Segment (..),
    annotate,
    toPair,
  )
import Unison.Util.SyntaxText qualified as ST hiding (toPlain)

type ColorText = AnnotatedText Color

data Color
  = Black
  | Red
  | Green
  | Yellow
  | Blue
  | Purple
  | Cyan
  | White
  | HiBlack
  | HiRed
  | HiGreen
  | HiYellow
  | HiBlue
  | HiPurple
  | HiCyan
  | HiWhite
  | Bold
  | Underline
  | Invert Color
  | Background Color Color
  | Default
  deriving (Color -> Color -> Bool
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
/= :: Color -> Color -> Bool
Eq, Eq Color
Eq Color =>
(Color -> Color -> Ordering)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Color)
-> (Color -> Color -> Color)
-> Ord Color
Color -> Color -> Bool
Color -> Color -> Ordering
Color -> Color -> Color
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Color -> Color -> Ordering
compare :: Color -> Color -> Ordering
$c< :: Color -> Color -> Bool
< :: Color -> Color -> Bool
$c<= :: Color -> Color -> Bool
<= :: Color -> Color -> Bool
$c> :: Color -> Color -> Bool
> :: Color -> Color -> Bool
$c>= :: Color -> Color -> Bool
>= :: Color -> Color -> Bool
$cmax :: Color -> Color -> Color
max :: Color -> Color -> Color
$cmin :: Color -> Color -> Color
min :: Color -> Color -> Color
Ord, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Color -> ShowS
showsPrec :: Int -> Color -> ShowS
$cshow :: Color -> String
show :: Color -> String
$cshowList :: [Color] -> ShowS
showList :: [Color] -> ShowS
Show, ReadPrec [Color]
ReadPrec Color
Int -> ReadS Color
ReadS [Color]
(Int -> ReadS Color)
-> ReadS [Color]
-> ReadPrec Color
-> ReadPrec [Color]
-> Read Color
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Color
readsPrec :: Int -> ReadS Color
$creadList :: ReadS [Color]
readList :: ReadS [Color]
$creadPrec :: ReadPrec Color
readPrec :: ReadPrec Color
$creadListPrec :: ReadPrec [Color]
readListPrec :: ReadPrec [Color]
Read)

black, red, green, yellow, blue, purple, cyan, white, hiBlack, hiRed, hiGreen, hiYellow, hiBlue, hiPurple, hiCyan, hiWhite, bold, underline :: ColorText -> ColorText
black :: ColorText -> ColorText
black = Color -> ColorText -> ColorText
style Color
Black
red :: ColorText -> ColorText
red = Color -> ColorText -> ColorText
style Color
Red
green :: ColorText -> ColorText
green = Color -> ColorText -> ColorText
style Color
Green
yellow :: ColorText -> ColorText
yellow = Color -> ColorText -> ColorText
style Color
Yellow
blue :: ColorText -> ColorText
blue = Color -> ColorText -> ColorText
style Color
Blue
purple :: ColorText -> ColorText
purple = Color -> ColorText -> ColorText
style Color
Purple
cyan :: ColorText -> ColorText
cyan = Color -> ColorText -> ColorText
style Color
Cyan
white :: ColorText -> ColorText
white = Color -> ColorText -> ColorText
style Color
White
hiBlack :: ColorText -> ColorText
hiBlack = Color -> ColorText -> ColorText
style Color
HiBlack
hiRed :: ColorText -> ColorText
hiRed = Color -> ColorText -> ColorText
style Color
HiRed
hiGreen :: ColorText -> ColorText
hiGreen = Color -> ColorText -> ColorText
style Color
HiGreen
hiYellow :: ColorText -> ColorText
hiYellow = Color -> ColorText -> ColorText
style Color
HiYellow
hiBlue :: ColorText -> ColorText
hiBlue = Color -> ColorText -> ColorText
style Color
HiBlue
hiPurple :: ColorText -> ColorText
hiPurple = Color -> ColorText -> ColorText
style Color
HiPurple
hiCyan :: ColorText -> ColorText
hiCyan = Color -> ColorText -> ColorText
style Color
HiCyan
hiWhite :: ColorText -> ColorText
hiWhite = Color -> ColorText -> ColorText
style Color
HiWhite
bold :: ColorText -> ColorText
bold = Color -> ColorText -> ColorText
style Color
Bold
underline :: ColorText -> ColorText
underline = Color -> ColorText -> ColorText
style Color
Underline

unstyled :: ColorText -> ColorText
unstyled :: ColorText -> ColorText
unstyled = Color -> ColorText -> ColorText
style Color
Default

background :: Color -> ColorText -> ColorText
background :: Color -> ColorText -> ColorText
background Color
c ColorText
ct = ColorText
ct ColorText -> (Color -> Color) -> ColorText
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Color -> Color -> Color
Background Color
c

invert :: ColorText -> ColorText
invert :: ColorText -> ColorText
invert ColorText
ct = ColorText
ct ColorText -> (Color -> Color) -> ColorText
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Color -> Color
Invert

style :: Color -> ColorText -> ColorText
style :: Color -> ColorText -> ColorText
style = Color -> ColorText -> ColorText
forall a. a -> AnnotatedText a -> AnnotatedText a
annotate

toHTML :: String -> ColorText -> String
toHTML :: String -> ColorText -> String
toHTML String
cssPrefix (AnnotatedText Seq (Segment Color)
at) =
  Seq (Segment Color) -> [Segment Color]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Segment Color)
at [Segment Color] -> (Segment Color -> String) -> String
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Segment String
s Maybe Color
color -> Maybe Color -> ShowS
forall {a}. Show a => Maybe a -> ShowS
wrap Maybe Color
color (String
s String -> (Char -> String) -> String
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Char -> String
newlineToBreak)
  where
    newlineToBreak :: Char -> String
newlineToBreak Char
'\n' = String
"<br/>\n"
    newlineToBreak Char
ch = [Char
ch]
    wrap :: Maybe a -> ShowS
wrap Maybe a
Nothing String
s = String
"<code>" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"</code>"
    wrap (Just a
c) String
s =
      String
"<code class=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall {a}. Show a => a -> String
colorName a
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"</code>"
    colorName :: a -> String
colorName a
c = String
"\"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cssPrefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall {a}. Show a => a -> String
show a
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""

-- Convert a `ColorText` to a `String`, ignoring colors
toPlain :: ColorText -> String
toPlain :: ColorText -> String
toPlain (AnnotatedText Seq (Segment Color)
at) = [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Seq String -> [String]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq String -> [String]) -> Seq String -> [String]
forall a b. (a -> b) -> a -> b
$ Segment Color -> String
forall a. Segment a -> String
segment (Segment Color -> String) -> Seq (Segment Color) -> Seq String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Segment Color)
at)

-- Convert a `ColorText` to a `String`, using ANSI codes to produce colors
toANSI :: ColorText -> String
toANSI :: ColorText -> String
toANSI (AnnotatedText Seq (Segment Color)
chunks) =
  [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([String] -> String)
-> (Seq String -> [String]) -> Seq String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq String -> [String]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq String -> String) -> Seq String -> String
forall a b. (a -> b) -> a -> b
$ (Maybe Color, Seq String) -> Seq String
forall a b. (a, b) -> b
snd (((Maybe Color, Seq String)
 -> Segment Color -> (Maybe Color, Seq String))
-> (Maybe Color, Seq String)
-> Seq (Segment Color)
-> (Maybe Color, Seq String)
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Maybe Color, Seq String)
-> Segment Color -> (Maybe Color, Seq String)
go (Maybe Color
forall a. Maybe a
Nothing, Seq String
forall a. Monoid a => a
mempty) Seq (Segment Color)
chunks) Seq String -> Seq String -> Seq String
forall a. Semigroup a => a -> a -> a
<> Seq String
resetANSI
  where
    go ::
      (Maybe Color, Seq String) ->
      Segment Color ->
      (Maybe Color, Seq String)
    go :: (Maybe Color, Seq String)
-> Segment Color -> (Maybe Color, Seq String)
go (Maybe Color
prev, Seq String
r) (Segment Color -> (String, Maybe Color)
forall a. Segment a -> (String, Maybe a)
toPair -> (String
text, Maybe Color
new)) =
      if Maybe Color
prev Maybe Color -> Maybe Color -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Color
new
        then (Maybe Color
prev, Seq String
r Seq String -> Seq String -> Seq String
forall a. Semigroup a => a -> a -> a
<> String -> Seq String
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
text)
        else
          ( Maybe Color
new,
            case Maybe Color
new of
              Maybe Color
Nothing -> Seq String
r Seq String -> Seq String -> Seq String
forall a. Semigroup a => a -> a -> a
<> Seq String
resetANSI Seq String -> Seq String -> Seq String
forall a. Semigroup a => a -> a -> a
<> String -> Seq String
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
text
              Just Color
style -> Seq String
r Seq String -> Seq String -> Seq String
forall a. Semigroup a => a -> a -> a
<> Seq String
resetANSI Seq String -> Seq String -> Seq String
forall a. Semigroup a => a -> a -> a
<> Color -> Seq String
toANSI Color
style Seq String -> Seq String -> Seq String
forall a. Semigroup a => a -> a -> a
<> String -> Seq String
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
text
          )
    resetANSI :: Seq String
    resetANSI :: Seq String
resetANSI = String -> Seq String
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Seq String) -> String -> Seq String
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
ANSI.setSGRCode [SGR
ANSI.Reset]
    toANSI :: Color -> Seq String
    toANSI :: Color -> Seq String
toANSI Color
c = String -> Seq String
forall a. a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Seq String) -> String -> Seq String
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
ANSI.setSGRCode (Color -> [SGR]
toANSI' Color
c)

    toANSI' :: Color -> [ANSI.SGR]
    toANSI' :: Color -> [SGR]
toANSI' Color
c = case Color
c of
      Color
Default -> []
      Background Color
c Color
c2 -> (SGR -> SGR
setBg (SGR -> SGR) -> [SGR] -> [SGR]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Color -> [SGR]
toANSI' Color
c) [SGR] -> [SGR] -> [SGR]
forall a. Semigroup a => a -> a -> a
<> Color -> [SGR]
toANSI' Color
c2
        where
          setBg :: SGR -> SGR
setBg (ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
intensity Color
color) =
            ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Background ColorIntensity
intensity Color
color
          setBg SGR
sgr = SGR
sgr
      Invert Color
c -> [Bool -> SGR
ANSI.SetSwapForegroundBackground Bool
True] [SGR] -> [SGR] -> [SGR]
forall a. Semigroup a => a -> a -> a
<> Color -> [SGR]
toANSI' Color
c
      Color
Black -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.Black]
      Color
Red -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.Red]
      Color
Green -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.Green]
      Color
Yellow -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.Yellow]
      Color
Blue -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.Blue]
      Color
Purple -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.Magenta]
      Color
Cyan -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.Cyan]
      Color
White -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Dull Color
ANSI.White]
      Color
HiBlack -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.Black]
      Color
HiRed -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.Red]
      Color
HiGreen -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.Green]
      Color
HiYellow -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.Yellow]
      Color
HiBlue -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.Blue]
      Color
HiPurple -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.Magenta]
      Color
HiCyan -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.Cyan]
      Color
HiWhite -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
ANSI.Vivid Color
ANSI.White]
      Color
Bold -> [ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity ConsoleIntensity
ANSI.BoldIntensity]
      Color
Underline -> [Underlining -> SGR
ANSI.SetUnderlining Underlining
ANSI.SingleUnderline]

defaultColors :: ST.Element r -> Maybe Color
defaultColors :: forall r. Element r -> Maybe Color
defaultColors = \case
  Element r
ST.NumericLiteral -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.TextLiteral -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.BytesLiteral -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  Element r
ST.CharLiteral -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.BooleanLiteral -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.Blank -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.Var -> Maybe Color
forall a. Maybe a
Nothing
  ST.TypeReference r
_ -> Maybe Color
forall a. Maybe a
Nothing
  ST.TermReference Referent' r
_ -> Maybe Color
forall a. Maybe a
Nothing
  ST.Op SeqOp
_ -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.Unit -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.AbilityBraces -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  Element r
ST.ControlKeyword -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiCyan
  Element r
ST.LinkKeyword -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  Element r
ST.TypeOperator -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  Element r
ST.BindingEquals -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.TypeAscriptionColon -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Blue
  Element r
ST.DataTypeKeyword -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.DataTypeParams -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.DataTypeModifier -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.UseKeyword -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  Element r
ST.UsePrefix -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  Element r
ST.UseSuffix -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  ST.HashQualifier HashQualified Name
_ -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiPurple
  Element r
ST.DelayForceChar -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Yellow
  Element r
ST.DelimiterChar -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.Parenthesis -> Maybe Color
forall a. Maybe a
Nothing
  Element r
ST.DocDelimiter -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Green
  Element r
ST.DocKeyword -> Color -> Maybe Color
forall a. a -> Maybe a
Just Color
HiCyan