bac96b4433
* Markdown type * Markdown parser (WIP) * fix markdown parser * style markdown in messages * one-letter color abbreviations in markdown
123 lines
3.4 KiB
Haskell
123 lines
3.4 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module SimplexMarkdown where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Data.Attoparsec.Text (Parser)
|
|
import qualified Data.Attoparsec.Text as A
|
|
import Data.Either (fromRight)
|
|
import Data.Functor (($>))
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.String
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Styled
|
|
import System.Console.ANSI.Types
|
|
|
|
data Markdown = Markdown Format Text | Markdown :|: Markdown
|
|
deriving (Show)
|
|
|
|
data Format
|
|
= Bold
|
|
| Italic
|
|
| Underline
|
|
| StrikeThrough
|
|
| Colored Color
|
|
| NoFormat
|
|
deriving (Show)
|
|
|
|
instance Semigroup Markdown where (<>) = (:|:)
|
|
|
|
instance Monoid Markdown where mempty = unmarked ""
|
|
|
|
instance IsString Markdown where fromString = unmarked . T.pack
|
|
|
|
unmarked :: Text -> Markdown
|
|
unmarked = Markdown NoFormat
|
|
|
|
styleMarkdown :: Markdown -> StyledString
|
|
styleMarkdown (s1 :|: s2) = styleMarkdown s1 <> styleMarkdown s2
|
|
styleMarkdown (Markdown f s) = Styled sgr $ T.unpack s
|
|
where
|
|
sgr = case f of
|
|
Bold -> [SetConsoleIntensity BoldIntensity]
|
|
Italic -> [SetUnderlining SingleUnderline, SetItalicized True]
|
|
Underline -> [SetUnderlining SingleUnderline]
|
|
StrikeThrough -> [SetSwapForegroundBackground True]
|
|
Colored c -> [SetColor Foreground Vivid c]
|
|
NoFormat -> []
|
|
|
|
formats :: Map Char Format
|
|
formats =
|
|
M.fromList
|
|
[ ('*', Bold),
|
|
('_', Italic),
|
|
('+', Underline),
|
|
('~', StrikeThrough),
|
|
('^', Colored White)
|
|
]
|
|
|
|
colors :: Map Text Color
|
|
colors =
|
|
M.fromList
|
|
[ ("red", Red),
|
|
("green", Green),
|
|
("blue", Blue),
|
|
("yellow", Yellow),
|
|
("cyan", Cyan),
|
|
("magenta", Magenta),
|
|
("r", Red),
|
|
("g", Green),
|
|
("b", Blue),
|
|
("y", Yellow),
|
|
("c", Cyan),
|
|
("m", Magenta)
|
|
]
|
|
|
|
parseMarkdown :: Text -> Markdown
|
|
parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
|
|
|
|
markdownP :: Parser Markdown
|
|
markdownP = merge <$> A.many' fragmentP
|
|
where
|
|
merge :: [Markdown] -> Markdown
|
|
merge [] = ""
|
|
merge [f] = f
|
|
merge (f : fs) = foldl (:|:) f fs
|
|
fragmentP :: Parser Markdown
|
|
fragmentP =
|
|
A.anyChar >>= \case
|
|
' ' -> unmarked . (" " <>) <$> A.takeWhile (== ' ')
|
|
c -> case M.lookup c formats of
|
|
Just (Colored White) -> coloredP
|
|
Just f -> formattedP c "" f
|
|
Nothing -> unformattedP c
|
|
formattedP :: Char -> Text -> Format -> Parser Markdown
|
|
formattedP c p f = do
|
|
s <- A.takeTill (== c)
|
|
(A.char c $> Markdown f s) <|> noFormat (T.singleton c <> p <> s)
|
|
coloredP :: Parser Markdown
|
|
coloredP = do
|
|
color <- A.takeWhile (\c -> c /= ' ' && c /= '^')
|
|
case M.lookup color colors of
|
|
Just c ->
|
|
let f = Colored c
|
|
in (A.char ' ' *> formattedP '^' (color <> " ") f)
|
|
<|> (A.char '^' $> Markdown f color)
|
|
<|> noFormat ("^" <> color)
|
|
_ -> noFormat ("^" <> color)
|
|
unformattedP :: Char -> Parser Markdown
|
|
unformattedP c = unmarked . (T.singleton c <>) <$> wordsP
|
|
wordsP :: Parser Text
|
|
wordsP = do
|
|
s <- (<>) <$> A.takeTill (== ' ') <*> A.takeWhile (== ' ')
|
|
A.peekChar >>= \case
|
|
Nothing -> pure s
|
|
Just c -> case M.lookup c formats of
|
|
Just _ -> pure s
|
|
Nothing -> (s <>) <$> wordsP
|
|
noFormat :: Text -> Parser Markdown
|
|
noFormat = pure . unmarked
|