{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Simplex.Chat.Styled
  ( StyledString (..),
    StyledFormat (..),
    styleMarkdown,
    styleMarkdownList,
    unStyle,
    sLength,
    sShow,
    sTake,
  )
where

import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.Markdown
import System.Console.ANSI.Types

data StyledString = Styled [SGR] String | StyledString :<>: StyledString
  deriving (Int -> StyledString -> ShowS
[StyledString] -> ShowS
StyledString -> String
(Int -> StyledString -> ShowS)
-> (StyledString -> String)
-> ([StyledString] -> ShowS)
-> Show StyledString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StyledString -> ShowS
showsPrec :: Int -> StyledString -> ShowS
$cshow :: StyledString -> String
show :: StyledString -> String
$cshowList :: [StyledString] -> ShowS
showList :: [StyledString] -> ShowS
Show)

instance Semigroup StyledString where <> :: StyledString -> StyledString -> StyledString
(<>) = StyledString -> StyledString -> StyledString
(:<>:)

instance Monoid StyledString where mempty :: StyledString
mempty = StyledString
""

instance IsString StyledString where fromString :: String -> StyledString
fromString = String -> StyledString
forall a. StyledFormat a => a -> StyledString
plain

styleMarkdown :: Markdown -> StyledString
styleMarkdown :: Markdown -> StyledString
styleMarkdown (Markdown
s1 :|: Markdown
s2) = Markdown -> StyledString
styleMarkdown Markdown
s1 StyledString -> StyledString -> StyledString
forall a. Semigroup a => a -> a -> a
<> Markdown -> StyledString
styleMarkdown Markdown
s2
styleMarkdown (Markdown Maybe Format
f Text
s) = Maybe Format -> Text -> StyledString
styleFormat Maybe Format
f Text
s

styleMarkdownList :: MarkdownList -> StyledString
styleMarkdownList :: MarkdownList -> StyledString
styleMarkdownList [] = StyledString
""
styleMarkdownList [FormattedText Maybe Format
f Text
s] = Maybe Format -> Text -> StyledString
styleFormat Maybe Format
f Text
s
styleMarkdownList (FormattedText Maybe Format
f Text
s : MarkdownList
ts) = Maybe Format -> Text -> StyledString
styleFormat Maybe Format
f Text
s StyledString -> StyledString -> StyledString
forall a. Semigroup a => a -> a -> a
<> MarkdownList -> StyledString
styleMarkdownList MarkdownList
ts

styleFormat :: Maybe Format -> Text -> StyledString
styleFormat :: Maybe Format -> Text -> StyledString
styleFormat (Just Format
Snippet) Text
s = Char
'`' Char -> StyledString -> StyledString
`wrap` Format -> Text -> StyledString
forall a. StyledFormat a => Format -> a -> StyledString
styled Format
Snippet Text
s
styleFormat (Just Format
Secret) Text
s = Char
'#' Char -> StyledString -> StyledString
`wrap` Format -> Text -> StyledString
forall a. StyledFormat a => Format -> a -> StyledString
styled Format
Secret Text
s
styleFormat (Just Format
f) Text
s = Format -> Text -> StyledString
forall a. StyledFormat a => Format -> a -> StyledString
styled Format
f Text
s
styleFormat Maybe Format
Nothing Text
s = Text -> StyledString
forall a. StyledFormat a => a -> StyledString
plain Text
s

wrap :: Char -> StyledString -> StyledString
wrap :: Char -> StyledString -> StyledString
wrap Char
c StyledString
s = String -> StyledString
forall a. StyledFormat a => a -> StyledString
plain [Char
c] StyledString -> StyledString -> StyledString
forall a. Semigroup a => a -> a -> a
<> StyledString
s StyledString -> StyledString -> StyledString
forall a. Semigroup a => a -> a -> a
<> String -> StyledString
forall a. StyledFormat a => a -> StyledString
plain [Char
c]

class StyledFormat a where
  styled :: Format -> a -> StyledString
  plain :: a -> StyledString

instance StyledFormat String where
  styled :: Format -> String -> StyledString
styled = [SGR] -> String -> StyledString
Styled ([SGR] -> String -> StyledString)
-> (Format -> [SGR]) -> Format -> String -> StyledString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> [SGR]
sgr
  plain :: String -> StyledString
plain = [SGR] -> String -> StyledString
Styled []

instance StyledFormat ByteString where
  styled :: Format -> ByteString -> StyledString
styled Format
f = Format -> String -> StyledString
forall a. StyledFormat a => Format -> a -> StyledString
styled Format
f (String -> StyledString)
-> (ByteString -> String) -> ByteString -> StyledString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack
  plain :: ByteString -> StyledString
plain = [SGR] -> String -> StyledString
Styled [] (String -> StyledString)
-> (ByteString -> String) -> ByteString -> StyledString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack

instance StyledFormat Text where
  styled :: Format -> Text -> StyledString
styled Format
f = Format -> String -> StyledString
forall a. StyledFormat a => Format -> a -> StyledString
styled Format
f (String -> StyledString)
-> (Text -> String) -> Text -> StyledString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
  plain :: Text -> StyledString
plain = [SGR] -> String -> StyledString
Styled [] (String -> StyledString)
-> (Text -> String) -> Text -> StyledString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

sShow :: Show a => a -> StyledString
sShow :: forall a. Show a => a -> StyledString
sShow = String -> StyledString
forall a. StyledFormat a => a -> StyledString
plain (String -> StyledString) -> (a -> String) -> a -> StyledString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

sgr :: Format -> [SGR]
sgr :: Format -> [SGR]
sgr = \case
  Format
Bold -> [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity]
  Format
Italic -> [Underlining -> SGR
SetUnderlining Underlining
SingleUnderline, Bool -> SGR
SetItalicized Bool
True]
  Format
StrikeThrough -> [Bool -> SGR
SetSwapForegroundBackground Bool
True]
  Colored (FormatColor Color
c) -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
c]
  Format
Secret -> [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Black, ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
Dull Color
Black]
  Format
_ -> []

unStyle :: StyledString -> String
unStyle :: StyledString -> String
unStyle (Styled [SGR]
_ String
s) = String
s
unStyle (StyledString
s1 :<>: StyledString
s2) = StyledString -> String
unStyle StyledString
s1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StyledString -> String
unStyle StyledString
s2

sLength :: StyledString -> Int
sLength :: StyledString -> Int
sLength (Styled [SGR]
_ String
s) = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
sLength (StyledString
s1 :<>: StyledString
s2) = StyledString -> Int
sLength StyledString
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ StyledString -> Int
sLength StyledString
s2

sTake :: Int -> StyledString -> StyledString
sTake :: Int -> StyledString -> StyledString
sTake Int
n = Maybe StyledString -> Int -> StyledString -> StyledString
go Maybe StyledString
forall a. Maybe a
Nothing Int
0
  where
    go :: Maybe StyledString -> Int -> StyledString -> StyledString
go Maybe StyledString
res Int
len = \case
      Styled [SGR]
f String
s ->
        let s' :: StyledString
s' = [SGR] -> String -> StyledString
Styled [SGR]
f (String -> StyledString) -> String -> StyledString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) String
s
         in (StyledString -> StyledString)
-> (StyledString -> StyledString -> StyledString)
-> Maybe StyledString
-> StyledString
-> StyledString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StyledString -> StyledString
forall a. a -> a
id StyledString -> StyledString -> StyledString
forall a. Semigroup a => a -> a -> a
(<>) Maybe StyledString
res StyledString
s'
      StyledString
s1 :<>: StyledString
s2 ->
        let s1' :: StyledString
s1' = Maybe StyledString -> Int -> StyledString -> StyledString
go Maybe StyledString
res Int
len StyledString
s1
            len' :: Int
len' = StyledString -> Int
sLength StyledString
s1'
         in if Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n then StyledString
s1' else Maybe StyledString -> Int -> StyledString -> StyledString
go (StyledString -> Maybe StyledString
forall a. a -> Maybe a
Just StyledString
s1') Int
len' StyledString
s2