diff options
Diffstat (limited to 'src/Text/Pandoc')
| -rw-r--r-- | src/Text/Pandoc/Writers/Org.hs | 89 |
1 files changed, 59 insertions, 30 deletions
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) = |