From 1d3a3a027a76941cbc47ad707a17fb43aa3030e7 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Sun, 17 May 2020 21:41:35 +0200
Subject: Org writer: clean-up Div handling
---
src/Text/Pandoc/Writers/Org.hs | 89 ++++++++++++++++++++++++++++--------------
1 file changed, 59 insertions(+), 30 deletions(-)
(limited to 'src')
diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs
index e7b940c57..628d91bf7 100644
--- a/src/Text/Pandoc/Writers/Org.hs
+++ b/src/Text/Pandoc/Writers/Org.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
{- |
Module : Text.Pandoc.Writers.Org
Copyright : © 2010-2015 Puneeth Chaganti <punchagan@gmail.com>
@@ -98,36 +99,7 @@ blockToOrg :: PandocMonad m
=> Block -- ^ Block element
-> Org m (Doc Text)
blockToOrg Null = return empty
-blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do
- contents <- blockListToOrg bs
- let drawerNameTag = ":" <> literal cls <> ":"
- let keys = vcat $ map (\(k,v) ->
- ":" <> literal k <> ":"
- <> space <> literal v) kvs
- let drawerEndTag = text ":END:"
- return $ drawerNameTag $$ cr $$ keys $$
- blankline $$ contents $$
- blankline $$ drawerEndTag $$
- blankline
-blockToOrg (Div (ident, classes, kv) bs) = do
- contents <- blockListToOrg bs
- -- if one class looks like the name of a greater block then output as such:
- -- The ID, if present, is added via the #+NAME keyword; other classes and
- -- key-value pairs are kept as #+ATTR_HTML attributes.
- let isGreaterBlockClass = (`elem` ["center", "quote"]) . T.toLower
- (blockTypeCand, classes') = partition isGreaterBlockClass classes
- return $ case blockTypeCand of
- (blockType:classes'') ->
- blankline $$ attrHtml (ident, classes'' <> classes', kv) $$
- "#+BEGIN_" <> literal blockType $$ contents $$
- "#+END_" <> literal blockType $$ blankline
- _ ->
- -- fallback with id: add id as an anchor if present, discard classes and
- -- key-value pairs, unwrap the content.
- let contents' = if not (T.null ident)
- then "<<" <> literal ident <> ">>" $$ contents
- else contents
- in blankline $$ contents' $$ blankline
+blockToOrg (Div attr bs) = divToOrg attr bs
blockToOrg (Plain inlines) = inlineListToOrg inlines
-- title beginning with fig: indicates that the image is a figure
blockToOrg (Para [Image attr txt (src,tgt)])
@@ -287,6 +259,63 @@ propertiesDrawer (ident, classes, kv) =
kvToOrgProperty (key, value) =
text ":" <> literal key <> text ": " <> literal value <> cr
+-- | The different methods to represent a Div block.
+data DivBlockType
+ = GreaterBlock Text Attr -- ^ Greater block like @center@ or @quote@.
+ | Drawer Text Attr -- ^ Org drawer with of given name; keeps
+ -- key-value pairs.
+ | UnwrappedWithAnchor Text -- ^ Not mapped to other type, only
+ -- identifier is retained (if any).
+
+-- | Gives the most suitable method to render a list of blocks
+-- with attributes.
+divBlockType :: Attr-> DivBlockType
+divBlockType (ident, classes, kvs)
+ -- if any class is named "drawer", then output as org :drawer:
+ | ([_], drawerName:classes') <- partition (== "drawer") classes
+ = Drawer drawerName (ident, classes', kvs)
+ -- if any class is either @center@ or @quote@, then use a org block.
+ | (blockName:classes'', classes') <- partition isGreaterBlockClass classes
+ = GreaterBlock blockName (ident, classes' <> classes'', kvs)
+ -- if no better method is found, unwrap div and set anchor
+ | otherwise
+ = UnwrappedWithAnchor ident
+ where
+ isGreaterBlockClass :: Text -> Bool
+ isGreaterBlockClass = (`elem` ["center", "quote"]) . T.toLower
+
+-- | 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' ->
+ -- 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'
+ $$ "#+BEGIN_" <> literal blockName
+ $$ contents
+ $$ "#+END_" <> literal blockName $$ blankline
+ Drawer drawerName (_,_,kvs) -> do
+ -- Write as drawer. Only key-value pairs are retained.
+ let keys = vcat $ map (\(k,v) ->
+ ":" <> literal k <> ":"
+ <> space <> literal v) kvs
+ return $ ":" <> literal drawerName <> ":" $$ cr
+ $$ keys $$ blankline
+ $$ contents $$ blankline
+ $$ text ":END:" $$ blankline
+ UnwrappedWithAnchor ident -> do
+ -- Unwrap the div. All attributes are discarded, except for
+ -- the identifier, which is added as an anchor before the
+ -- div contents.
+ let contents' = if T.null ident
+ then contents
+ else "<<" <> literal ident <> ">>" $$ contents
+ return (blankline $$ contents' $$ blankline)
+
attrHtml :: Attr -> Doc Text
attrHtml ("" , [] , []) = mempty
attrHtml (ident, classes, kvs) =
--
cgit v1.2.3