{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Text.Jira.Printer
( pretty
, renderBlock
, renderInline
, prettyBlocks
, prettyInlines
, JiraPrinter
, PrinterState (..)
, startState
, withDefault
) where
import Data.Char (isAlphaNum)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Control.Monad ((<=<))
import Control.Monad.Reader (Reader, runReader, asks, local)
import Data.Text (Text)
import Text.Jira.Markup
import qualified Data.Text as T
pretty :: Doc -> Text
pretty :: Doc -> Text
pretty (Doc [Block]
blks) = [Block] -> Text
prettyBlocks [Block]
blks
prettyBlocks :: [Block] -> Text
prettyBlocks :: [Block] -> Text
prettyBlocks [Block]
blks = forall r a. Reader r a -> r -> a
runReader ([Block] -> JiraPrinter Text
renderBlocks [Block]
blks) PrinterState
startState
prettyInlines :: [Inline] -> Text
prettyInlines :: [Inline] -> Text
prettyInlines = \case
[] ->
Text
""
s :: Inline
s@Str{} : Styled InlineStyle
style [Inline]
inlns : [Inline]
rest ->
Inline -> Text
renderInline Inline
s forall a. Semigroup a => a -> a -> a
<> InlineStyle -> [Inline] -> Text
renderStyledSafely InlineStyle
style [Inline]
inlns forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
rest
Styled InlineStyle
style [Inline]
inlns : s :: Inline
s@(Str Text
t) : [Inline]
rest | Text -> Bool
startsWithAlphaNum Text
t ->
InlineStyle -> [Inline] -> Text
renderStyledSafely InlineStyle
style [Inline]
inlns forall a. Semigroup a => a -> a -> a
<> Inline -> Text
renderInline Inline
s forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
rest
s :: Inline
s@Str{} : SpecialChar Char
c : rest :: [Inline]
rest@(Str {}:[Inline]
_) | Bool -> Bool
not (Char -> Bool
isBrace Char
c) ->
(Inline -> Text
renderInline Inline
s Text -> Char -> Text
`T.snoc` Char
c) forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
rest
s :: Inline
s@Inline
Space : SpecialChar Char
c : rest :: [Inline]
rest@(Space {}:[Inline]
_) | Bool -> Bool
not (Char -> Bool
isBrace Char
c) ->
(Inline -> Text
renderInline Inline
s Text -> Char -> Text
`T.snoc` Char
c) forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
rest
s :: Inline
s@Inline
Linebreak : SpecialChar Char
c : rest :: [Inline]
rest@(Space {}:[Inline]
_) | Bool -> Bool
not (Char -> Bool
isBrace Char
c) ->
(Inline -> Text
renderInline Inline
s Text -> Char -> Text
`T.snoc` Char
c) forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
rest
SpecialChar Char
c : rest :: [Inline]
rest@(Inline
x : [Inline]
_) | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
':', Char
';'] Bool -> Bool -> Bool
&& Bool -> Bool
not (Inline -> Bool
isSmileyStr Inline
x) ->
Char -> Text
T.singleton Char
c forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
rest
[SpecialChar Char
c] | Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
':', Char
';'] ->
Char -> Text
T.singleton Char
c
SpecialChar Char
'?' : [Inline]
rest | Bool -> Bool
not ([Inline] -> Bool
startsWithQuestionMark [Inline]
rest) ->
Text
"?" forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
rest
(Inline
x:[Inline]
xs) ->
Inline -> Text
renderInline Inline
x forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
xs
where
isBrace :: Char -> Bool
isBrace = \case
Char
'{' -> Bool
True
Char
'}' -> Bool
True
Char
_ -> Bool
False
startsWithAlphaNum :: Text -> Bool
startsWithAlphaNum Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
Just (Char
c, Text
_) -> Char -> Bool
isAlphaNum Char
c
Maybe (Char, Text)
_ -> Bool
False
isSmileyStr :: Inline -> Bool
isSmileyStr = \case
Str Text
x | Text
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"D", Text
")", Text
"(", Text
"P"] -> Bool
True
Inline
_ -> Bool
False
startsWithQuestionMark :: [Inline] -> Bool
startsWithQuestionMark = \case
SpecialChar Char
'?' : [Inline]
_ -> Bool
True
[Inline]
_ -> Bool
False
data PrinterState = PrinterState
{ PrinterState -> Bool
stateInTable :: Bool
, PrinterState -> Text
stateListLevel :: Text
}
type JiraPrinter a = Reader PrinterState a
withDefault :: JiraPrinter a -> a
withDefault :: forall a. JiraPrinter a -> a
withDefault = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader PrinterState
startState
startState :: PrinterState
startState :: PrinterState
startState = PrinterState
{ stateInTable :: Bool
stateInTable = Bool
False
, stateListLevel :: Text
stateListLevel = Text
""
}
renderBlocks :: [Block] -> JiraPrinter Text
renderBlocks :: [Block] -> JiraPrinter Text
renderBlocks = [Text] -> JiraPrinter Text
concatBlocks forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block -> JiraPrinter Text
renderBlock
concatBlocks :: [Text] -> JiraPrinter Text
concatBlocks :: [Text] -> JiraPrinter Text
concatBlocks = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"\n"
appendNewline :: Text -> JiraPrinter Text
appendNewline :: Text -> JiraPrinter Text
appendNewline Text
text = do
Text
listLevel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrinterState -> Text
stateListLevel
Bool
inTable <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrinterState -> Bool
stateInTable
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if Bool
inTable Bool -> Bool -> Bool
|| Bool -> Bool
not (Text -> Bool
T.null Text
listLevel)
then Text
text
else Text
text forall a. Semigroup a => a -> a -> a
<> Text
"\n"
renderBlock :: Block -> JiraPrinter Text
renderBlock :: Block -> JiraPrinter Text
renderBlock = \case
Code Language
lang [Parameter]
params Text
content -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"{code:"
, Text -> [Text] -> Text
T.intercalate Text
"|"
(Language -> Text
renderLang Language
lang forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Text
renderParam [Parameter]
params)
, Text
"}\n"
, Text
content
, Text
"\n{code}"
]
Color ColorName
colorName [Block]
blocks -> [Block] -> JiraPrinter Text
renderBlocks [Block]
blocks forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
blks -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"{color:", ColorName -> Text
colorText ColorName
colorName, Text
"}\n"
, Text
blks
, Text
"{color}"
]
BlockQuote [Para [Inline]
xs] | Inline
Linebreak forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Inline]
xs
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"bq. " forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
xs
BlockQuote [Block]
blocks -> [Block] -> JiraPrinter Text
renderBlocks [Block]
blocks forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
blks -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"{quote}\n"
, Text
blks
, Text
"{quote}"]
Header Int
lvl [Inline]
inlines -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"h", [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int
lvl), Text
". "
, [Inline] -> Text
prettyInlines [Inline]
inlines
]
Block
HorizontalRule -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"----"
List ListStyle
style [[Block]]
items -> [[Block]] -> Char -> JiraPrinter Text
listWithMarker [[Block]]
items (ListStyle -> Char
styleChar ListStyle
style) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Text -> JiraPrinter Text
appendNewline
NoFormat [Parameter]
params Text
content -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"{noformat"
, [Parameter] -> Text
renderBlockParams [Parameter]
params
, Text
"}\n"
, Text
content
, Text
"{noformat}"
]
Panel [Parameter]
params [Block]
blocks -> [Block] -> JiraPrinter Text
renderBlocks [Block]
blocks forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
blks ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"{panel"
, [Parameter] -> Text
renderBlockParams [Parameter]
params
, Text
"}\n"
, Text
blks
, Text
"{panel}"
]
Para [Inline]
inlines -> Text -> JiraPrinter Text
appendNewline forall a b. (a -> b) -> a -> b
$ [Inline] -> Text
prettyInlines [Inline]
inlines
Table [Row]
rows ->
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\PrinterState
st -> PrinterState
st { stateInTable :: Bool
stateInTable = Bool
True }) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Text
T.unlines (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Row -> JiraPrinter Text
renderRow [Row]
rows)
colorText :: ColorName -> Text
colorText :: ColorName -> Text
colorText (ColorName Text
c) = Text
c
renderLang :: Language -> Text
renderLang :: Language -> Text
renderLang (Language Text
lang) = Text
lang
renderBlockParams :: [Parameter] -> Text
renderBlockParams :: [Parameter] -> Text
renderBlockParams = \case
[] -> forall a. Monoid a => a
mempty
[Parameter]
xs -> Char -> Text -> Text
T.cons Char
':' ([Parameter] -> Text
renderParams [Parameter]
xs)
renderParams :: [Parameter] -> Text
renderParams :: [Parameter] -> Text
renderParams = Text -> [Text] -> Text
T.intercalate Text
"|" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Text
renderParam
renderParam :: Parameter -> Text
renderParam :: Parameter -> Text
renderParam (Parameter Text
key Text
value) = Text
key forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
value
renderRow :: Row -> JiraPrinter Text
renderRow :: Row -> JiraPrinter Text
renderRow (Row [Cell]
cells) = do
[Text]
rendered <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Cell -> JiraPrinter Text
renderCell [Cell]
cells
let closing :: Text
closing = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Cell -> Bool
isHeaderCell [Cell]
cells then Text
" ||" else Text
" |"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text]
rendered forall a. Semigroup a => a -> a -> a
<> Text
closing
where
isHeaderCell :: Cell -> Bool
isHeaderCell HeaderCell {} = Bool
True
isHeaderCell BodyCell {} = Bool
False
renderCell :: Cell -> JiraPrinter Text
renderCell :: Cell -> JiraPrinter Text
renderCell Cell
cell = let (Text
cellStart, [Block]
blocks) = case Cell
cell of
(HeaderCell [Block]
bs) -> (Text
"|| ", [Block]
bs)
(BodyCell [Block]
bs) -> (Text
"| ", [Block]
bs)
in (Text
cellStart forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> JiraPrinter Text
renderBlocks [Block]
blocks
styleChar :: ListStyle -> Char
styleChar :: ListStyle -> Char
styleChar = \case
ListStyle
CircleBullets -> Char
'*'
ListStyle
SquareBullets -> Char
'-'
ListStyle
Enumeration -> Char
'#'
listWithMarker :: [[Block]]
-> Char
-> JiraPrinter Text
listWithMarker :: [[Block]] -> Char -> JiraPrinter Text
listWithMarker [[Block]]
items Char
marker = do
let addItem :: PrinterState -> PrinterState
addItem PrinterState
s = PrinterState
s { stateListLevel :: Text
stateListLevel = PrinterState -> Text
stateListLevel PrinterState
s Text -> Char -> Text
`T.snoc` Char
marker }
[Text]
renderedBlocks <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local PrinterState -> PrinterState
addItem forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Block] -> JiraPrinter Text
listItemToJira [[Block]]
items
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
renderedBlocks
listItemToJira :: [Block]
-> JiraPrinter Text
listItemToJira :: [Block] -> JiraPrinter Text
listItemToJira [Block]
items = do
Text
contents <- [Block] -> JiraPrinter Text
renderBlocks [Block]
items
Text
marker <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PrinterState -> Text
stateListLevel
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [Block]
items of
List{} : [Block]
_ -> Text
contents
[Block]
_ -> Text
marker forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
contents
renderInline :: Inline -> Text
renderInline :: Inline -> Text
renderInline = \case
Anchor Text
name -> Text
"{anchor:" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"}"
AutoLink URL
url -> URL -> Text
fromURL URL
url
Citation [Inline]
ils -> Text
"??" forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
ils forall a. Semigroup a => a -> a -> a
<> Text
"??"
ColorInline ColorName
color [Inline]
ils -> Text
"{color:" forall a. Semigroup a => a -> a -> a
<> ColorName -> Text
colorText ColorName
color forall a. Semigroup a => a -> a -> a
<> Text
"}" forall a. Semigroup a => a -> a -> a
<>
[Inline] -> Text
prettyInlines [Inline]
ils forall a. Semigroup a => a -> a -> a
<> Text
"{color}"
Emoji Icon
icon -> Icon -> Text
iconText Icon
icon
Entity Text
entity -> Text
"&" forall a. Semigroup a => a -> a -> a
<> Text
entity forall a. Semigroup a => a -> a -> a
<> Text
";"
Image [Parameter]
ps URL
url -> Text
"!" forall a. Semigroup a => a -> a -> a
<> URL -> Text
fromURL URL
url forall a. Semigroup a => a -> a -> a
<> [Parameter] -> Text
renderImageParams [Parameter]
ps forall a. Semigroup a => a -> a -> a
<> Text
"!"
Inline
Linebreak -> Text
"\n"
Link LinkType
lt [Inline]
ils URL
url -> LinkType -> [Inline] -> URL -> Text
renderLink LinkType
lt [Inline]
ils URL
url
Monospaced [Inline]
inlines -> Text
"{{" forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
inlines forall a. Semigroup a => a -> a -> a
<> Text
"}}"
Inline
Space -> Text
" "
SpecialChar Char
c -> case Char
c of
Char
'\\' -> Text
"\"
Char
_ -> Text
"\\" Text -> Char -> Text
`T.snoc` Char
c
Str Text
txt -> Text
txt
Styled InlineStyle
style [Inline]
inlines -> Char -> [Inline] -> Text
renderWrapped (InlineStyle -> Char
delimiterChar InlineStyle
style) [Inline]
inlines
renderStyledSafely :: InlineStyle -> [Inline] -> Text
renderStyledSafely :: InlineStyle -> [Inline] -> Text
renderStyledSafely InlineStyle
style =
let delim :: Text
delim = [Char] -> Text
T.pack [Char
'{', InlineStyle -> Char
delimiterChar InlineStyle
style, Char
'}']
in (Text
delim forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> Text
delim) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Text
prettyInlines
renderLink :: LinkType -> [Inline] -> URL -> Text
renderLink :: LinkType -> [Inline] -> URL -> Text
renderLink LinkType
linkType [Inline]
inlines URL
url = case LinkType
linkType of
LinkType
Attachment -> Text
"[" forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
inlines forall a. Semigroup a => a -> a -> a
<> Text
"^" forall a. Semigroup a => a -> a -> a
<> URL -> Text
fromURL URL
url forall a. Semigroup a => a -> a -> a
<> Text
"]"
LinkType
Email -> Text -> Text
link' forall a b. (a -> b) -> a -> b
$ Text
"mailto:" forall a. Semigroup a => a -> a -> a
<> URL -> Text
fromURL URL
url
LinkType
External -> Text -> Text
link' forall a b. (a -> b) -> a -> b
$ URL -> Text
fromURL URL
url
LinkType
SmartCard -> Text -> Text -> Text
smartLink (URL -> Text
fromURL URL
url) Text
"smart-card"
LinkType
SmartLink -> Text -> Text -> Text
smartLink (URL -> Text
fromURL URL
url) Text
"smart-link"
LinkType
User -> Text -> Text
link' forall a b. (a -> b) -> a -> b
$ Text
"~" forall a. Semigroup a => a -> a -> a
<> URL -> Text
fromURL URL
url
where
link' :: Text -> Text
link' Text
urlText = case [Inline]
inlines of
[] -> Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
urlText forall a. Semigroup a => a -> a -> a
<> Text
"]"
[Inline]
_ -> Text
"[" forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
inlines forall a. Semigroup a => a -> a -> a
<> Text
"|" forall a. Semigroup a => a -> a -> a
<> Text
urlText forall a. Semigroup a => a -> a -> a
<> Text
"]"
smartLink :: Text -> Text -> Text
smartLink Text
urlText Text
smartType =
Text
"[" forall a. Semigroup a => a -> a -> a
<> [Inline] -> Text
prettyInlines [Inline]
inlines forall a. Semigroup a => a -> a -> a
<> Text
"|" forall a. Semigroup a => a -> a -> a
<> Text
urlText forall a. Semigroup a => a -> a -> a
<> Text
"|" forall a. Semigroup a => a -> a -> a
<> Text
smartType forall a. Semigroup a => a -> a -> a
<> Text
"]"
delimiterChar :: InlineStyle -> Char
delimiterChar :: InlineStyle -> Char
delimiterChar = \case
InlineStyle
Emphasis -> Char
'_'
InlineStyle
Insert -> Char
'+'
InlineStyle
Strong -> Char
'*'
InlineStyle
Strikeout -> Char
'-'
InlineStyle
Subscript -> Char
'~'
InlineStyle
Superscript -> Char
'^'
renderImageParams :: [Parameter] -> Text
renderImageParams :: [Parameter] -> Text
renderImageParams = \case
[] -> Text
""
[Parameter]
ps | Text
"thumbnail" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Text
parameterKey [Parameter]
ps -> Text
"|thumbnail"
[Parameter]
ps -> Text
"|" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Text
renderParam [Parameter]
ps)
renderWrapped :: Char -> [Inline] -> Text
renderWrapped :: Char -> [Inline] -> Text
renderWrapped Char
c = Char -> Text -> Text
T.cons Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
T.snoc Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Text
prettyInlines