Org reader/writer: support admonitions.

Closes #9475.

3 files changed, 157 insertions, 18 deletions

diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs
index 01d9c4f8f..9fd90dff4 100644
--- a/src/Text/Pandoc/Readers/Org/Blocks.hs
+++ b/src/Text/Pandoc/Readers/Org/Blocks.hs
@@ -180,16 +180,21 @@ orgBlock = try $ do
   blkType <- blockHeaderStart
   ($ blkType) $
     case T.toLower blkType of
-      "export"  -> exportBlock
-      "comment" -> rawBlockLines (const mempty)
-      "html"    -> rawBlockLines (return . B.rawBlock (lowercase blkType))
-      "latex"   -> rawBlockLines (return . B.rawBlock (lowercase blkType))
-      "ascii"   -> rawBlockLines (return . B.rawBlock (lowercase blkType))
-      "example" -> exampleBlock blockAttrs
-      "quote"   -> parseBlockLines (fmap B.blockQuote)
-      "verse"   -> verseBlock
-      "src"     -> codeBlock blockAttrs
-      _         ->
+      "export"    -> exportBlock
+      "comment"   -> rawBlockLines (const mempty)
+      "html"      -> rawBlockLines (return . B.rawBlock (lowercase blkType))
+      "latex"     -> rawBlockLines (return . B.rawBlock (lowercase blkType))
+      "ascii"     -> rawBlockLines (return . B.rawBlock (lowercase blkType))
+      "example"   -> exampleBlock blockAttrs
+      "quote"     -> parseBlockLines (fmap B.blockQuote)
+      "verse"     -> verseBlock
+      "src"       -> codeBlock blockAttrs
+      "note"      -> admonitionBlock "note" blockAttrs
+      "warning"   -> admonitionBlock "warning" blockAttrs
+      "tip"       -> admonitionBlock "tip" blockAttrs
+      "caution"   -> admonitionBlock "caution" blockAttrs
+      "important" -> admonitionBlock "important" blockAttrs
+      _           ->
         -- case-sensitive checks
         case blkType of
           "abstract" -> metadataBlock
@@ -203,6 +208,16 @@ orgBlock = try $ do
    lowercase :: Text -> Text
    lowercase = T.toLower
 
+admonitionBlock :: PandocMonad m
+                => Text -> BlockAttributes -> Text -> OrgParser m (F Blocks)
+admonitionBlock blockType blockAttrs rawtext = do
+  bls <- parseBlockLines id rawtext
+  let id' = fromMaybe mempty $ blockAttrName blockAttrs
+  pure $ fmap
+    (B.divWith (id', [blockType], []) .
+     (B.divWith ("", ["title"], []) (B.para (B.str (T.toTitle blockType))) <>))
+    bls
+
 exampleBlock :: PandocMonad m => BlockAttributes -> Text -> OrgParser m (F Blocks)
 exampleBlock blockAttrs _label = do
   skipSpaces
diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs
index 6704cf6f0..fa8b2e325 100644
--- a/src/Text/Pandoc/Writers/Org.hs
+++ b/src/Text/Pandoc/Writers/Org.hs
@@ -352,6 +352,7 @@ data DivBlockType
                              --   key-value pairs.
   | UnwrappedWithAnchor Text -- ^ Not mapped to other type, only
                              --   identifier is retained (if any).
+  deriving (Show)
 
 -- | Gives the most suitable method to render a list of blocks
 -- with attributes.
@@ -368,23 +369,39 @@ divBlockType (ident, classes, kvs)
   = UnwrappedWithAnchor ident
  where
   isGreaterBlockClass :: Text -> Bool
-  isGreaterBlockClass = (`elem` ["center", "quote"]) . T.toLower
+  isGreaterBlockClass t = case T.toLower t of
+                            "center" -> True
+                            "quote" -> True
+                            x -> isAdmonition x
+
+isAdmonition :: Text -> Bool
+isAdmonition "warning" = True
+isAdmonition "important" = True
+isAdmonition "tip" = True
+isAdmonition "note" = True
+isAdmonition "caution" = True
+isAdmonition _ = False
 
 -- | Converts a Div to an org-mode element.
 divToOrg :: PandocMonad m
          => Attr -> [Block] -> Org m (Doc Text)
 divToOrg attr bs = do
-  contents <- blockListToOrg bs
   case divBlockType attr of
-    GreaterBlock blockName attr' ->
+    GreaterBlock blockName attr' -> do
       -- Write as greater block. The ID, if present, is added via
       -- the #+name keyword; other classes and key-value pairs
       -- are kept as #+attr_html attributes.
-      return $ blankline $$ attrHtml attr'
+      contents <- case bs of
+                    (Div ("",["title"],[]) _ : bs')
+                      | isAdmonition blockName -> blockListToOrg bs'
+                    _ -> blockListToOrg bs
+      return $ blankline
+            $$ attrHtml attr'
             $$ "#+begin_" <> literal blockName
-            $$ contents
+            $$ chomp contents
             $$ "#+end_" <> literal blockName $$ blankline
     Drawer drawerName (_,_,kvs) -> do
+      contents <- blockListToOrg bs
       -- Write as drawer. Only key-value pairs are retained.
       let keys = vcat $ map (\(k,v) ->
                                ":" <> literal k <> ":"
@@ -394,6 +411,7 @@ divToOrg attr bs = do
             $$ contents $$ blankline
             $$ text ":END:" $$ blankline
     UnwrappedWithAnchor ident -> do
+      contents <- blockListToOrg bs
       -- Unwrap the div. All attributes are discarded, except for
       -- the identifier, which is added as an anchor before the
       -- div contents.
@@ -408,9 +426,13 @@ attrHtml (ident, classes, kvs) =
   let
     name = if T.null ident then mempty else "#+name: " <> literal ident <> cr
     keyword = "#+attr_html"
-    classKv = ("class", T.unwords classes)
-    kvStrings = map (\(k,v) -> ":" <> k <> " " <> v) (classKv:kvs)
-  in name <> keyword <> ": " <> literal (T.unwords kvStrings) <> cr
+    addClassKv = if null classes
+                    then id
+                    else (("class", T.unwords classes):)
+    kvStrings = map (\(k,v) -> ":" <> k <> " " <> v) (addClassKv kvs)
+  in name <> if null kvStrings
+                then mempty
+                else keyword <> ": " <> literal (T.unwords kvStrings) <> cr
 
 -- | Convert list of Pandoc block elements to Org.
 blockListToOrg :: PandocMonad m
diff --git a/test/command/9475.md b/test/command/9475.md
new file mode 100644
index 000000000..c3f355f3b
--- /dev/null
+++ b/test/command/9475.md
@@ -0,0 +1,102 @@
+```
+% pandoc -f org -t native
+#+begin_note
+Useful note.
+#+end_note
+
+#+begin_warning
+Be careful!
+#+end_warning
+
+#+begin_tip
+Try this...
+#+end_tip
+
+#+begin_caution
+Caution
+#+end_caution
+
+#+name: foo
+#+begin_important
+Important
+#+end_important
+^D
+[ Div
+    ( "" , [ "note" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Note" ] ]
+    , Para [ Str "Useful" , Space , Str "note." ]
+    ]
+, Div
+    ( "" , [ "warning" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Warning" ] ]
+    , Para [ Str "Be" , Space , Str "careful!" ]
+    ]
+, Div
+    ( "" , [ "tip" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Tip" ] ]
+    , Para [ Str "Try" , Space , Str "this\8230" ]
+    ]
+, Div
+    ( "" , [ "caution" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Caution" ] ]
+    , Para [ Str "Caution" ]
+    ]
+, Div
+    ( "foo" , [ "important" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Important" ] ]
+    , Para [ Str "Important" ]
+    ]
+]
+
+```
+
+```
+% pandoc -f native -t org
+[ Div
+    ( "" , [ "note" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Note" ] ]
+    , Para [ Str "Useful" , Space , Str "note." ]
+    ]
+, Div
+    ( "" , [ "warning" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Warning" ] ]
+    , Para [ Str "Be" , Space , Str "careful!" ]
+    ]
+, Div
+    ( "" , [ "tip" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Tip" ] ]
+    , Para [ Str "Try" , Space , Str "this\8230" ]
+    ]
+, Div
+    ( "" , [ "caution" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Caution" ] ]
+    , Para [ Str "Caution" ]
+    ]
+, Div
+    ( "foo" , [ "important" ] , [] )
+    [ Div ( "" , [ "title" ] , [] ) [ Para [ Str "Important" ] ]
+    , Para [ Str "Important" ]
+    ]
+]
+^D
+#+begin_note
+Useful note.
+#+end_note
+
+#+begin_warning
+Be careful!
+#+end_warning
+
+#+begin_tip
+Try this...
+#+end_tip
+
+#+begin_caution
+Caution
+#+end_caution
+
+#+name: foo
+#+begin_important
+Important
+#+end_important
+```