module Matterhorn.Types.RichText
( RichTextBlock(..)
, ListType(..)
, CodeBlockInfo(..)
, NumDecoration(..)
, Element(..)
, ElementData(..)
, ElementStyle(..)
, TeamBaseURL(..)
, TeamURLName(..)
, URL(..)
, unURL
, parseMarkdown
, setElementStyle
, findUsernames
, blockGetURLs
, findVerbatimChunk
, fromMarkdownBlocks
)
where
import Prelude ()
import Matterhorn.Prelude
import qualified Cheapskate as C
import Data.Char ( isAlphaNum, isAlpha )
import qualified Data.Foldable as F
import Data.Monoid (First(..))
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import Data.Sequence ( (<|), ViewL((:<)) )
import qualified Data.Text as T
import Network.Mattermost.Types ( PostId(..), Id(..), ServerBaseURL(..) )
import Matterhorn.Constants ( userSigil, normalChannelSigil )
data TeamURLName = TeamURLName Text
deriving (Eq, Show, Ord)
data TeamBaseURL = TeamBaseURL TeamURLName ServerBaseURL
deriving (Eq, Show)
data RichTextBlock =
Para (Seq Element)
| Header Int (Seq Element)
| Blockquote (Seq RichTextBlock)
| List Bool ListType (Seq (Seq RichTextBlock))
| CodeBlock CodeBlockInfo Text
| HTMLBlock Text
| HRule
deriving (Show)
data ListType =
Bullet Char
| Numbered NumDecoration Int
deriving (Eq, Show, Ord)
data CodeBlockInfo =
CodeBlockInfo { codeBlockLanguage :: Maybe Text
, codeBlockInfo :: Maybe Text
}
deriving (Eq, Show, Ord)
data NumDecoration =
Paren
| Period
deriving (Eq, Show, Ord)
data Element =
Element { eStyle :: ElementStyle
, eData :: ElementData
}
deriving (Show, Eq, Ord)
setElementStyle :: ElementStyle -> Element -> Element
setElementStyle s e = e { eStyle = s }
newtype URL = URL Text
deriving (Eq, Show, Ord)
unURL :: URL -> Text
unURL (URL url) = url
data ElementData =
EText Text
| ESpace
| ESoftBreak
| ELineBreak
| ERawHtml Text
| EEditSentinel Bool
| EUser Text
| EChannel Text
| EHyperlink URL (Maybe (Seq Element))
| EImage URL (Maybe (Seq Element))
| EEmoji Text
| ENonBreaking (Seq Element)
| EPermalink TeamURLName PostId (Maybe (Seq Element))
deriving (Show, Eq, Ord)
data ElementStyle =
Normal
| Emph
| Strikethrough
| Strong
| Code
| Hyperlink URL ElementStyle
| Permalink
deriving (Eq, Show, Ord)
parseMarkdown :: Maybe TeamBaseURL -> T.Text -> Seq RichTextBlock
parseMarkdown baseUrl t =
fromMarkdownBlocks baseUrl bs where C.Doc _ bs = C.markdown C.def t
fromMarkdownBlocks :: Maybe TeamBaseURL -> C.Blocks -> Seq RichTextBlock
fromMarkdownBlocks baseUrl = fmap (fromMarkdownBlock baseUrl)
fromMarkdownBlock :: Maybe TeamBaseURL -> C.Block -> RichTextBlock
fromMarkdownBlock baseUrl (C.Para is) =
Para $ fromMarkdownInlines baseUrl is
fromMarkdownBlock baseUrl (C.Header level is) =
Header level $ fromMarkdownInlines baseUrl is
fromMarkdownBlock baseUrl (C.Blockquote bs) =
Blockquote $ fromMarkdownBlock baseUrl <$> bs
fromMarkdownBlock baseUrl (C.List f ty bss) =
List f (fromMarkdownListType ty) $ fmap (fromMarkdownBlock baseUrl) <$> Seq.fromList bss
fromMarkdownBlock _ (C.CodeBlock attr body) =
CodeBlock (fromMarkdownCodeAttr attr) body
fromMarkdownBlock _ (C.HtmlBlock body) =
HTMLBlock body
fromMarkdownBlock _ C.HRule =
HRule
fromMarkdownCodeAttr :: C.CodeAttr -> CodeBlockInfo
fromMarkdownCodeAttr (C.CodeAttr lang info) =
let strippedLang = T.strip lang
strippedInfo = T.strip info
maybeText t = if T.null t then Nothing else Just t
in CodeBlockInfo (maybeText strippedLang)
(maybeText strippedInfo)
fromMarkdownListType :: C.ListType -> ListType
fromMarkdownListType (C.Bullet c) =
Bullet c
fromMarkdownListType (C.Numbered wrap i) =
let dec = case wrap of
C.PeriodFollowing -> Period
C.ParenFollowing -> Paren
in Numbered dec i
removeHyperlinks :: Seq C.Inline -> Seq C.Inline
removeHyperlinks is =
case Seq.viewl is of
h :< t ->
case h of
C.Link label theUrl _ ->
if Seq.null label
then C.Str theUrl <| removeHyperlinks t
else removeHyperlinks label <> removeHyperlinks t
_ -> h <| removeHyperlinks t
Seq.EmptyL -> mempty
fromMarkdownInlines :: Maybe TeamBaseURL -> Seq C.Inline -> Seq Element
fromMarkdownInlines baseUrl inlines =
let go sty is = case Seq.viewl is of
C.Str "~" :< xs ->
case Seq.viewl xs of
C.Str "~" :< xs2 ->
case takeUntilStrikethroughEnd xs2 of
Nothing -> Element sty (EText "~") <|
go sty xs
Just (strikethroughInlines, rest) ->
go Strikethrough strikethroughInlines <>
go sty rest
_ ->
let (cFrags, rest) = Seq.spanl isNameFragment xs
cn = T.concat (unsafeGetStr <$> F.toList cFrags)
in if not (T.null cn)
then Element sty (EChannel cn) <| go sty rest
else Element sty (EText normalChannelSigil) <| go sty xs
C.Str ":" :< xs ->
let validEmojiFragment (C.Str f) =
f `elem` ["_", "-"] || T.all isAlphaNum f
validEmojiFragment _ = False
(emojiFrags, rest) = Seq.spanl validEmojiFragment xs
em = T.concat $ unsafeGetStr <$> F.toList emojiFrags
in case Seq.viewl rest of
C.Str ":" :< rest2 ->
Element Normal (EEmoji em) <| go sty rest2
_ ->
Element sty (EText ":") <| go sty xs
C.Str t :< xs | userSigil `T.isPrefixOf` t ->
let (uFrags, rest) = Seq.spanl isNameFragment xs
t' = T.concat $ t : (unsafeGetStr <$> F.toList uFrags)
u = T.drop 1 t'
in Element sty (EUser u) <| go sty rest
C.Str t :< xs ->
let rest = go sty xs
e = Element sty (EText t)
in case Seq.viewl rest of
Element sty2 (EText t2) :< tail_ | sty2 == sty ->
(Element sty (EText (t <> t2))) <| tail_
_ ->
e <| rest
C.Space :< xs ->
Element sty ESpace <| go sty xs
C.SoftBreak :< xs ->
Element sty ESoftBreak <| go sty xs
C.LineBreak :< xs ->
Element sty ELineBreak <| go sty xs
C.Link label theUrl _ :< xs ->
let mLabel = if Seq.null label
then Nothing
else case F.toList label of
[C.Str u] | u == theUrl -> Nothing
_ -> Just $ fromMarkdownInlines baseUrl $ removeHyperlinks label
rest = go sty xs
this = case flip getPermalink theUrl =<< baseUrl of
Nothing ->
let url = URL theUrl
in Element (Hyperlink url sty) $ EHyperlink url mLabel
Just (tName, pId) ->
Element Permalink $ EPermalink tName pId mLabel
in this <| rest
C.Image altIs theUrl _ :< xs ->
let mLabel = if Seq.null altIs
then Nothing
else Just $ fromMarkdownInlines baseUrl altIs
url = URL theUrl
in (Element (Hyperlink url sty) $ EImage url mLabel) <| go sty xs
C.RawHtml t :< xs ->
Element sty (ERawHtml t) <| go sty xs
C.Code t :< xs ->
let ts = [ Element Code frag
| wd <- T.split (== ' ') t
, frag <- case wd of
"" -> [ESpace]
_ -> [ESpace, EText wd]
]
ts' = case ts of
(Element _ ESpace:rs) -> rs
_ -> ts
in Seq.fromList ts' <> go sty xs
C.Emph as :< xs ->
go Emph as <> go sty xs
C.Strong as :< xs ->
go Strong as <> go sty xs
C.Entity t :< xs ->
Element sty (EText t) <| go sty xs
Seq.EmptyL -> mempty
in go Normal inlines
takeUntilStrikethroughEnd :: Seq C.Inline -> Maybe (Seq C.Inline, Seq C.Inline)
takeUntilStrikethroughEnd is =
let go pos s = case Seq.viewl s of
C.Str "~" :< rest ->
case Seq.viewl rest of
C.Str "~" :< _ ->
Just pos
_ -> go (pos + 1) rest
_ :< rest -> go (pos + 1) rest
Seq.EmptyL -> Nothing
in do
pos <- go 0 is
let (h, t) = Seq.splitAt pos is
return (h, Seq.drop 2 t)
getPermalink :: TeamBaseURL -> Text -> Maybe (TeamURLName, PostId)
getPermalink (TeamBaseURL tName (ServerBaseURL baseUrl)) url =
let newBaseUrl = if "/" `T.isSuffixOf` baseUrl
then baseUrl
else baseUrl <> "/"
in if not $ newBaseUrl `T.isPrefixOf` url
then Nothing
else let rest = T.drop (T.length newBaseUrl) url
(tName', rawPIdStr) = T.breakOn "/pl/" rest
pIdStr = T.drop 4 rawPIdStr
in if tName == TeamURLName tName' && not (T.null pIdStr)
then Just (tName, PI $ Id pIdStr)
else Nothing
unsafeGetStr :: C.Inline -> Text
unsafeGetStr (C.Str t) = t
unsafeGetStr _ = error "BUG: unsafeGetStr called on non-Str Inline"
findUsernames :: Seq RichTextBlock -> S.Set T.Text
findUsernames = S.unions . F.toList . fmap blockFindUsernames
blockFindUsernames :: RichTextBlock -> S.Set T.Text
blockFindUsernames (Para is) =
elementFindUsernames $ F.toList is
blockFindUsernames (Header _ is) =
elementFindUsernames $ F.toList is
blockFindUsernames (Blockquote bs) =
findUsernames bs
blockFindUsernames (List _ _ bs) =
S.unions $ F.toList $ findUsernames <$> bs
blockFindUsernames _ =
mempty
elementFindUsernames :: [Element] -> S.Set T.Text
elementFindUsernames [] = mempty
elementFindUsernames (e : es) =
case eData e of
EUser u -> S.insert u $ elementFindUsernames es
_ -> elementFindUsernames es
blockGetURLs :: RichTextBlock -> [(Either (TeamURLName, PostId) URL, Maybe (Seq Element))]
blockGetURLs (Para is) =
catMaybes $ elementGetURL <$> toList is
blockGetURLs (Header _ is) =
catMaybes $ elementGetURL <$> toList is
blockGetURLs (Blockquote bs) =
mconcat $ blockGetURLs <$> toList bs
blockGetURLs (List _ _ bss) =
mconcat $ mconcat $
(fmap blockGetURLs . F.toList) <$> F.toList bss
blockGetURLs _ =
mempty
elementGetURL :: Element -> Maybe (Either (TeamURLName, PostId) URL, Maybe (Seq Element))
elementGetURL (Element _ (EHyperlink url label)) =
Just (Right url, label)
elementGetURL (Element _ (EImage url label)) =
Just (Right url, label)
elementGetURL (Element _ (EPermalink tName pId label)) =
Just (Left (tName, pId), label)
elementGetURL _ =
Nothing
findVerbatimChunk :: Seq RichTextBlock -> Maybe Text
findVerbatimChunk = getFirst . F.foldMap go
where go (CodeBlock _ t) = First (Just t)
go _ = First Nothing
isValidNameChar :: Char -> Bool
isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-'
isNameFragment :: C.Inline -> Bool
isNameFragment (C.Str t) =
not (T.null t) && isValidNameChar (T.head t)
isNameFragment _ = False