Org writer: clean-up Div handling

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) =