From 54b001aa193ace3d6b0a30f8456853d0d2be38c2 Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Mon, 19 Feb 2024 11:26:57 -0800 Subject: [PATCH] Org reader/writer: support admonitions. Closes #9475. --- src/Text/Pandoc/Readers/Org/Blocks.hs | 35 ++++++--- src/Text/Pandoc/Writers/Org.hs | 38 ++++++++-- test/command/9475.md | 102 ++++++++++++++++++++++++++ 3 files changed, 157 insertions(+), 18 deletions(-) create mode 100644 test/command/9475.md diff --git a/src/Text/Pandoc/Readers/Org/Blocks.hs b/src/Text/Pandoc/Readers/Org/Blocks.hs index 01d9c4f8fd35..9fd90dff4637 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 6704cf6f0891..fa8b2e325a4d 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 000000000000..c3f355f3bfa4 --- /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 +```