mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-31 11:56:00 +00:00
774af334fd
* terminal: command to show the list of the last active chats * indent for chats without messages, help * update command in the test
99 lines
2.7 KiB
Haskell
99 lines
2.7 KiB
Haskell
{-# 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 (Show)
|
|
|
|
instance Semigroup StyledString where (<>) = (:<>:)
|
|
|
|
instance Monoid StyledString where mempty = ""
|
|
|
|
instance IsString StyledString where fromString = plain
|
|
|
|
styleMarkdown :: Markdown -> StyledString
|
|
styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
|
|
styleMarkdown (Markdown f s) = styleFormat f s
|
|
|
|
styleMarkdownList :: MarkdownList -> StyledString
|
|
styleMarkdownList [] = ""
|
|
styleMarkdownList [FormattedText f s] = styleFormat f s
|
|
styleMarkdownList (FormattedText f s : ts) = styleFormat f s <> styleMarkdownList ts
|
|
|
|
styleFormat :: Maybe Format -> Text -> StyledString
|
|
styleFormat (Just Snippet) s = '`' `wrap` styled Snippet s
|
|
styleFormat (Just Secret) s = '#' `wrap` styled Secret s
|
|
styleFormat (Just f) s = styled f s
|
|
styleFormat Nothing s = plain s
|
|
|
|
wrap :: Char -> StyledString -> StyledString
|
|
wrap c s = plain [c] <> s <> plain [c]
|
|
|
|
class StyledFormat a where
|
|
styled :: Format -> a -> StyledString
|
|
plain :: a -> StyledString
|
|
|
|
instance StyledFormat String where
|
|
styled = Styled . sgr
|
|
plain = Styled []
|
|
|
|
instance StyledFormat ByteString where
|
|
styled f = styled f . B.unpack
|
|
plain = Styled [] . B.unpack
|
|
|
|
instance StyledFormat Text where
|
|
styled f = styled f . T.unpack
|
|
plain = Styled [] . T.unpack
|
|
|
|
sShow :: Show a => a -> StyledString
|
|
sShow = plain . show
|
|
|
|
sgr :: Format -> [SGR]
|
|
sgr = \case
|
|
Bold -> [SetConsoleIntensity BoldIntensity]
|
|
Italic -> [SetUnderlining SingleUnderline, SetItalicized True]
|
|
StrikeThrough -> [SetSwapForegroundBackground True]
|
|
Colored (FormatColor c) -> [SetColor Foreground Vivid c]
|
|
Secret -> [SetColor Foreground Dull Black, SetColor Background Dull Black]
|
|
_ -> []
|
|
|
|
unStyle :: StyledString -> String
|
|
unStyle (Styled _ s) = s
|
|
unStyle (s1 :<>: s2) = unStyle s1 <> unStyle s2
|
|
|
|
sLength :: StyledString -> Int
|
|
sLength (Styled _ s) = length s
|
|
sLength (s1 :<>: s2) = sLength s1 + sLength s2
|
|
|
|
sTake :: Int -> StyledString -> StyledString
|
|
sTake n = go Nothing 0
|
|
where
|
|
go res len = \case
|
|
Styled f s ->
|
|
let s' = Styled f $ take (n - len) s
|
|
in maybe id (<>) res s'
|
|
s1 :<>: s2 ->
|
|
let s1' = go res len s1
|
|
len' = sLength s1'
|
|
in if len' >= n then s1' else go (Just s1') len' s2
|