{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | This module provides a set of data types to represent message text.
-- The inline and block types in this module are designed to represent
-- most of what is found in Markdown documents (particularly the
-- Commonmark specification) in addition to other things we find in
-- Mattermost messages, such as username or channel references.
--
-- To parse a Markdown document, use 'parseMarkdown'. To actually render
-- text in this representation, see the module 'Draw.RichText'.
module Matterhorn.Types.RichText
  ( Blocks(..)
  , unBlocks

  , Block(..)
  , sameBlockType
  , CodeBlockInfo(..)
  , Inline(..)
  , Inlines(..)
  , unInlines

  , C.ListType(..)
  , C.ListSpacing(..)
  , C.EnumeratorType(..)
  , C.DelimiterType(..)
  , C.ColAlignment(..)

  , TeamBaseURL(..)
  , TeamURLName(..)

  , URL(..)
  , unURL

  , parseMarkdown

  , findUsernames
  , blockGetURLs
  , findVerbatimChunk
  , makePermalink
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Commonmark as C
import qualified Commonmark.Extensions as C
import qualified Commonmark.Inlines as C
import qualified Commonmark.TokParsers as C
import           Control.Monad.Identity
import qualified Data.Foldable as F
import           Data.List ( intersperse )
import           Data.Monoid (First(..))
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import           Data.Sequence ( (<|), viewl, viewr, ViewL((:<)), ViewR((:>)) )
import qualified Data.Text as T
import qualified Text.Parsec as P

import           Network.Mattermost.Types ( PostId(..), Id(..), ServerBaseURL(..) )

import           Matterhorn.Constants ( userSigilChar, normalChannelSigilChar )

-- | A team name found in a Mattermost post URL
data TeamURLName = TeamURLName Text
                 deriving (TeamURLName -> TeamURLName -> Bool
(TeamURLName -> TeamURLName -> Bool)
-> (TeamURLName -> TeamURLName -> Bool) -> Eq TeamURLName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TeamURLName -> TeamURLName -> Bool
$c/= :: TeamURLName -> TeamURLName -> Bool
== :: TeamURLName -> TeamURLName -> Bool
$c== :: TeamURLName -> TeamURLName -> Bool
Eq, Int -> TeamURLName -> ShowS
[TeamURLName] -> ShowS
TeamURLName -> String
(Int -> TeamURLName -> ShowS)
-> (TeamURLName -> String)
-> ([TeamURLName] -> ShowS)
-> Show TeamURLName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TeamURLName] -> ShowS
$cshowList :: [TeamURLName] -> ShowS
show :: TeamURLName -> String
$cshow :: TeamURLName -> String
showsPrec :: Int -> TeamURLName -> ShowS
$cshowsPrec :: Int -> TeamURLName -> ShowS
Show, Eq TeamURLName
Eq TeamURLName
-> (TeamURLName -> TeamURLName -> Ordering)
-> (TeamURLName -> TeamURLName -> Bool)
-> (TeamURLName -> TeamURLName -> Bool)
-> (TeamURLName -> TeamURLName -> Bool)
-> (TeamURLName -> TeamURLName -> Bool)
-> (TeamURLName -> TeamURLName -> TeamURLName)
-> (TeamURLName -> TeamURLName -> TeamURLName)
-> Ord TeamURLName
TeamURLName -> TeamURLName -> Bool
TeamURLName -> TeamURLName -> Ordering
TeamURLName -> TeamURLName -> TeamURLName
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
min :: TeamURLName -> TeamURLName -> TeamURLName
$cmin :: TeamURLName -> TeamURLName -> TeamURLName
max :: TeamURLName -> TeamURLName -> TeamURLName
$cmax :: TeamURLName -> TeamURLName -> TeamURLName
>= :: TeamURLName -> TeamURLName -> Bool
$c>= :: TeamURLName -> TeamURLName -> Bool
> :: TeamURLName -> TeamURLName -> Bool
$c> :: TeamURLName -> TeamURLName -> Bool
<= :: TeamURLName -> TeamURLName -> Bool
$c<= :: TeamURLName -> TeamURLName -> Bool
< :: TeamURLName -> TeamURLName -> Bool
$c< :: TeamURLName -> TeamURLName -> Bool
compare :: TeamURLName -> TeamURLName -> Ordering
$ccompare :: TeamURLName -> TeamURLName -> Ordering
$cp1Ord :: Eq TeamURLName
Ord)

-- | A server base URL with a team name.
data TeamBaseURL = TeamBaseURL TeamURLName ServerBaseURL
                 deriving (TeamBaseURL -> TeamBaseURL -> Bool
(TeamBaseURL -> TeamBaseURL -> Bool)
-> (TeamBaseURL -> TeamBaseURL -> Bool) -> Eq TeamBaseURL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TeamBaseURL -> TeamBaseURL -> Bool
$c/= :: TeamBaseURL -> TeamBaseURL -> Bool
== :: TeamBaseURL -> TeamBaseURL -> Bool
$c== :: TeamBaseURL -> TeamBaseURL -> Bool
Eq, Int -> TeamBaseURL -> ShowS
[TeamBaseURL] -> ShowS
TeamBaseURL -> String
(Int -> TeamBaseURL -> ShowS)
-> (TeamBaseURL -> String)
-> ([TeamBaseURL] -> ShowS)
-> Show TeamBaseURL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TeamBaseURL] -> ShowS
$cshowList :: [TeamBaseURL] -> ShowS
show :: TeamBaseURL -> String
$cshow :: TeamBaseURL -> String
showsPrec :: Int -> TeamBaseURL -> ShowS
$cshowsPrec :: Int -> TeamBaseURL -> ShowS
Show)

-- | A sequence of rich text blocks.
newtype Blocks = Blocks (Seq Block)
            deriving (b -> Blocks -> Blocks
NonEmpty Blocks -> Blocks
Blocks -> Blocks -> Blocks
(Blocks -> Blocks -> Blocks)
-> (NonEmpty Blocks -> Blocks)
-> (forall b. Integral b => b -> Blocks -> Blocks)
-> Semigroup Blocks
forall b. Integral b => b -> Blocks -> Blocks
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Blocks -> Blocks
$cstimes :: forall b. Integral b => b -> Blocks -> Blocks
sconcat :: NonEmpty Blocks -> Blocks
$csconcat :: NonEmpty Blocks -> Blocks
<> :: Blocks -> Blocks -> Blocks
$c<> :: Blocks -> Blocks -> Blocks
Semigroup, Semigroup Blocks
Blocks
Semigroup Blocks
-> Blocks
-> (Blocks -> Blocks -> Blocks)
-> ([Blocks] -> Blocks)
-> Monoid Blocks
[Blocks] -> Blocks
Blocks -> Blocks -> Blocks
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Blocks] -> Blocks
$cmconcat :: [Blocks] -> Blocks
mappend :: Blocks -> Blocks -> Blocks
$cmappend :: Blocks -> Blocks -> Blocks
mempty :: Blocks
$cmempty :: Blocks
$cp1Monoid :: Semigroup Blocks
Monoid, Int -> Blocks -> ShowS
[Blocks] -> ShowS
Blocks -> String
(Int -> Blocks -> ShowS)
-> (Blocks -> String) -> ([Blocks] -> ShowS) -> Show Blocks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Blocks] -> ShowS
$cshowList :: [Blocks] -> ShowS
show :: Blocks -> String
$cshow :: Blocks -> String
showsPrec :: Int -> Blocks -> ShowS
$cshowsPrec :: Int -> Blocks -> ShowS
Show, Blocks -> Blocks -> Bool
(Blocks -> Blocks -> Bool)
-> (Blocks -> Blocks -> Bool) -> Eq Blocks
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Blocks -> Blocks -> Bool
$c/= :: Blocks -> Blocks -> Bool
== :: Blocks -> Blocks -> Bool
$c== :: Blocks -> Blocks -> Bool
Eq)

unBlocks :: Blocks -> Seq Block
unBlocks :: Blocks -> Seq Block
unBlocks (Blocks Seq Block
bs) = Seq Block
bs

singleB :: Block -> Blocks
singleB :: Block -> Blocks
singleB = Seq Block -> Blocks
Blocks (Seq Block -> Blocks) -> (Block -> Seq Block) -> Block -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Seq Block
forall a. a -> Seq a
Seq.singleton

-- | A block in a rich text document.
--
-- NOTE: update 'sameBlockType' when constructors are added to this
-- type.
data Block =
    Para Inlines
    -- ^ A paragraph.
    | Header Int Inlines
    -- ^ A section header with specified depth and contents.
    | Blockquote Blocks
    -- ^ A blockquote.
    | List C.ListType C.ListSpacing (Seq Blocks)
    -- ^ An itemized list.
    | CodeBlock CodeBlockInfo Text
    -- ^ A code block.
    | HTMLBlock Text
    -- ^ A fragment of raw HTML.
    | HRule
    -- ^ A horizontal rule.
    | Table [C.ColAlignment] [Inlines] [[Inlines]]
    -- ^ A table.
    deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show, Block -> Block -> Bool
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq)

-- | Returns whether two blocks have the same type.
sameBlockType :: Block -> Block -> Bool
sameBlockType :: Block -> Block -> Bool
sameBlockType (Para {})       (Para {})       = Bool
True
sameBlockType (Header {})     (Header {})     = Bool
True
sameBlockType (Blockquote {}) (Blockquote {}) = Bool
True
sameBlockType (List {})       (List {})       = Bool
True
sameBlockType (CodeBlock {})  (CodeBlock {})  = Bool
True
sameBlockType (HTMLBlock {})  (HTMLBlock {})  = Bool
True
sameBlockType Block
_               Block
_               = Bool
False

-- | Information about a code block.
data CodeBlockInfo =
    CodeBlockInfo { CodeBlockInfo -> Maybe Text
codeBlockLanguage :: Maybe Text
                  -- ^ The language of the source code in the code
                  -- block, if any. This is encoded in Markdown as a
                  -- sequence of non-whitespace characters following the
                  -- fenced code block opening backticks.
                  , CodeBlockInfo -> Maybe Text
codeBlockInfo :: Maybe Text
                  -- ^ Any text that comes after the language token.
                  -- This text is separated from the language token by
                  -- whitespace.
                  }
                  deriving (CodeBlockInfo -> CodeBlockInfo -> Bool
(CodeBlockInfo -> CodeBlockInfo -> Bool)
-> (CodeBlockInfo -> CodeBlockInfo -> Bool) -> Eq CodeBlockInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodeBlockInfo -> CodeBlockInfo -> Bool
$c/= :: CodeBlockInfo -> CodeBlockInfo -> Bool
== :: CodeBlockInfo -> CodeBlockInfo -> Bool
$c== :: CodeBlockInfo -> CodeBlockInfo -> Bool
Eq, Int -> CodeBlockInfo -> ShowS
[CodeBlockInfo] -> ShowS
CodeBlockInfo -> String
(Int -> CodeBlockInfo -> ShowS)
-> (CodeBlockInfo -> String)
-> ([CodeBlockInfo] -> ShowS)
-> Show CodeBlockInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeBlockInfo] -> ShowS
$cshowList :: [CodeBlockInfo] -> ShowS
show :: CodeBlockInfo -> String
$cshow :: CodeBlockInfo -> String
showsPrec :: Int -> CodeBlockInfo -> ShowS
$cshowsPrec :: Int -> CodeBlockInfo -> ShowS
Show, Eq CodeBlockInfo
Eq CodeBlockInfo
-> (CodeBlockInfo -> CodeBlockInfo -> Ordering)
-> (CodeBlockInfo -> CodeBlockInfo -> Bool)
-> (CodeBlockInfo -> CodeBlockInfo -> Bool)
-> (CodeBlockInfo -> CodeBlockInfo -> Bool)
-> (CodeBlockInfo -> CodeBlockInfo -> Bool)
-> (CodeBlockInfo -> CodeBlockInfo -> CodeBlockInfo)
-> (CodeBlockInfo -> CodeBlockInfo -> CodeBlockInfo)
-> Ord CodeBlockInfo
CodeBlockInfo -> CodeBlockInfo -> Bool
CodeBlockInfo -> CodeBlockInfo -> Ordering
CodeBlockInfo -> CodeBlockInfo -> CodeBlockInfo
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
min :: CodeBlockInfo -> CodeBlockInfo -> CodeBlockInfo
$cmin :: CodeBlockInfo -> CodeBlockInfo -> CodeBlockInfo
max :: CodeBlockInfo -> CodeBlockInfo -> CodeBlockInfo
$cmax :: CodeBlockInfo -> CodeBlockInfo -> CodeBlockInfo
>= :: CodeBlockInfo -> CodeBlockInfo -> Bool
$c>= :: CodeBlockInfo -> CodeBlockInfo -> Bool
> :: CodeBlockInfo -> CodeBlockInfo -> Bool
$c> :: CodeBlockInfo -> CodeBlockInfo -> Bool
<= :: CodeBlockInfo -> CodeBlockInfo -> Bool
$c<= :: CodeBlockInfo -> CodeBlockInfo -> Bool
< :: CodeBlockInfo -> CodeBlockInfo -> Bool
$c< :: CodeBlockInfo -> CodeBlockInfo -> Bool
compare :: CodeBlockInfo -> CodeBlockInfo -> Ordering
$ccompare :: CodeBlockInfo -> CodeBlockInfo -> Ordering
$cp1Ord :: Eq CodeBlockInfo
Ord)

-- | A URL.
newtype URL = URL Text
            deriving (URL -> URL -> Bool
(URL -> URL -> Bool) -> (URL -> URL -> Bool) -> Eq URL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URL -> URL -> Bool
$c/= :: URL -> URL -> Bool
== :: URL -> URL -> Bool
$c== :: URL -> URL -> Bool
Eq, Int -> URL -> ShowS
[URL] -> ShowS
URL -> String
(Int -> URL -> ShowS)
-> (URL -> String) -> ([URL] -> ShowS) -> Show URL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URL] -> ShowS
$cshowList :: [URL] -> ShowS
show :: URL -> String
$cshow :: URL -> String
showsPrec :: Int -> URL -> ShowS
$cshowsPrec :: Int -> URL -> ShowS
Show, Eq URL
Eq URL
-> (URL -> URL -> Ordering)
-> (URL -> URL -> Bool)
-> (URL -> URL -> Bool)
-> (URL -> URL -> Bool)
-> (URL -> URL -> Bool)
-> (URL -> URL -> URL)
-> (URL -> URL -> URL)
-> Ord URL
URL -> URL -> Bool
URL -> URL -> Ordering
URL -> URL -> URL
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
min :: URL -> URL -> URL
$cmin :: URL -> URL -> URL
max :: URL -> URL -> URL
$cmax :: URL -> URL -> URL
>= :: URL -> URL -> Bool
$c>= :: URL -> URL -> Bool
> :: URL -> URL -> Bool
$c> :: URL -> URL -> Bool
<= :: URL -> URL -> Bool
$c<= :: URL -> URL -> Bool
< :: URL -> URL -> Bool
$c< :: URL -> URL -> Bool
compare :: URL -> URL -> Ordering
$ccompare :: URL -> URL -> Ordering
$cp1Ord :: Eq URL
Ord)

unURL :: URL -> Text
unURL :: URL -> Text
unURL (URL Text
url) = Text
url

-- | The kinds of inline values that can appear in rich text blocks.
data Inline =
    EText Text
    -- ^ Plain text that SHOULD be a contiguous sequence of
    -- non-whitespace characters.
    | EEmph Inlines
    -- ^ Emphasized (usually italicized) content.
    | EStrikethrough Inlines
    -- ^ Strikethrough content.
    | EStrong Inlines
    -- ^ Boldface content.
    | ECode Inlines
    -- ^ A sequence of non-whitespace characters.
    | ESpace
    -- ^ A single space.
    | ESoftBreak
    -- ^ A soft line break.
    | ELineBreak
    -- ^ A hard line break.
    | ERawHtml Text
    -- ^ Raw HTML.
    | EEditSentinel Bool
    -- ^ A sentinel indicating that some text has been edited (used
    -- to indicate that mattermost messages have been edited by their
    -- authors). This has no parsable representation; it is only used
    -- to annotate a message prior to rendering to add a visual editing
    -- indicator. The boolean indicates whether the edit was "recent"
    -- (True) or not (False).
    | EUser Text
    -- ^ A user reference. The text here includes only the username, not
    -- the sigil.
    | EChannel Text
    -- ^ A channel reference. The text here includes only the channel
    -- name, not the sigil.
    | EHyperlink URL Inlines
    -- ^ A hyperlink to the specified URL. Optionally provides an
    -- element sequence indicating the URL's text label; if absent, the
    -- label is understood to be the URL itself.
    | EImage URL Inlines
    -- ^ An image at the specified URL. Optionally provides an element
    -- sequence indicating the image's "alt" text label; if absent, the
    -- label is understood to be the URL itself.
    | EEmoji Text
    -- ^ An emoji reference. The text here includes only the text
    -- portion, not the colons, e.g. "foo" instead of ":foo:".
    | ENonBreaking Inlines
    -- ^ A sequence of elements that must never be separated during line
    -- wrapping.
    | EPermalink TeamURLName PostId (Maybe Inlines)
    -- ^ A permalink to the specified team (name) and post ID with an
    -- optional label.
    deriving (Int -> Inline -> ShowS
[Inline] -> ShowS
Inline -> String
(Int -> Inline -> ShowS)
-> (Inline -> String) -> ([Inline] -> ShowS) -> Show Inline
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inline] -> ShowS
$cshowList :: [Inline] -> ShowS
show :: Inline -> String
$cshow :: Inline -> String
showsPrec :: Int -> Inline -> ShowS
$cshowsPrec :: Int -> Inline -> ShowS
Show, Inline -> Inline -> Bool
(Inline -> Inline -> Bool)
-> (Inline -> Inline -> Bool) -> Eq Inline
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Inline -> Inline -> Bool
$c/= :: Inline -> Inline -> Bool
== :: Inline -> Inline -> Bool
$c== :: Inline -> Inline -> Bool
Eq, Eq Inline
Eq Inline
-> (Inline -> Inline -> Ordering)
-> (Inline -> Inline -> Bool)
-> (Inline -> Inline -> Bool)
-> (Inline -> Inline -> Bool)
-> (Inline -> Inline -> Bool)
-> (Inline -> Inline -> Inline)
-> (Inline -> Inline -> Inline)
-> Ord Inline
Inline -> Inline -> Bool
Inline -> Inline -> Ordering
Inline -> Inline -> Inline
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
min :: Inline -> Inline -> Inline
$cmin :: Inline -> Inline -> Inline
max :: Inline -> Inline -> Inline
$cmax :: Inline -> Inline -> Inline
>= :: Inline -> Inline -> Bool
$c>= :: Inline -> Inline -> Bool
> :: Inline -> Inline -> Bool
$c> :: Inline -> Inline -> Bool
<= :: Inline -> Inline -> Bool
$c<= :: Inline -> Inline -> Bool
< :: Inline -> Inline -> Bool
$c< :: Inline -> Inline -> Bool
compare :: Inline -> Inline -> Ordering
$ccompare :: Inline -> Inline -> Ordering
$cp1Ord :: Eq Inline
Ord)

-- | A sequence of inline values.
newtype Inlines = Inlines (Seq Inline)
                deriving (Semigroup Inlines
Inlines
Semigroup Inlines
-> Inlines
-> (Inlines -> Inlines -> Inlines)
-> ([Inlines] -> Inlines)
-> Monoid Inlines
[Inlines] -> Inlines
Inlines -> Inlines -> Inlines
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Inlines] -> Inlines
$cmconcat :: [Inlines] -> Inlines
mappend :: Inlines -> Inlines -> Inlines
$cmappend :: Inlines -> Inlines -> Inlines
mempty :: Inlines
$cmempty :: Inlines
$cp1Monoid :: Semigroup Inlines
Monoid, Eq Inlines
Eq Inlines
-> (Inlines -> Inlines -> Ordering)
-> (Inlines -> Inlines -> Bool)
-> (Inlines -> Inlines -> Bool)
-> (Inlines -> Inlines -> Bool)
-> (Inlines -> Inlines -> Bool)
-> (Inlines -> Inlines -> Inlines)
-> (Inlines -> Inlines -> Inlines)
-> Ord Inlines
Inlines -> Inlines -> Bool
Inlines -> Inlines -> Ordering
Inlines -> Inlines -> Inlines
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
min :: Inlines -> Inlines -> Inlines
$cmin :: Inlines -> Inlines -> Inlines
max :: Inlines -> Inlines -> Inlines
$cmax :: Inlines -> Inlines -> Inlines
>= :: Inlines -> Inlines -> Bool
$c>= :: Inlines -> Inlines -> Bool
> :: Inlines -> Inlines -> Bool
$c> :: Inlines -> Inlines -> Bool
<= :: Inlines -> Inlines -> Bool
$c<= :: Inlines -> Inlines -> Bool
< :: Inlines -> Inlines -> Bool
$c< :: Inlines -> Inlines -> Bool
compare :: Inlines -> Inlines -> Ordering
$ccompare :: Inlines -> Inlines -> Ordering
$cp1Ord :: Eq Inlines
Ord, Inlines -> Inlines -> Bool
(Inlines -> Inlines -> Bool)
-> (Inlines -> Inlines -> Bool) -> Eq Inlines
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Inlines -> Inlines -> Bool
$c/= :: Inlines -> Inlines -> Bool
== :: Inlines -> Inlines -> Bool
$c== :: Inlines -> Inlines -> Bool
Eq, Int -> Inlines -> ShowS
[Inlines] -> ShowS
Inlines -> String
(Int -> Inlines -> ShowS)
-> (Inlines -> String) -> ([Inlines] -> ShowS) -> Show Inlines
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inlines] -> ShowS
$cshowList :: [Inlines] -> ShowS
show :: Inlines -> String
$cshow :: Inlines -> String
showsPrec :: Int -> Inlines -> ShowS
$cshowsPrec :: Int -> Inlines -> ShowS
Show)

unInlines :: Inlines -> Seq Inline
unInlines :: Inlines -> Seq Inline
unInlines (Inlines Seq Inline
is) = Seq Inline
is

singleI :: Inline -> Inlines
singleI :: Inline -> Inlines
singleI = Seq Inline -> Inlines
Inlines (Seq Inline -> Inlines)
-> (Inline -> Seq Inline) -> Inline -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inline -> Seq Inline
forall a. a -> Seq a
Seq.singleton

instance Semigroup Inlines where
    (Inlines Seq Inline
l) <> :: Inlines -> Inlines -> Inlines
<> (Inlines Seq Inline
r) =
        Seq Inline -> Inlines
Inlines (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ case (Seq Inline -> ViewR Inline
forall a. Seq a -> ViewR a
viewr Seq Inline
l, Seq Inline -> ViewL Inline
forall a. Seq a -> ViewL a
viewl Seq Inline
r) of
            (Seq Inline
lInit :> Inline
lLast, Inline
rHead :< Seq Inline
rTail) ->
                case (Inline
lLast, Inline
rHead) of
                    (EText Text
a, EText Text
b) ->
                        Seq Inline
lInit Seq Inline -> Seq Inline -> Seq Inline
forall a. Semigroup a => a -> a -> a
<> ((Text -> Inline
EText (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b) Inline -> Seq Inline -> Seq Inline
forall a. a -> Seq a -> Seq a
<| Seq Inline
rTail)
                    (ECode Inlines
a, ECode Inlines
b) ->
                        Seq Inline
lInit Seq Inline -> Seq Inline -> Seq Inline
forall a. Semigroup a => a -> a -> a
<> ((Inlines -> Inline
ECode (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ Inlines
a Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
b) Inline -> Seq Inline -> Seq Inline
forall a. a -> Seq a -> Seq a
<| Seq Inline
rTail)
                    (EEmph Inlines
a, EEmph Inlines
b) ->
                        Seq Inline
lInit Seq Inline -> Seq Inline -> Seq Inline
forall a. Semigroup a => a -> a -> a
<> ((Inlines -> Inline
EEmph (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ Inlines
a Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
b) Inline -> Seq Inline -> Seq Inline
forall a. a -> Seq a -> Seq a
<| Seq Inline
rTail)
                    (EStrikethrough Inlines
a, EStrikethrough Inlines
b) ->
                        Seq Inline
lInit Seq Inline -> Seq Inline -> Seq Inline
forall a. Semigroup a => a -> a -> a
<> ((Inlines -> Inline
EStrikethrough (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ Inlines
a Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
b) Inline -> Seq Inline -> Seq Inline
forall a. a -> Seq a -> Seq a
<| Seq Inline
rTail)
                    (EStrong Inlines
a, EStrong Inlines
b) ->
                        Seq Inline
lInit Seq Inline -> Seq Inline -> Seq Inline
forall a. Semigroup a => a -> a -> a
<> ((Inlines -> Inline
EStrong (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ Inlines
a Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
b) Inline -> Seq Inline -> Seq Inline
forall a. a -> Seq a -> Seq a
<| Seq Inline
rTail)
                    (Inline
_, Inline
_) ->
                        Seq Inline
l Seq Inline -> Seq Inline -> Seq Inline
forall a. Semigroup a => a -> a -> a
<> Seq Inline
r
            (ViewR Inline
_, ViewL Inline
_) -> Seq Inline
l Seq Inline -> Seq Inline -> Seq Inline
forall a. Semigroup a => a -> a -> a
<> Seq Inline
r

-- A dummy instance just to satisfy commonmark; we don't use this.
instance C.Rangeable Inlines where
    ranged :: SourceRange -> Inlines -> Inlines
ranged SourceRange
_ = Inlines -> Inlines
forall a. a -> a
id

-- A dummy instance just to satisfy commonmark; we don't use this.
instance C.HasAttributes Inlines where
    addAttributes :: Attributes -> Inlines -> Inlines
addAttributes Attributes
_ = Inlines -> Inlines
forall a. a -> a
id

instance C.IsInline Inlines where
    lineBreak :: Inlines
lineBreak = Inline -> Inlines
singleI Inline
ELineBreak
    softBreak :: Inlines
softBreak = Inline -> Inlines
singleI Inline
ESoftBreak
    str :: Text -> Inlines
str Text
t = Seq Inline -> Inlines
Inlines (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ [Inline] -> Seq Inline
forall a. [a] -> Seq a
Seq.fromList ([Inline] -> Seq Inline) -> [Inline] -> Seq Inline
forall a b. (a -> b) -> a -> b
$
            (Inline -> Bool) -> [Inline] -> [Inline]
forall a. (a -> Bool) -> [a] -> [a]
filter (Inline -> Inline -> Bool
forall a. Eq a => a -> a -> Bool
/= (Text -> Inline
EText Text
"")) ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$
            Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
intersperse Inline
ESpace ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall a b. (a -> b) -> a -> b
$ Text -> Inline
EText (Text -> Inline) -> [Text] -> [Inline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
T.splitOn Text
" " Text
t
    entity :: Text -> Inlines
entity = Inline -> Inlines
singleI (Inline -> Inlines) -> (Text -> Inline) -> Text -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
EText
    escapedChar :: Char -> Inlines
escapedChar = Inline -> Inlines
singleI (Inline -> Inlines) -> (Char -> Inline) -> Char -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
EText (Text -> Inline) -> (Char -> Text) -> Char -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton
    emph :: Inlines -> Inlines
emph = Inline -> Inlines
singleI (Inline -> Inlines) -> (Inlines -> Inline) -> Inlines -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Inline
EEmph
    strong :: Inlines -> Inlines
strong = Inline -> Inlines
singleI (Inline -> Inlines) -> (Inlines -> Inline) -> Inlines -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Inline
EStrong
    link :: Text -> Text -> Inlines -> Inlines
link Text
url Text
_title Inlines
desc = Inline -> Inlines
singleI (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ URL -> Inlines -> Inline
EHyperlink (Text -> URL
URL Text
url) Inlines
desc
    image :: Text -> Text -> Inlines -> Inlines
image Text
url Text
_title Inlines
desc = Inline -> Inlines
singleI (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ URL -> Inlines -> Inline
EImage (Text -> URL
URL Text
url) Inlines
desc
    code :: Text -> Inlines
code Text
t = Inline -> Inlines
singleI (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inlines -> Inline
ECode (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
forall a. IsInline a => Text -> a
C.str Text
t
    rawInline :: Format -> Text -> Inlines
rawInline Format
_ = Inline -> Inlines
singleI (Inline -> Inlines) -> (Text -> Inline) -> Text -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inline
ERawHtml

instance C.HasStrikethrough Inlines where
    strikethrough :: Inlines -> Inlines
strikethrough = Inline -> Inlines
singleI (Inline -> Inlines) -> (Inlines -> Inline) -> Inlines -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Inline
EStrikethrough

instance C.HasPipeTable Inlines Blocks where
    pipeTable :: [ColAlignment] -> [Inlines] -> [[Inlines]] -> Blocks
pipeTable [ColAlignment]
a [Inlines]
h [[Inlines]]
b = Block -> Blocks
singleB (Block -> Blocks) -> Block -> Blocks
forall a b. (a -> b) -> a -> b
$ [ColAlignment] -> [Inlines] -> [[Inlines]] -> Block
Table [ColAlignment]
a [Inlines]
h [[Inlines]]
b

-- Syntax extension for parsing ~channel references.
channelSpec :: (Monad m) => C.SyntaxSpec m Inlines Blocks
channelSpec :: SyntaxSpec m Inlines Blocks
channelSpec =
    SyntaxSpec m Inlines Blocks
forall a. Monoid a => a
mempty { syntaxInlineParsers :: [InlineParser m Inlines]
C.syntaxInlineParsers = [InlineParser m Inlines -> InlineParser m Inlines
forall a (m :: * -> *).
(IsInline a, Monad m) =>
InlineParser m a -> InlineParser m a
C.withAttributes InlineParser m Inlines
forall (m :: * -> *). Monad m => InlineParser m Inlines
parseChannel]
           }

parseChannel :: (Monad m) => C.InlineParser m Inlines
parseChannel :: InlineParser m Inlines
parseChannel = InlineParser m Inlines -> InlineParser m Inlines
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (InlineParser m Inlines -> InlineParser m Inlines)
-> InlineParser m Inlines -> InlineParser m Inlines
forall a b. (a -> b) -> a -> b
$ do
    ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) ())
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
normalChannelSigilChar
    let chunk :: ParsecT [Tok] s (StateT Enders m) Tok
chunk = (Text -> Bool) -> ParsecT [Tok] s (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
C.satisfyWord (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True) ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT [Tok] s (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'_' ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT [Tok] s (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'-'
    [Tok]
cts <- ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s. ParsecT [Tok] s (StateT Enders m) Tok
chunk
    Inlines -> InlineParser m Inlines
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> InlineParser m Inlines)
-> Inlines -> InlineParser m Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
singleI (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
EChannel (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ [Tok] -> Text
C.untokenize [Tok]
cts

-- Syntax extension for parsing @username references.
usernameSpec :: (Monad m) => C.SyntaxSpec m Inlines Blocks
usernameSpec :: SyntaxSpec m Inlines Blocks
usernameSpec =
    SyntaxSpec m Inlines Blocks
forall a. Monoid a => a
mempty { syntaxInlineParsers :: [InlineParser m Inlines]
C.syntaxInlineParsers = [InlineParser m Inlines -> InlineParser m Inlines
forall a (m :: * -> *).
(IsInline a, Monad m) =>
InlineParser m a -> InlineParser m a
C.withAttributes InlineParser m Inlines
forall (m :: * -> *). Monad m => InlineParser m Inlines
parseUsername]
           }

parseUsername :: (Monad m) => C.InlineParser m Inlines
parseUsername :: InlineParser m Inlines
parseUsername = InlineParser m Inlines -> InlineParser m Inlines
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (InlineParser m Inlines -> InlineParser m Inlines)
-> InlineParser m Inlines -> InlineParser m Inlines
forall a b. (a -> b) -> a -> b
$ do
    ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) ())
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
userSigilChar
    let chunk :: ParsecT [Tok] s (StateT Enders m) Tok
chunk = (Text -> Bool) -> ParsecT [Tok] s (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
C.satisfyWord (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True) ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT [Tok] s (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'_' ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
-> ParsecT [Tok] s (StateT Enders m) Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT [Tok] s (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'-'
        period :: Tok
period = case String -> Text -> [Tok]
C.tokenize String
"" Text
"." of
            [Tok
p] -> Tok
p
            [Tok]
_ -> String -> Tok
forall a. HasCallStack => String -> a
error String
"BUG: parseUsername: failed to tokenize basic input"
    [Tok]
uts <- Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
intersperse Tok
period ([Tok] -> [Tok])
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        Tok
c <- ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s. ParsecT [Tok] s (StateT Enders m) Tok
chunk
        [Tok]
rest <- ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok])
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall a b. (a -> b) -> a -> b
$ ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok)
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall a b. (a -> b) -> a -> b
$ do
            ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) ())
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'.'
            ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s. ParsecT [Tok] s (StateT Enders m) Tok
chunk
        [Tok] -> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tok] -> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok])
-> [Tok] -> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall a b. (a -> b) -> a -> b
$ Tok
c Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
: [Tok]
rest
    Inlines -> InlineParser m Inlines
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> InlineParser m Inlines)
-> Inlines -> InlineParser m Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
singleI (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
EUser (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ [Tok] -> Text
C.untokenize [Tok]
uts

-- Syntax extension for parsing :emoji: references.
--
-- NOTE: the commonmark-extensions package also provides a syntax
-- extension for exactly this. Why don't we use it? I'm glad you asked.
-- We don't use it because that extension actually checks to see whether
-- emoji are valid by looking in a database (provided by the 'emojis'
-- package). While that's actually a great feature, it is problematic
-- when that package's emoji database does not exactly match the one
-- that the Mattermost server uses. As a result, Matterhorn may think
-- that some valid emoji (according to the server) is invalid (according
-- to the 'emojis' package). Instead of using that extension, we made
-- our own that does *not* validate the emoji references at parse time.
-- We just parse them and keep them around, and then validate them at
-- *render* time. That way we can allow anything to parse, but change
-- how we render valid and invalid emoji based on a copy of the server's
-- emoji database that we bundle with Matterhorn.
emojiSpec :: (Monad m) => C.SyntaxSpec m Inlines Blocks
emojiSpec :: SyntaxSpec m Inlines Blocks
emojiSpec =
    SyntaxSpec m Inlines Blocks
forall a. Monoid a => a
mempty { syntaxInlineParsers :: [InlineParser m Inlines]
C.syntaxInlineParsers = [InlineParser m Inlines -> InlineParser m Inlines
forall a (m :: * -> *).
(IsInline a, Monad m) =>
InlineParser m a -> InlineParser m a
C.withAttributes InlineParser m Inlines
forall (m :: * -> *). Monad m => InlineParser m Inlines
parseEmoji]
           }

parseEmoji :: (Monad m) => C.InlineParser m Inlines
parseEmoji :: InlineParser m Inlines
parseEmoji = InlineParser m Inlines -> InlineParser m Inlines
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (InlineParser m Inlines -> InlineParser m Inlines)
-> InlineParser m Inlines -> InlineParser m Inlines
forall a b. (a -> b) -> a -> b
$ do
    ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) ())
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
':'
    [Tok]
ts <- ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok])
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
C.satisfyWord (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True)
               ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'_'
               ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'+'
               ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
'-'
    ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) ())
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
C.symbol Char
':'
    let kw :: Text
kw = [Tok] -> Text
C.untokenize [Tok]
ts
    Inlines -> InlineParser m Inlines
forall (m :: * -> *) a. Monad m => a -> m a
return (Inlines -> InlineParser m Inlines)
-> Inlines -> InlineParser m Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
singleI (Inline -> Inlines) -> Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inline
EEmoji Text
kw

-- A dummy instance just to satisfy commonmark; we don't use this.
instance C.HasAttributes Blocks where
    addAttributes :: Attributes -> Blocks -> Blocks
addAttributes Attributes
_ = Blocks -> Blocks
forall a. a -> a
id

-- A dummy instance just to satisfy commonmark; we don't use this.
instance C.Rangeable Blocks where
    ranged :: SourceRange -> Blocks -> Blocks
ranged SourceRange
_ = Blocks -> Blocks
forall a. a -> a
id

instance C.IsBlock Inlines Blocks where
    paragraph :: Inlines -> Blocks
paragraph = Block -> Blocks
singleB (Block -> Blocks) -> (Inlines -> Block) -> Inlines -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Block
Para
    plain :: Inlines -> Blocks
plain = Block -> Blocks
singleB (Block -> Blocks) -> (Inlines -> Block) -> Inlines -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Block
Para
    thematicBreak :: Blocks
thematicBreak = Block -> Blocks
singleB Block
HRule
    blockQuote :: Blocks -> Blocks
blockQuote = Block -> Blocks
singleB (Block -> Blocks) -> (Blocks -> Block) -> Blocks -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> Block
Blockquote
    codeBlock :: Text -> Text -> Blocks
codeBlock Text
infoTxt Text
content = Block -> Blocks
singleB (Block -> Blocks) -> Block -> Blocks
forall a b. (a -> b) -> a -> b
$ CodeBlockInfo -> Text -> Block
CodeBlock (Text -> CodeBlockInfo
parseCodeBlockInfo Text
infoTxt) Text
content
    heading :: Int -> Inlines -> Blocks
heading Int
level Inlines
i = Block -> Blocks
singleB (Block -> Blocks) -> Block -> Blocks
forall a b. (a -> b) -> a -> b
$ Int -> Inlines -> Block
Header Int
level Inlines
i
    rawBlock :: Format -> Text -> Blocks
rawBlock Format
_format Text
content = Block -> Blocks
singleB (Block -> Blocks) -> Block -> Blocks
forall a b. (a -> b) -> a -> b
$ CodeBlockInfo -> Text -> Block
CodeBlock (Text -> CodeBlockInfo
parseCodeBlockInfo Text
"") Text
content
    list :: ListType -> ListSpacing -> [Blocks] -> Blocks
list ListType
ty ListSpacing
spacing [Blocks]
bs = Block -> Blocks
singleB (Block -> Blocks) -> Block -> Blocks
forall a b. (a -> b) -> a -> b
$ ListType -> ListSpacing -> Seq Blocks -> Block
List ListType
ty ListSpacing
spacing (Seq Blocks -> Block) -> Seq Blocks -> Block
forall a b. (a -> b) -> a -> b
$ [Blocks] -> Seq Blocks
forall a. [a] -> Seq a
Seq.fromList [Blocks]
bs
    referenceLinkDefinition :: Text -> (Text, Text) -> Blocks
referenceLinkDefinition Text
_label (Text
_dest, Text
_title) = Blocks
forall a. Monoid a => a
mempty

parseCodeBlockInfo :: Text -> CodeBlockInfo
parseCodeBlockInfo :: Text -> CodeBlockInfo
parseCodeBlockInfo Text
t = Maybe Text -> Maybe Text -> CodeBlockInfo
CodeBlockInfo Maybe Text
lang Maybe Text
info
    where
        ws :: [Text]
ws = Text -> [Text]
T.words Text
t
        (Maybe Text
lang, Maybe Text
info) = case [Text]
ws of
            [Text
l, Text
i] -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
l, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
i)
            [Text
l]    -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
l, Maybe Text
forall a. Maybe a
Nothing)
            [Text]
_      -> (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)

-- | Parse markdown input text to RichText.
--
-- Note that this always returns a block sequence even if the input
-- cannot be parsed. It isn't yet clear just how permissive the
-- commonmark parser is, but so far we have not encountered any issues.
-- If the input document is so broken that commonmark cannot parse it,
-- we return an empty block sequence.
parseMarkdown :: Maybe TeamBaseURL
              -- ^ If provided, perform post link detection whenever a
              -- hyperlink is parsed by checking to see if the post link
              -- is a post in this Mattermost team
              -> T.Text
              -- ^ The markdown input text to parse
              -> Blocks
parseMarkdown :: Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown Maybe TeamBaseURL
mBaseUrl Text
t =
    let customSyntax :: SyntaxSpec Identity Inlines Blocks
customSyntax = [SyntaxSpec Identity Inlines Blocks]
-> SyntaxSpec Identity Inlines Blocks
forall a. Monoid a => [a] -> a
mconcat ([SyntaxSpec Identity Inlines Blocks]
 -> SyntaxSpec Identity Inlines Blocks)
-> [SyntaxSpec Identity Inlines Blocks]
-> SyntaxSpec Identity Inlines Blocks
forall a b. (a -> b) -> a -> b
$ [SyntaxSpec Identity Inlines Blocks]
markdownExtensions [SyntaxSpec Identity Inlines Blocks]
-> [SyntaxSpec Identity Inlines Blocks]
-> [SyntaxSpec Identity Inlines Blocks]
forall a. Semigroup a => a -> a -> a
<> [SyntaxSpec Identity Inlines Blocks
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
C.defaultSyntaxSpec]
        markdownExtensions :: [SyntaxSpec Identity Inlines Blocks]
markdownExtensions =
            [ SyntaxSpec Identity Inlines Blocks
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
C.autolinkSpec
            , SyntaxSpec Identity Inlines Blocks
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasStrikethrough il) =>
SyntaxSpec m il bl
C.strikethroughSpec
            , SyntaxSpec Identity Inlines Blocks
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasPipeTable il bl) =>
SyntaxSpec m il bl
C.pipeTableSpec
            , SyntaxSpec Identity Inlines Blocks
forall (m :: * -> *). Monad m => SyntaxSpec m Inlines Blocks
usernameSpec
            , SyntaxSpec Identity Inlines Blocks
forall (m :: * -> *). Monad m => SyntaxSpec m Inlines Blocks
channelSpec
            , SyntaxSpec Identity Inlines Blocks
forall (m :: * -> *). Monad m => SyntaxSpec m Inlines Blocks
emojiSpec
            ]

    in case Identity (Either ParseError Blocks) -> Either ParseError Blocks
forall a. Identity a -> a
runIdentity (Identity (Either ParseError Blocks) -> Either ParseError Blocks)
-> Identity (Either ParseError Blocks) -> Either ParseError Blocks
forall a b. (a -> b) -> a -> b
$ SyntaxSpec Identity Inlines Blocks
-> String -> Text -> Identity (Either ParseError Blocks)
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl -> String -> Text -> m (Either ParseError bl)
C.commonmarkWith SyntaxSpec Identity Inlines Blocks
customSyntax String
"-" Text
t of
        Left ParseError
_ -> Blocks
forall a. Monoid a => a
mempty
        Right Blocks
bs -> case Maybe TeamBaseURL
mBaseUrl of
            Maybe TeamBaseURL
Nothing -> Blocks
bs
            Just TeamBaseURL
baseUrl -> TeamBaseURL -> Blocks -> Blocks
rewriteBlocksPermalinks TeamBaseURL
baseUrl Blocks
bs

makePermalink :: TeamBaseURL -> PostId -> Text
makePermalink :: TeamBaseURL -> PostId -> Text
makePermalink (TeamBaseURL (TeamURLName Text
tName) (ServerBaseURL Text
baseUrl)) PostId
pId =
    Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/pl/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id -> Text
unId (PostId -> Id
unPI PostId
pId)

-- | If the specified URL matches the active server base URL and team
-- and refers to a post, extract the team name and post ID values and
-- return them.
getPermalink :: TeamBaseURL -> Text -> Maybe (TeamURLName, PostId)
getPermalink :: TeamBaseURL -> Text -> Maybe (TeamURLName, PostId)
getPermalink (TeamBaseURL TeamURLName
tName (ServerBaseURL Text
baseUrl)) Text
url =
    let newBaseUrl :: Text
newBaseUrl = if Text
"/" Text -> Text -> Bool
`T.isSuffixOf` Text
baseUrl
                     then Text
baseUrl
                     else Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
    in if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
newBaseUrl Text -> Text -> Bool
`T.isPrefixOf` Text
url
       then Maybe (TeamURLName, PostId)
forall a. Maybe a
Nothing
       else let rest :: Text
rest = Int -> Text -> Text
T.drop (Text -> Int
T.length Text
newBaseUrl) Text
url
                (Text
tName', Text
rawPIdStr) = Text -> Text -> (Text, Text)
T.breakOn Text
"/pl/" Text
rest
                pIdStr :: Text
pIdStr = Int -> Text -> Text
T.drop Int
4 Text
rawPIdStr
            in if TeamURLName
tName TeamURLName -> TeamURLName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> TeamURLName
TeamURLName Text
tName' Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null Text
pIdStr)
               then (TeamURLName, PostId) -> Maybe (TeamURLName, PostId)
forall a. a -> Maybe a
Just (TeamURLName
tName, Id -> PostId
PI (Id -> PostId) -> Id -> PostId
forall a b. (a -> b) -> a -> b
$ Text -> Id
Id Text
pIdStr)
               else Maybe (TeamURLName, PostId)
forall a. Maybe a
Nothing

-- | Locate post hyperlinks in the block sequence and rewrite them as
-- post permalinks.
rewriteBlocksPermalinks :: TeamBaseURL -> Blocks -> Blocks
rewriteBlocksPermalinks :: TeamBaseURL -> Blocks -> Blocks
rewriteBlocksPermalinks TeamBaseURL
u (Blocks Seq Block
bs) = Seq Block -> Blocks
Blocks (Seq Block -> Blocks) -> Seq Block -> Blocks
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Block -> Block
rewriteBlockPermalinks TeamBaseURL
u (Block -> Block) -> Seq Block -> Seq Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Block
bs

-- | Locate post hyperlinks in the block and rewrite them as post
-- permalinks.
rewriteBlockPermalinks :: TeamBaseURL -> Block -> Block
rewriteBlockPermalinks :: TeamBaseURL -> Block -> Block
rewriteBlockPermalinks TeamBaseURL
u (Table [ColAlignment]
a [Inlines]
h [[Inlines]]
b) = [ColAlignment] -> [Inlines] -> [[Inlines]] -> Block
Table [ColAlignment]
a (TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u (Inlines -> Inlines) -> [Inlines] -> [Inlines]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inlines]
h)
                                                 (([Inlines] -> [Inlines]) -> [[Inlines]] -> [[Inlines]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Inlines -> Inlines) -> [Inlines] -> [Inlines]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u)) [[Inlines]]
b)
rewriteBlockPermalinks TeamBaseURL
u (Para Inlines
s) = Inlines -> Block
Para (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u Inlines
s
rewriteBlockPermalinks TeamBaseURL
u (Header Int
i Inlines
s) = Int -> Inlines -> Block
Header Int
i (Inlines -> Block) -> Inlines -> Block
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u Inlines
s
rewriteBlockPermalinks TeamBaseURL
u (Blockquote Blocks
bs) = Blocks -> Block
Blockquote (Blocks -> Block) -> Blocks -> Block
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Blocks -> Blocks
rewriteBlocksPermalinks TeamBaseURL
u Blocks
bs
rewriteBlockPermalinks TeamBaseURL
u (List ListType
ty ListSpacing
spacing Seq Blocks
bss) = ListType -> ListSpacing -> Seq Blocks -> Block
List ListType
ty ListSpacing
spacing (Seq Blocks -> Block) -> Seq Blocks -> Block
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Blocks -> Blocks
rewriteBlocksPermalinks TeamBaseURL
u (Blocks -> Blocks) -> Seq Blocks -> Seq Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Blocks
bss
rewriteBlockPermalinks TeamBaseURL
_ b :: Block
b@(CodeBlock {}) = Block
b
rewriteBlockPermalinks TeamBaseURL
_ b :: Block
b@(HTMLBlock {}) = Block
b
rewriteBlockPermalinks TeamBaseURL
_ b :: Block
b@Block
HRule = Block
b

-- | Locate post hyperlinks in the inline sequence and rewrite them as
-- post permalinks.
rewriteInlinePermalinks :: TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks :: TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u (Inlines Seq Inline
is) = Seq Inline -> Inlines
Inlines (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inline -> Inline
rewriteInlinePermalink TeamBaseURL
u (Inline -> Inline) -> Seq Inline -> Seq Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Inline
is

-- | Locate post hyperlinks in the inline value and rewrite them as post
-- permalinks.
rewriteInlinePermalink :: TeamBaseURL -> Inline -> Inline
rewriteInlinePermalink :: TeamBaseURL -> Inline -> Inline
rewriteInlinePermalink TeamBaseURL
u i :: Inline
i@(EHyperlink URL
url Inlines
label) =
    case TeamBaseURL -> Text -> Maybe (TeamURLName, PostId)
getPermalink TeamBaseURL
u (URL -> Text
unURL URL
url) of
        Maybe (TeamURLName, PostId)
Nothing -> Inline
i
        Just (TeamURLName
tName, PostId
pId) ->
            -- Get rid of permalink labels if they just match the URL,
            -- because that's how Commonmark-extensions parses them. We
            -- would rather only preserve the label if it differs from
            -- the URL.
            let newLabel :: Maybe Inlines
newLabel = if Inlines
label Inlines -> Inlines -> Bool
forall a. Eq a => a -> a -> Bool
== Seq Inline -> Inlines
Inlines ([Inline] -> Seq Inline
forall a. [a] -> Seq a
Seq.fromList [Text -> Inline
EText (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ URL -> Text
unURL URL
url])
                           then Maybe Inlines
forall a. Maybe a
Nothing
                           else Inlines -> Maybe Inlines
forall a. a -> Maybe a
Just Inlines
label
            in TeamURLName -> PostId -> Maybe Inlines -> Inline
EPermalink TeamURLName
tName PostId
pId Maybe Inlines
newLabel
rewriteInlinePermalink TeamBaseURL
u (EEmph Inlines
s) = Inlines -> Inline
EEmph (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u Inlines
s
rewriteInlinePermalink TeamBaseURL
u (ECode Inlines
s) = Inlines -> Inline
ECode (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u Inlines
s
rewriteInlinePermalink TeamBaseURL
u (EStrikethrough Inlines
s) = Inlines -> Inline
EStrikethrough (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u Inlines
s
rewriteInlinePermalink TeamBaseURL
u (EStrong Inlines
s) = Inlines -> Inline
EStrong (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u Inlines
s
rewriteInlinePermalink TeamBaseURL
u (ENonBreaking Inlines
s) = Inlines -> Inline
ENonBreaking (Inlines -> Inline) -> Inlines -> Inline
forall a b. (a -> b) -> a -> b
$ TeamBaseURL -> Inlines -> Inlines
rewriteInlinePermalinks TeamBaseURL
u Inlines
s
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(EText {}) = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@Inline
ESpace = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@Inline
ESoftBreak = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@Inline
ELineBreak = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(EEditSentinel {}) = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(ERawHtml {}) = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(EEmoji {}) = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(EUser {}) = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(EChannel {}) = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(EImage {}) = Inline
i
rewriteInlinePermalink TeamBaseURL
_ i :: Inline
i@(EPermalink {}) = Inline
i

-- | Obtain all username references in a rich text document.
findUsernames :: Blocks -> S.Set T.Text
findUsernames :: Blocks -> Set Text
findUsernames (Blocks Seq Block
bs) = [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Text] -> Set Text) -> [Set Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ Seq (Set Text) -> [Set Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Set Text) -> [Set Text]) -> Seq (Set Text) -> [Set Text]
forall a b. (a -> b) -> a -> b
$ (Block -> Set Text) -> Seq Block -> Seq (Set Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block -> Set Text
blockFindUsernames Seq Block
bs

blockFindUsernames :: Block -> S.Set T.Text
blockFindUsernames :: Block -> Set Text
blockFindUsernames (Para Inlines
is) =
    [Inline] -> Set Text
inlineFindUsernames ([Inline] -> Set Text) -> [Inline] -> Set Text
forall a b. (a -> b) -> a -> b
$ Seq Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Inline -> [Inline]) -> Seq Inline -> [Inline]
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
unInlines Inlines
is
blockFindUsernames (Header Int
_ Inlines
is) =
    [Inline] -> Set Text
inlineFindUsernames ([Inline] -> Set Text) -> [Inline] -> Set Text
forall a b. (a -> b) -> a -> b
$ Seq Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Inline -> [Inline]) -> Seq Inline -> [Inline]
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
unInlines Inlines
is
blockFindUsernames (Blockquote Blocks
bs) =
    Blocks -> Set Text
findUsernames Blocks
bs
blockFindUsernames (Table [ColAlignment]
_ [Inlines]
header [[Inlines]]
rows) =
    let cellFindUsernames :: Inlines -> Set Text
cellFindUsernames = [Inline] -> Set Text
inlineFindUsernames ([Inline] -> Set Text)
-> (Inlines -> [Inline]) -> Inlines -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Inline -> [Inline])
-> (Inlines -> Seq Inline) -> Inlines -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Seq Inline
unInlines
    in [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Text] -> Set Text) -> [Set Text] -> Set Text
forall a b. (a -> b) -> a -> b
$
       ((Inlines -> Set Text
cellFindUsernames (Inlines -> Set Text) -> [Inlines] -> [Set Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inlines]
header) [Set Text] -> [Set Text] -> [Set Text]
forall a. Semigroup a => a -> a -> a
<>
        ([[Set Text]] -> [Set Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Set Text]] -> [Set Text]) -> [[Set Text]] -> [Set Text]
forall a b. (a -> b) -> a -> b
$ ((Inlines -> Set Text) -> [Inlines] -> [Set Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Inlines -> Set Text
cellFindUsernames) ([Inlines] -> [Set Text]) -> [[Inlines]] -> [[Set Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Inlines]]
rows))
blockFindUsernames (List ListType
_ ListSpacing
_ Seq Blocks
bs) =
    [Set Text] -> Set Text
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set Text] -> Set Text) -> [Set Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ Seq (Set Text) -> [Set Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Set Text) -> [Set Text]) -> Seq (Set Text) -> [Set Text]
forall a b. (a -> b) -> a -> b
$ Blocks -> Set Text
findUsernames (Blocks -> Set Text) -> Seq Blocks -> Seq (Set Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Blocks
bs
blockFindUsernames Block
HRule =
    Set Text
forall a. Monoid a => a
mempty
blockFindUsernames (HTMLBlock {}) =
    Set Text
forall a. Monoid a => a
mempty
blockFindUsernames (CodeBlock {}) =
    Set Text
forall a. Monoid a => a
mempty

inlineFindUsernames :: [Inline] -> S.Set T.Text
inlineFindUsernames :: [Inline] -> Set Text
inlineFindUsernames [] = Set Text
forall a. Monoid a => a
mempty
inlineFindUsernames (Inline
i : [Inline]
is) =
    case Inline
i of
        EUser Text
u -> Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert Text
u (Set Text -> Set Text) -> Set Text -> Set Text
forall a b. (a -> b) -> a -> b
$ [Inline] -> Set Text
inlineFindUsernames [Inline]
is
        Inline
_ -> [Inline] -> Set Text
inlineFindUsernames [Inline]
is

-- | Obtain all URLs (and optional labels) in a rich text block.
blockGetURLs :: Block -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
blockGetURLs :: Block -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
blockGetURLs (Para Inlines
is) =
    [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
 -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a b. (a -> b) -> a -> b
$ Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
elementGetURL (Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines))
-> [Inline]
-> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Seq Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Inline -> [Inline]) -> Seq Inline -> [Inline]
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
unInlines Inlines
is)
blockGetURLs (Header Int
_ Inlines
is) =
    [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
 -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a b. (a -> b) -> a -> b
$ Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
elementGetURL (Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines))
-> [Inline]
-> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Seq Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Inline -> [Inline]) -> Seq Inline -> [Inline]
forall a b. (a -> b) -> a -> b
$ Inlines -> Seq Inline
unInlines Inlines
is)
blockGetURLs (Blockquote Blocks
bs) =
    [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. Monoid a => [a] -> a
mconcat ([[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
 -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a b. (a -> b) -> a -> b
$ Block -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
blockGetURLs (Block -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [Block] -> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Block -> [Block]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Blocks -> Seq Block
unBlocks Blocks
bs)
blockGetURLs (List ListType
_ ListSpacing
_ Seq Blocks
bss) =
    [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. Monoid a => [a] -> a
mconcat ([[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
 -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a b. (a -> b) -> a -> b
$ [[[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]]
-> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
forall a. Monoid a => [a] -> a
mconcat ([[[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]]
 -> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]])
-> [[[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]]
-> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
forall a b. (a -> b) -> a -> b
$
    ((Block -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [Block] -> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
blockGetURLs ([Block] -> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]])
-> (Blocks -> [Block])
-> Blocks
-> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Block -> [Block]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Block -> [Block])
-> (Blocks -> Seq Block) -> Blocks -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> Seq Block
unBlocks) (Blocks -> [[(Either (TeamURLName, PostId) URL, Maybe Inlines)]])
-> [Blocks]
-> [[[(Either (TeamURLName, PostId) URL, Maybe Inlines)]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Blocks -> [Blocks]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Blocks
bss
blockGetURLs (Table [ColAlignment]
_ [Inlines]
header [[Inlines]]
rows) =
    let cellFindURLs :: Inlines -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
cellFindURLs = [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
 -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> (Inlines
    -> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> Inlines
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines))
-> [Inline]
-> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
elementGetURL ([Inline]
 -> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> (Inlines -> [Inline])
-> Inlines
-> [Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Inline -> [Inline]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq Inline -> [Inline])
-> (Inlines -> Seq Inline) -> Inlines -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Seq Inline
unInlines
    in ((Inlines -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [Inlines] -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Inlines -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
cellFindURLs [Inlines]
header) [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. Semigroup a => a -> a -> a
<>
       (([Inlines] -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [[Inlines]]
-> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Inlines -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)])
-> [Inlines] -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Inlines -> [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
cellFindURLs) [[Inlines]]
rows)
blockGetURLs Block
HRule =
    [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. Monoid a => a
mempty
blockGetURLs (HTMLBlock {}) =
    [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. Monoid a => a
mempty
blockGetURLs (CodeBlock {}) =
    [(Either (TeamURLName, PostId) URL, Maybe Inlines)]
forall a. Monoid a => a
mempty

elementGetURL :: Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
elementGetURL :: Inline -> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
elementGetURL (EHyperlink URL
url Inlines
label) =
    (Either (TeamURLName, PostId) URL, Maybe Inlines)
-> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
forall a. a -> Maybe a
Just (URL -> Either (TeamURLName, PostId) URL
forall a b. b -> Either a b
Right URL
url, Inlines -> Maybe Inlines
forall a. a -> Maybe a
Just Inlines
label)
elementGetURL (EImage URL
url Inlines
label) =
    (Either (TeamURLName, PostId) URL, Maybe Inlines)
-> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
forall a. a -> Maybe a
Just (URL -> Either (TeamURLName, PostId) URL
forall a b. b -> Either a b
Right URL
url, Inlines -> Maybe Inlines
forall a. a -> Maybe a
Just Inlines
label)
elementGetURL (EPermalink TeamURLName
tName PostId
pId Maybe Inlines
label) =
    (Either (TeamURLName, PostId) URL, Maybe Inlines)
-> Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
forall a. a -> Maybe a
Just ((TeamURLName, PostId) -> Either (TeamURLName, PostId) URL
forall a b. a -> Either a b
Left (TeamURLName
tName, PostId
pId), Maybe Inlines
label)
elementGetURL Inline
_ =
    Maybe (Either (TeamURLName, PostId) URL, Maybe Inlines)
forall a. Maybe a
Nothing

-- | Find the first code block in a sequence of rich text blocks.
findVerbatimChunk :: Blocks -> Maybe Text
findVerbatimChunk :: Blocks -> Maybe Text
findVerbatimChunk (Blocks Seq Block
bs) = First Text -> Maybe Text
forall a. First a -> Maybe a
getFirst (First Text -> Maybe Text) -> First Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Block -> First Text) -> Seq Block -> First Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Block -> First Text
go Seq Block
bs
  where go :: Block -> First Text
go (CodeBlock CodeBlockInfo
_ Text
t) = Maybe Text -> First Text
forall a. Maybe a -> First a
First (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t)
        go Block
_               = Maybe Text -> First Text
forall a. Maybe a -> First a
First Maybe Text
forall a. Maybe a
Nothing