aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Writers/Jira.hs
blob: 7090642704fbc604e2e11073b91870b22356015a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{- |
   Module      : Text.Pandoc.Writers.Jira
   Copyright   : © 2010-2021 Albert Krewinkel, John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to Jira markup.

JIRA:
<https://jira.atlassian.com/secure/WikiRendererHelpAction.jspa?section=all>
-}
module Text.Pandoc.Writers.Jira ( writeJira ) where
import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)
import Control.Monad.State.Strict (StateT, evalStateT, gets, modify)
import Data.Foldable (find)
import Data.Text (Text)
import Text.Jira.Parser (plainText)
import Text.Jira.Printer (prettyBlocks, prettyInlines)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Options (WriterOptions (writerTemplate, writerWrapText),
                            WrapOption (..))
import Text.Pandoc.Shared (linesToPara, stringify)
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Writers.Math (texMathToInlines)
import Text.Pandoc.Writers.Shared (defField, metaToContext, toLegacyTable)
import Text.DocLayout (literal, render)
import qualified Data.Text as T
import qualified Text.Jira.Markup as Jira

-- | Convert Pandoc to Jira.
writeJira :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJira opts = runDefaultConverter (writerWrapText opts) (pandocToJira opts)

-- | State to keep track of footnotes.
data ConverterState = ConverterState
  { stNotes   :: [Text] -- ^ Footnotes to be appended to the end of the text
  , stInPanel :: Bool   -- ^ whether we are in a @{panel}@ block
  }

-- | Initial converter state.
startState :: ConverterState
startState = ConverterState
  { stNotes = []
  , stInPanel = False
  }

-- | Converter monad
type JiraConverter m = ReaderT WrapOption (StateT ConverterState m)

-- | Run a converter using the default state
runDefaultConverter :: PandocMonad m
                    => WrapOption
                    -> (a -> JiraConverter m Text)
                    -> a
                    -> m Text
runDefaultConverter wrap c x = evalStateT (runReaderT (c x) wrap) startState

-- | Return Jira representation of document.
pandocToJira :: PandocMonad m
             => WriterOptions -> Pandoc -> JiraConverter m Text
pandocToJira opts (Pandoc meta blocks) = do
  wrap <- ask
  metadata <- metaToContext opts
                 (fmap literal . runDefaultConverter wrap blockListToJira)
                 (fmap literal . runDefaultConverter wrap inlineListToJira) meta
  body <- blockListToJira blocks
  notes <- gets $ T.intercalate "\n" . reverse . stNotes
  let main = body <> if T.null notes then mempty else "\n\n" <> notes
  let context = defField "body" main metadata
  return $
    case writerTemplate opts of
      Nothing  -> main
      Just tpl -> render Nothing $ renderTemplate tpl context

blockListToJira :: PandocMonad m => [Block] -> JiraConverter m Text
blockListToJira = fmap prettyBlocks . toJiraBlocks

inlineListToJira :: PandocMonad m => [Inline] -> JiraConverter m Text
inlineListToJira = fmap prettyInlines . toJiraInlines

toJiraBlocks :: PandocMonad m => [Block] -> JiraConverter m [Jira.Block]
toJiraBlocks blocks = do
  let convert = \case
        BlockQuote bs        -> singleton . Jira.BlockQuote
                                <$> toJiraBlocks bs
        BulletList items     -> singleton . Jira.List Jira.CircleBullets
                                <$> toJiraItems items
        CodeBlock attr cs    -> toJiraCode attr cs
        DefinitionList items -> toJiraDefinitionList items
        Div attr bs          -> toJiraPanel attr bs
        Header lvl attr xs   -> toJiraHeader lvl attr xs
        HorizontalRule       -> return . singleton $ Jira.HorizontalRule
        LineBlock xs         -> toJiraBlocks [linesToPara xs]
        OrderedList _ items  -> singleton . Jira.List Jira.Enumeration
                                <$> toJiraItems items
        Para xs              -> singleton . Jira.Para <$> toJiraInlines xs
        Plain xs             -> singleton . Jira.Para <$> toJiraInlines xs
        RawBlock fmt cs      -> rawBlockToJira fmt cs
        Table _ blkCapt specs thead tbody tfoot -> singleton <$> do
          let (_, _, _, hd, body) = toLegacyTable blkCapt specs thead tbody tfoot
          headerRow <- if all null hd
                       then pure Nothing
                       else Just <$> toRow Jira.HeaderCell hd
          bodyRows <- mapM (toRow Jira.BodyCell) body
          let rows = case headerRow of
                       Just header -> header : bodyRows
                       Nothing     -> bodyRows
          return $ Jira.Table rows
  jiraBlocks <- mapM convert blocks
  return $ mconcat jiraBlocks

toRow :: PandocMonad m
      => ([Jira.Block] -> Jira.Cell)
      -> [[Block]]
      -> JiraConverter m Jira.Row
toRow mkCell cells = Jira.Row <$>
  mapM (fmap mkCell . toJiraBlocks) cells

toJiraItems :: PandocMonad m => [[Block]] -> JiraConverter m [[Jira.Block]]
toJiraItems = mapM toJiraBlocks

toJiraCode :: PandocMonad m
           => Attr
           -> Text
           -> JiraConverter m [Jira.Block]
toJiraCode (ident, classes, _attribs) code = do
  return . addAnchor ident . singleton $
    case find (\c -> T.toLower c `elem` knownLanguages) classes of
      Nothing -> Jira.NoFormat mempty code
      Just l  -> Jira.Code (Jira.Language l) mempty code

-- | Prepends an anchor with the given identifier.
addAnchor :: Text -> [Jira.Block] -> [Jira.Block]
addAnchor ident =
  if T.null ident
  then id
  else \case
    Jira.Para xs : bs -> (Jira.Para (Jira.Anchor ident : xs) : bs)
    bs                -> (Jira.Para (singleton (Jira.Anchor ident)) : bs)

-- | Creates a Jira definition list
toJiraDefinitionList :: PandocMonad m
                     => [([Inline], [[Block]])]
                     -> JiraConverter m [Jira.Block]
toJiraDefinitionList defItems = do
  let convertDefItem (term, defs) = do
        jiraTerm <- Jira.Para <$> styled Jira.Strong term
        jiraDefs <- mconcat <$> mapM toJiraBlocks defs
        return $ jiraTerm : jiraDefs
  singleton . Jira.List Jira.CircleBullets <$> mapM convertDefItem defItems

-- | Creates a Jira panel
toJiraPanel :: PandocMonad m
            => Attr -> [Block]
            -> JiraConverter m [Jira.Block]
toJiraPanel (ident, classes, attribs) blocks = do
  inPanel <- gets stInPanel
  if inPanel || ("panel" `notElem` classes && null attribs)
    then addAnchor ident <$> toJiraBlocks blocks
    else do
      modify $ \st -> st{ stInPanel = True }
      jiraBlocks <- toJiraBlocks blocks
      modify $ \st -> st{ stInPanel = inPanel }
      let params = map (uncurry Jira.Parameter) attribs
      return $ singleton (Jira.Panel params $ addAnchor ident jiraBlocks)

-- | Creates a Jira header
toJiraHeader :: PandocMonad m
             => Int -> Attr -> [Inline]
             -> JiraConverter m [Jira.Block]
toJiraHeader lvl (ident, _, _) inlines =
  let anchor = Jira.Anchor ident
  in singleton . Jira.Header lvl . (anchor :) <$> toJiraInlines inlines

-- | Handles raw block. Jira is included verbatim, everything else is
-- discarded.
rawBlockToJira :: PandocMonad m
               => Format -> Text
               -> JiraConverter m [Jira.Block]
rawBlockToJira fmt cs = do
  rawInlines <- toJiraRaw fmt cs
  return $
    if null rawInlines
    then mempty
    else singleton (Jira.Para rawInlines)

toJiraRaw :: PandocMonad m
          => Format -> Text -> JiraConverter m [Jira.Inline]
toJiraRaw fmt cs = case fmt of
  Format "jira" -> return . singleton $ Jira.Str cs
  _             -> return mempty


--
-- Inlines
--

toJiraInlines :: PandocMonad m => [Inline] -> JiraConverter m [Jira.Inline]
toJiraInlines inlines = do
  let convert = \case
        Cite _ xs          -> toJiraInlines xs
        Code _ cs          -> return . singleton $
                              Jira.Monospaced (escapeSpecialChars cs)
        Emph xs            -> styled Jira.Emphasis xs
        Underline xs       -> styled Jira.Insert xs
        Image attr cap tgt -> uncurry (imageToJira attr cap) tgt
        LineBreak          -> pure . singleton $ Jira.Linebreak
        Link attr xs tgt   -> toJiraLink attr tgt xs
        Math mtype cs      -> mathToJira mtype cs
        Note bs            -> registerNotes bs
        Quoted qt xs       -> quotedToJira qt xs
        RawInline fmt cs   -> toJiraRaw fmt cs
        SmallCaps xs       -> styled Jira.Strong xs
        SoftBreak          -> do
                                preserveBreak <- asks (== WrapPreserve)
                                pure . singleton $ if preserveBreak
                                  then Jira.Linebreak
                                  else Jira.Space
        Space              -> pure . singleton $ Jira.Space
        Span attr xs       -> spanToJira attr xs
        Str s              -> pure $ escapeSpecialChars s
        Strikeout xs       -> styled Jira.Strikeout xs
        Strong xs          -> styled Jira.Strong xs
        Subscript xs       -> styled Jira.Subscript xs
        Superscript xs     -> styled Jira.Superscript xs
  jiraInlines <- mapM convert inlines
  return $ mconcat jiraInlines

singleton :: a -> [a]
singleton = (:[])

styled :: PandocMonad m
       => Jira.InlineStyle -> [Inline]
       -> JiraConverter m [Jira.Inline]
styled s = fmap (singleton . Jira.Styled s) . toJiraInlines

-- | Converts a plain text value to Jira inlines, ensuring that all
-- special characters will be handled appropriately.
escapeSpecialChars :: Text -> [Jira.Inline]
escapeSpecialChars t = case plainText t of
  Right xs -> xs
  Left _  -> singleton $ Jira.Str t

imageToJira :: PandocMonad m
            => Attr -> [Inline] -> Text -> Text
            -> JiraConverter m [Jira.Inline]
imageToJira (_, classes, kvs) caption src title =
  let imageWithParams ps = Jira.Image ps (Jira.URL src)
      alt = stringify caption
  in pure . singleton . imageWithParams $
     if "thumbnail" `elem` classes
     then [Jira.Parameter "thumbnail" ""]
     else map (uncurry Jira.Parameter)
          . (if T.null title then id else (("title", title):))
          . (if T.null alt then id else (("alt", alt):))
          $ kvs

-- | Creates a Jira Link element.
toJiraLink :: PandocMonad m
           => Attr
           -> Target
           -> [Inline]
           -> JiraConverter m [Jira.Inline]
toJiraLink (_, classes, _) (url, _) alias = do
  let (linkType, url') = toLinkType url
  description <- if url `elem` [stringify alias, "mailto:" <> stringify alias]
                 then pure mempty
                 else toJiraInlines alias
  pure . singleton $ Jira.Link linkType description (Jira.URL url')
 where
  toLinkType url'
    | Just email <- T.stripPrefix "mailto:" url' = (Jira.Email, email)
    | "user-account" `elem` classes              = (Jira.User, dropTilde url)
    | "attachment" `elem` classes                = (Jira.Attachment, url)
    | "smart-card" `elem` classes                = (Jira.SmartCard, url)
    | "smart-link" `elem` classes                = (Jira.SmartLink, url)
    | otherwise                                  = (Jira.External, url)
  dropTilde txt = case T.uncons txt of
    Just ('~', username) -> username
    _                    -> txt

mathToJira :: PandocMonad m
           => MathType
           -> Text
           -> JiraConverter m [Jira.Inline]
mathToJira mtype cs = do
  mathInlines <- toJiraInlines =<< texMathToInlines mtype cs
  return $ case mtype of
    InlineMath  -> mathInlines
    DisplayMath -> Jira.Linebreak : mathInlines ++ [Jira.Linebreak]

quotedToJira :: PandocMonad m
             => QuoteType
             -> [Inline]
             -> JiraConverter m [Jira.Inline]
quotedToJira qtype xs = do
  let quoteChar = case qtype of
                    DoubleQuote -> "\""
                    SingleQuote -> "'"
  let surroundWithQuotes = (Jira.Str quoteChar :) . (++ [Jira.Str quoteChar])
  surroundWithQuotes <$> toJiraInlines xs

spanToJira :: PandocMonad m
           => Attr -> [Inline]
           -> JiraConverter m [Jira.Inline]
spanToJira (ident, _classes, attribs) inls =
  let wrap = case lookup "color" attribs of
               Nothing -> id
               Just color -> singleton . Jira.ColorInline (Jira.ColorName color)
  in wrap <$> case ident of
    "" -> toJiraInlines inls
    _  -> (Jira.Anchor ident :) <$> toJiraInlines inls

registerNotes :: PandocMonad m => [Block] -> JiraConverter m [Jira.Inline]
registerNotes contents = do
  curNotes <- gets stNotes
  let newnum = length curNotes + 1
  contents' <- blockListToJira contents
  let thisnote = "\\[" <> T.pack (show newnum) <> "] " <> contents' <> "\n"
  modify $ \s -> s { stNotes = thisnote : curNotes }
  return . singleton . Jira.Str $
    "[" <> T.pack (show newnum) <> "]"

-- | Language codes recognized by jira
knownLanguages :: [Text]
knownLanguages =
  [ "actionscript", "ada", "applescript", "bash", "c", "c#", "c++"
  , "css", "erlang", "go", "groovy", "haskell", "html", "java", "javascript"
  , "json", "lua", "nyan", "objc", "perl", "php", "python", "r", "ruby"
  , "scala", "sql", "swift", "visualbasic", "xml", "yaml"
  ]