summaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Writers/Org.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Writers/Org.hs')
-rw-r--r--src/Text/Pandoc/Writers/Org.hs242
1 files changed, 126 insertions, 116 deletions
diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs
index 4302459cc..2307204a5 100644
--- a/src/Text/Pandoc/Writers/Org.hs
+++ b/src/Text/Pandoc/Writers/Org.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-
Copyright (C) 2010-2015 Puneeth Chaganti <punchagan@gmail.com>
- Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>,
- and John MacFarlane <jgm@berkeley.edu>
+ 2010-2018 John MacFarlane <jgm@berkeley.edu>
+ 2016-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -21,10 +21,12 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
{- |
Module : Text.Pandoc.Writers.Org
- Copyright : Copyright (C) 2010-2015 Puneeth Chaganti and John MacFarlane
+ Copyright : © 2010-2015 Puneeth Chaganti <punchagan@gmail.com>
+ 2010-2018 John MacFarlane <jgm@berkeley.edu>
+ 2016-2018 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
License : GNU GPL, version 2 or above
- Maintainer : Puneeth Chaganti <punchagan@gmail.com>
+ Maintainer : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
Stability : alpha
Portability : portable
@@ -32,64 +34,67 @@ Conversion of 'Pandoc' documents to Emacs Org-Mode.
Org-Mode: <http://orgmode.org>
-}
-module Text.Pandoc.Writers.Org ( writeOrg) where
+module Text.Pandoc.Writers.Org (writeOrg) where
+import Control.Monad.State.Strict
+import Data.Char (isAlphaNum, toLower)
+import Data.List (intersect, intersperse, isPrefixOf, partition, transpose)
+import Data.Text (Text)
+import Text.Pandoc.Class (PandocMonad, report)
import Text.Pandoc.Definition
+import Text.Pandoc.Logging
import Text.Pandoc.Options
-import Text.Pandoc.Shared
-import Text.Pandoc.Writers.Shared
import Text.Pandoc.Pretty
+import Text.Pandoc.Shared
import Text.Pandoc.Templates (renderTemplate')
-import Data.Char ( isAlphaNum, toLower )
-import Data.List ( isPrefixOf, intersect, intersperse, partition, transpose )
-import Control.Monad.State
+import Text.Pandoc.Writers.Shared
data WriterState =
- WriterState { stNotes :: [[Block]]
- , stLinks :: Bool
- , stImages :: Bool
- , stHasMath :: Bool
- , stOptions :: WriterOptions
+ WriterState { stNotes :: [[Block]]
+ , stHasMath :: Bool
+ , stOptions :: WriterOptions
}
+type Org = StateT WriterState
+
-- | Convert Pandoc to Org.
-writeOrg :: WriterOptions -> Pandoc -> String
-writeOrg opts document =
- let st = WriterState { stNotes = [], stLinks = False,
- stImages = False, stHasMath = False,
+writeOrg :: PandocMonad m => WriterOptions -> Pandoc -> m Text
+writeOrg opts document = do
+ let st = WriterState { stNotes = [],
+ stHasMath = False,
stOptions = opts }
- in evalState (pandocToOrg document) st
+ evalStateT (pandocToOrg document) st
-- | Return Org representation of document.
-pandocToOrg :: Pandoc -> State WriterState String
+pandocToOrg :: PandocMonad m => Pandoc -> Org m Text
pandocToOrg (Pandoc meta blocks) = do
- opts <- liftM stOptions get
+ opts <- gets stOptions
let colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
+ let render' :: Doc -> Text
+ render' = render colwidth
metadata <- metaToJSON opts
- (fmap (render colwidth) . blockListToOrg)
- (fmap (render colwidth) . inlineListToOrg)
+ (fmap render' . blockListToOrg)
+ (fmap render' . inlineListToOrg)
meta
body <- blockListToOrg blocks
- notes <- liftM (reverse . stNotes) get >>= notesToOrg
- -- note that the notes may contain refs, so we do them first
- hasMath <- liftM stHasMath get
- let main = render colwidth $ foldl ($+$) empty $ [body, notes]
+ notes <- gets (reverse . stNotes) >>= notesToOrg
+ hasMath <- gets stHasMath
+ let main = render colwidth . foldl ($+$) empty $ [body, notes]
let context = defField "body" main
- $ defField "math" hasMath
+ . defField "math" hasMath
$ metadata
case writerTemplate opts of
Nothing -> return main
- Just tpl -> return $ renderTemplate' tpl context
+ Just tpl -> renderTemplate' tpl context
-- | Return Org representation of notes.
-notesToOrg :: [[Block]] -> State WriterState Doc
+notesToOrg :: PandocMonad m => [[Block]] -> Org m Doc
notesToOrg notes =
- mapM (\(num, note) -> noteToOrg num note) (zip [1..] notes) >>=
- return . vsep
+ vsep <$> zipWithM noteToOrg [1..] notes
-- | Return Org representation of a note.
-noteToOrg :: Int -> [Block] -> State WriterState Doc
+noteToOrg :: PandocMonad m => Int -> [Block] -> Org m Doc
noteToOrg num note = do
contents <- blockListToOrg note
let marker = "[fn:" ++ show num ++ "] "
@@ -109,8 +114,9 @@ isRawFormat f =
f == Format "latex" || f == Format "tex" || f == Format "org"
-- | Convert Pandoc block element to Org.
-blockToOrg :: Block -- ^ Block element
- -> State WriterState Doc
+blockToOrg :: PandocMonad m
+ => Block -- ^ Block element
+ -> Org m Doc
blockToOrg Null = return empty
blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do
contents <- blockListToOrg bs
@@ -123,36 +129,25 @@ blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do
blankline $$ contents $$
blankline $$ drawerEndTag $$
blankline
-blockToOrg (Div attrs bs) = do
+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"]) . map toLower
- return $ case attrs of
- ("", [], []) ->
- -- nullAttr, treat contents as if it wasn't wrapped
- blankline $$ contents $$ blankline
- (ident, [], []) ->
- -- only an id: add id as an anchor, unwrap the rest
- blankline $$ "<<" <> text ident <> ">>" $$ contents $$ blankline
- (ident, classes, kv) ->
- -- 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
- (blockTypeCand, classes') = partition isGreaterBlockClass classes
- in case blockTypeCand of
- (blockType:classes'') ->
- blankline $$ attrHtml (ident, classes'' <> classes', kv) $$
- "#+BEGIN_" <> text blockType $$ contents $$
- "#+END_" <> text blockType $$ blankline
- _ ->
- -- fallback: wrap in div tags
- let
- startTag = tagWithAttrs "div" attrs
- endTag = text "</div>"
- in blankline $$ "#+BEGIN_HTML" $$
- nest 2 startTag $$ "#+END_HTML" $$ blankline $$
- contents $$ blankline $$ "#+BEGIN_HTML" $$
- nest 2 endTag $$ "#+END_HTML" $$ blankline
+ (blockTypeCand, classes') = partition isGreaterBlockClass classes
+ return $ case blockTypeCand of
+ (blockType:classes'') ->
+ blankline $$ attrHtml (ident, classes'' <> classes', kv) $$
+ "#+BEGIN_" <> text blockType $$ contents $$
+ "#+END_" <> text 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 (null ident)
+ then "<<" <> text ident <> ">>" $$ contents
+ else contents
+ in blankline $$ contents' $$ blankline
blockToOrg (Plain inlines) = inlineListToOrg inlines
-- title beginning with fig: indicates that the image is a figure
blockToOrg (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do
@@ -167,20 +162,22 @@ blockToOrg (Para inlines) = do
blockToOrg (LineBlock lns) = do
let splitStanza [] = []
splitStanza xs = case break (== mempty) xs of
- (l, []) -> l : []
+ (l, []) -> [l]
(l, _:r) -> l : splitStanza r
let joinWithLinefeeds = nowrap . mconcat . intersperse cr
let joinWithBlankLines = mconcat . intersperse blankline
- let prettyfyStanza ls = joinWithLinefeeds <$> mapM inlineListToOrg ls
- contents <- joinWithBlankLines <$> mapM prettyfyStanza (splitStanza lns)
+ let prettifyStanza ls = joinWithLinefeeds <$> mapM inlineListToOrg ls
+ contents <- joinWithBlankLines <$> mapM prettifyStanza (splitStanza lns)
return $ blankline $$ "#+BEGIN_VERSE" $$
nest 2 contents $$ "#+END_VERSE" <> blankline
blockToOrg (RawBlock "html" str) =
return $ blankline $$ "#+BEGIN_HTML" $$
nest 2 (text str) $$ "#+END_HTML" $$ blankline
-blockToOrg (RawBlock f str) | isRawFormat f =
- return $ text str
-blockToOrg (RawBlock _ _) = return empty
+blockToOrg b@(RawBlock f str)
+ | isRawFormat f = return $ text str
+ | otherwise = do
+ report $ BlockNotRendered b
+ return empty
blockToOrg HorizontalRule = return $ blankline $$ "--------------" $$ blankline
blockToOrg (Header level attr inlines) = do
contents <- inlineListToOrg inlines
@@ -190,7 +187,7 @@ blockToOrg (Header level attr inlines) = do
else cr <> nest (level + 1) (propertiesDrawer attr)
return $ headerStr <> " " <> contents <> drawerStr <> blankline
blockToOrg (CodeBlock (_,classes,_) str) = do
- opts <- stOptions <$> get
+ opts <- gets stOptions
let tabstop = writerTabStop opts
let at = map pandocLangToOrg classes `intersect` orgLangIdentifiers
let (beg, end) = case at of
@@ -205,7 +202,7 @@ blockToOrg (Table caption' _ _ headers rows) = do
caption'' <- inlineListToOrg caption'
let caption = if null caption'
then empty
- else ("#+CAPTION: " <> caption'')
+ else "#+CAPTION: " <> caption''
headers' <- mapM blockListToOrg headers
rawRows <- mapM (mapM blockListToOrg) rows
let numChars = maximum . map offset
@@ -215,16 +212,16 @@ blockToOrg (Table caption' _ _ headers rows) = do
-- FIXME: Org doesn't allow blocks with height more than 1.
let hpipeBlocks blocks = hcat [beg, middle, end]
where h = maximum (1 : map height blocks)
- sep' = lblock 3 $ vcat (map text $ replicate h " | ")
- beg = lblock 2 $ vcat (map text $ replicate h "| ")
- end = lblock 2 $ vcat (map text $ replicate h " |")
+ sep' = lblock 3 $ vcat (replicate h (text " | "))
+ beg = lblock 2 $ vcat (replicate h (text "| "))
+ end = lblock 2 $ vcat (replicate h (text " |"))
middle = hcat $ intersperse sep' blocks
let makeRow = hpipeBlocks . zipWith lblock widthsInChars
let head' = makeRow headers'
rows' <- mapM (\row -> do cols <- mapM blockListToOrg row
return $ makeRow cols) rows
let border ch = char '|' <> char ch <>
- (hcat $ intersperse (char ch <> char '+' <> char ch) $
+ (hcat . intersperse (char ch <> char '+' <> char ch) $
map (\l -> text $ replicate l ch) widthsInChars) <>
char ch <> char '|'
let body = vcat rows'
@@ -245,8 +242,7 @@ blockToOrg (OrderedList (start, _, delim) items) = do
let maxMarkerLength = maximum $ map length markers
let markers' = map (\m -> let s = maxMarkerLength - length m
in m ++ replicate s ' ') markers
- contents <- mapM (\(item, num) -> orderedListItemToOrg item num) $
- zip markers' items
+ contents <- zipWithM orderedListItemToOrg markers' items
-- ensure that sublists have preceding blank line
return $ blankline $$ vcat contents $$ blankline
blockToOrg (DefinitionList items) = do
@@ -254,25 +250,27 @@ blockToOrg (DefinitionList items) = do
return $ vcat contents $$ blankline
-- | Convert bullet list item (list of blocks) to Org.
-bulletListItemToOrg :: [Block] -> State WriterState Doc
+bulletListItemToOrg :: PandocMonad m => [Block] -> Org m Doc
bulletListItemToOrg items = do
contents <- blockListToOrg items
- return $ hang 3 "- " (contents <> cr)
+ return $ hang 2 "- " (contents <> cr)
-- | Convert ordered list item (a list of blocks) to Org.
-orderedListItemToOrg :: String -- ^ marker for list item
+orderedListItemToOrg :: PandocMonad m
+ => String -- ^ marker for list item
-> [Block] -- ^ list item (list of blocks)
- -> State WriterState Doc
+ -> Org m Doc
orderedListItemToOrg marker items = do
contents <- blockListToOrg items
return $ hang (length marker + 1) (text marker <> space) (contents <> cr)
-- | Convert defintion list item (label, list of blocks) to Org.
-definitionListItemToOrg :: ([Inline], [[Block]]) -> State WriterState Doc
+definitionListItemToOrg :: PandocMonad m
+ => ([Inline], [[Block]]) -> Org m Doc
definitionListItemToOrg (label, defs) = do
label' <- inlineListToOrg label
- contents <- liftM vcat $ mapM blockListToOrg defs
- return $ hang 3 "- " $ label' <> " :: " <> (contents <> cr)
+ contents <- vcat <$> mapM blockListToOrg defs
+ return . hang 2 "- " $ label' <> " :: " <> (contents <> cr)
-- | Convert list of key/value pairs to Org :PROPERTIES: drawer.
propertiesDrawer :: Attr -> Doc
@@ -280,8 +278,8 @@ propertiesDrawer (ident, classes, kv) =
let
drawerStart = text ":PROPERTIES:"
drawerEnd = text ":END:"
- kv' = if (classes == mempty) then kv else ("CLASS", unwords classes):kv
- kv'' = if (ident == mempty) then kv' else ("CUSTOM_ID", ident):kv'
+ kv' = if classes == mempty then kv else ("CLASS", unwords classes):kv
+ kv'' = if ident == mempty then kv' else ("CUSTOM_ID", ident):kv'
properties = vcat $ map kvToOrgProperty kv''
in
drawerStart <> cr <> properties <> cr <> drawerEnd
@@ -294,23 +292,37 @@ attrHtml :: Attr -> Doc
attrHtml ("" , [] , []) = mempty
attrHtml (ident, classes, kvs) =
let
- name = if (null ident) then mempty else "#+NAME: " <> text ident <> cr
+ name = if null ident then mempty else "#+NAME: " <> text ident <> cr
keyword = "#+ATTR_HTML"
classKv = ("class", unwords classes)
kvStrings = map (\(k,v) -> ":" <> k <> " " <> v) (classKv:kvs)
in name <> keyword <> ": " <> text (unwords kvStrings) <> cr
-- | Convert list of Pandoc block elements to Org.
-blockListToOrg :: [Block] -- ^ List of block elements
- -> State WriterState Doc
-blockListToOrg blocks = mapM blockToOrg blocks >>= return . vcat
+blockListToOrg :: PandocMonad m
+ => [Block] -- ^ List of block elements
+ -> Org m Doc
+blockListToOrg blocks = vcat <$> mapM blockToOrg blocks
-- | Convert list of Pandoc inline elements to Org.
-inlineListToOrg :: [Inline] -> State WriterState Doc
-inlineListToOrg lst = mapM inlineToOrg lst >>= return . hcat
+inlineListToOrg :: PandocMonad m
+ => [Inline]
+ -> Org m Doc
+inlineListToOrg lst = hcat <$> mapM inlineToOrg (fixMarkers lst)
+ where fixMarkers [] = [] -- prevent note refs and list markers from wrapping, see #4171
+ fixMarkers (Space : x : rest) | shouldFix x =
+ Str " " : x : fixMarkers rest
+ fixMarkers (SoftBreak : x : rest) | shouldFix x =
+ Str " " : x : fixMarkers rest
+ fixMarkers (x : rest) = x : fixMarkers rest
+
+ shouldFix Note{} = True -- Prevent footnotes
+ shouldFix (Str "-") = True -- Prevent bullet list items
+ -- TODO: prevent ordered list items
+ shouldFix _ = False
-- | Convert Pandoc inline element to Org.
-inlineToOrg :: Inline -> State WriterState Doc
+inlineToOrg :: PandocMonad m => Inline -> Org m Doc
inlineToOrg (Span (uid, [], []) []) =
return $ "<<" <> text uid <> ">>"
inlineToOrg (Span _ lst) =
@@ -339,50 +351,48 @@ inlineToOrg (Quoted DoubleQuote lst) = do
return $ "\"" <> contents <> "\""
inlineToOrg (Cite _ lst) = inlineListToOrg lst
inlineToOrg (Code _ str) = return $ "=" <> text str <> "="
-inlineToOrg (Str str) = return $ text $ escapeString str
+inlineToOrg (Str str) = return . text $ escapeString str
inlineToOrg (Math t str) = do
modify $ \st -> st{ stHasMath = True }
return $ if t == InlineMath
then "$" <> text str <> "$"
else "$$" <> text str <> "$$"
-inlineToOrg (RawInline f@(Format f') str) =
- return $ if isRawFormat f
- then text str
- else "@@" <> text f' <> ":" <> text str <> "@@"
-inlineToOrg (LineBreak) = return (text "\\\\" <> cr)
+inlineToOrg il@(RawInline f str)
+ | isRawFormat f = return $ text str
+ | otherwise = do
+ report $ InlineNotRendered il
+ return empty
+inlineToOrg LineBreak = return (text "\\\\" <> cr)
inlineToOrg Space = return space
inlineToOrg SoftBreak = do
wrapText <- gets (writerWrapText . stOptions)
case wrapText of
- WrapPreserve -> return cr
- WrapAuto -> return space
- WrapNone -> return space
-inlineToOrg (Link _ txt (src, _)) = do
+ WrapPreserve -> return cr
+ WrapAuto -> return space
+ WrapNone -> return space
+inlineToOrg (Link _ txt (src, _)) =
case txt of
[Str x] | escapeURI x == src -> -- autolink
- do modify $ \s -> s{ stLinks = True }
- return $ "[[" <> text (orgPath x) <> "]]"
+ return $ "[[" <> text (orgPath x) <> "]]"
_ -> do contents <- inlineListToOrg txt
- modify $ \s -> s{ stLinks = True }
return $ "[[" <> text (orgPath src) <> "][" <> contents <> "]]"
-inlineToOrg (Image _ _ (source, _)) = do
- modify $ \s -> s{ stImages = True }
+inlineToOrg (Image _ _ (source, _)) =
return $ "[[" <> text (orgPath source) <> "]]"
inlineToOrg (Note contents) = do
-- add to notes in state
- notes <- get >>= (return . stNotes)
+ notes <- gets stNotes
modify $ \st -> st { stNotes = contents:notes }
- let ref = show $ (length notes) + 1
+ let ref = show $ length notes + 1
return $ "[fn:" <> text ref <> "]"
orgPath :: String -> String
orgPath src =
case src of
- [] -> mempty -- wiki link
- ('#':xs) -> xs -- internal link
- _ | isUrl src -> src
- _ | isFilePath src -> src
- _ -> "file:" <> src
+ [] -> mempty -- wiki link
+ ('#':_) -> src -- internal link
+ _ | isUrl src -> src
+ _ | isFilePath src -> src
+ _ -> "file:" <> src
where
isFilePath :: String -> Bool
isFilePath cs = any (`isPrefixOf` cs) ["/", "./", "../", "file:"]
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-24 15:29:13 +0000