path: root/src/Text/Pandoc/Writers/Org.hs

{-# LANGUAGE OverloadedStrings #-}
{-
Copyright (C) 2010-2015 Puneeth Chaganti <punchagan@gmail.com>
                        Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>,
                        and John MacFarlane <jgm@berkeley.edu>

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
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
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
   License     : GNU GPL, version 2 or above

   Maintainer  : Puneeth Chaganti <punchagan@gmail.com>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to Emacs Org-Mode.

Org-Mode:  <http://orgmode.org>
-}
module Text.Pandoc.Writers.Org ( writeOrg) where
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Shared
import Text.Pandoc.Writers.Shared
import Text.Pandoc.Pretty
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.Class (PandocMonad)

data WriterState =
  WriterState { stNotes     :: [[Block]]
              , stHasMath   :: Bool
              , stOptions   :: WriterOptions
              }

-- | Convert Pandoc to Org.
writeOrg :: PandocMonad m => WriterOptions -> Pandoc -> m String
writeOrg opts document = return $
  let st = WriterState { stNotes = [],
                         stHasMath = False,
                         stOptions = opts }
  in evalState (pandocToOrg document) st

-- | Return Org representation of document.
pandocToOrg :: Pandoc -> State WriterState String
pandocToOrg (Pandoc meta blocks) = do
  opts <- liftM stOptions get
  let colwidth = if writerWrapText opts == WrapAuto
                    then Just $ writerColumns opts
                    else Nothing
  metadata <- metaToJSON opts
               (fmap (render colwidth) . blockListToOrg)
               (fmap (render colwidth) . inlineListToOrg)
               meta
  body <- blockListToOrg blocks
  notes <- liftM (reverse . stNotes) get >>= notesToOrg
  hasMath <- liftM stHasMath get
  let main = render colwidth $ foldl ($+$) empty $ [body, notes]
  let context = defField "body" main
              $ defField "math" hasMath
              $ metadata
  case writerTemplate opts of
       Nothing  -> return main
       Just tpl -> return $ renderTemplate' tpl context

-- | Return Org representation of notes.
notesToOrg :: [[Block]] -> State WriterState Doc
notesToOrg notes =
  mapM (\(num, note) -> noteToOrg num note) (zip [1..] notes) >>=
  return . vsep

-- | Return Org representation of a note.
noteToOrg :: Int -> [Block] -> State WriterState Doc
noteToOrg num note = do
  contents <- blockListToOrg note
  let marker = "[fn:" ++ show num ++ "] "
  return $ hang (length marker) (text marker) contents

-- | Escape special characters for Org.
escapeString :: String -> String
escapeString = escapeStringUsing $
               [ ('\x2014',"---")
               , ('\x2013',"--")
               , ('\x2019',"'")
               , ('\x2026',"...")
               ] ++ backslashEscapes "^_"

isRawFormat :: Format -> Bool
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 Null = return empty
blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do
  contents <- blockListToOrg bs
  let drawerNameTag = ":" <> text cls <> ":"
  let keys = vcat $ map (\(k,v) ->
                       ":" <> text k <> ":"
                       <> space <> text v) kvs
  let drawerEndTag = text ":END:"
  return $ drawerNameTag $$ cr $$ keys $$
           blankline $$ contents $$
           blankline $$ drawerEndTag $$
           blankline
blockToOrg (Div attrs bs) = do
  contents <- blockListToOrg bs
  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
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
  capt <- if null txt
             then return empty
             else ("#+CAPTION: " <>) `fmap` inlineListToOrg txt
  img <- inlineToOrg (Image attr txt (src,tit))
  return $ capt $$ img $$ blankline
blockToOrg (Para inlines) = do
  contents <- inlineListToOrg inlines
  return $ contents <> blankline
blockToOrg (LineBlock lns) = do
  let splitStanza [] = []
      splitStanza xs = case break (== mempty) xs of
        (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)
  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 HorizontalRule = return $ blankline $$ "--------------" $$ blankline
blockToOrg (Header level attr inlines) = do
  contents <- inlineListToOrg inlines
  let headerStr = text $ if level > 999 then " " else replicate level '*'
  let drawerStr = if attr == nullAttr
                  then empty
                  else cr <> nest (level + 1) (propertiesDrawer attr)
  return $ headerStr <> " " <> contents <> drawerStr <> blankline
blockToOrg (CodeBlock (_,classes,_) str) = do
  opts <- stOptions <$> get
  let tabstop = writerTabStop opts
  let at = map pandocLangToOrg classes `intersect` orgLangIdentifiers
  let (beg, end) = case at of
                      []    -> ("#+BEGIN_EXAMPLE", "#+END_EXAMPLE")
                      (x:_) -> ("#+BEGIN_SRC " ++ x, "#+END_SRC")
  return $ text beg $$ nest tabstop (text str) $$ text end $$ blankline
blockToOrg (BlockQuote blocks) = do
  contents <- blockListToOrg blocks
  return $ blankline $$ "#+BEGIN_QUOTE" $$
           nest 2 contents $$ "#+END_QUOTE" $$ blankline
blockToOrg (Table caption' _ _ headers rows) =  do
  caption'' <- inlineListToOrg caption'
  let caption = if null caption'
                   then empty
                   else ("#+CAPTION: " <> caption'')
  headers' <- mapM blockListToOrg headers
  rawRows <- mapM (mapM blockListToOrg) rows
  let numChars = maximum . map offset
  -- FIXME: width is not being used.
  let widthsInChars =
       map ((+2) . numChars) $ transpose (headers' : rawRows)
  -- 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 " |")
              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) $
                          map (\l -> text $ replicate l ch) widthsInChars) <>
                  char ch <> char '|'
  let body = vcat rows'
  let head'' = if all null headers
                  then empty
                  else head' $$ border '-'
  return $ head'' $$ body $$ caption $$ blankline
blockToOrg (BulletList items) = do
  contents <- mapM bulletListItemToOrg items
  -- ensure that sublists have preceding blank line
  return $ blankline $+$ vcat contents $$ blankline
blockToOrg (OrderedList (start, _, delim) items) = do
  let delim' = case delim of
                    TwoParens -> OneParen
                    x         -> x
  let markers = take (length items) $ orderedListMarkers
                                      (start, Decimal, delim')
  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
  -- ensure that sublists have preceding blank line
  return $ blankline $$ vcat contents $$ blankline
blockToOrg (DefinitionList items) = do
  contents <- mapM definitionListItemToOrg items
  return $ vcat contents $$ blankline

-- | Convert bullet list item (list of blocks) to Org.
bulletListItemToOrg :: [Block] -> State WriterState Doc
bulletListItemToOrg items = do
  contents <- blockListToOrg items
  return $ hang 2 "- " (contents <> cr)

-- | Convert ordered list item (a list of blocks) to Org.
orderedListItemToOrg :: String   -- ^ marker for list item
                     -> [Block]  -- ^ list item (list of blocks)
                     -> State WriterState 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 (label, defs) = do
  label' <- inlineListToOrg label
  contents <- liftM vcat $ mapM blockListToOrg defs
  return $ hang 2 "- " $ label' <> " :: " <> (contents <> cr)

-- | Convert list of key/value pairs to Org :PROPERTIES: drawer.
propertiesDrawer :: Attr -> Doc
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'
    properties = vcat $ map kvToOrgProperty kv''
  in
    drawerStart <> cr <> properties <> cr <> drawerEnd
 where
   kvToOrgProperty :: (String, String) -> Doc
   kvToOrgProperty (key, value) =
     text ":" <> text key <> text ": " <> text value <> cr

attrHtml :: Attr -> Doc
attrHtml (""   , []     , []) = mempty
attrHtml (ident, classes, kvs) =
  let
    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

-- | Convert list of Pandoc inline elements to Org.
inlineListToOrg :: [Inline] -> State WriterState Doc
inlineListToOrg lst = mapM inlineToOrg lst >>= return . hcat

-- | Convert Pandoc inline element to Org.
inlineToOrg :: Inline -> State WriterState Doc
inlineToOrg (Span (uid, [], []) []) =
  return $ "<<" <> text uid <> ">>"
inlineToOrg (Span _ lst) =
  inlineListToOrg lst
inlineToOrg (Emph lst) = do
  contents <- inlineListToOrg lst
  return $ "/" <> contents <> "/"
inlineToOrg (Strong lst) = do
  contents <- inlineListToOrg lst
  return $ "*" <> contents <> "*"
inlineToOrg (Strikeout lst) = do
  contents <- inlineListToOrg lst
  return $ "+" <> contents <> "+"
inlineToOrg (Superscript lst) = do
  contents <- inlineListToOrg lst
  return $ "^{" <> contents <> "}"
inlineToOrg (Subscript lst) = do
  contents <- inlineListToOrg lst
  return $ "_{" <> contents <> "}"
inlineToOrg (SmallCaps lst) = inlineListToOrg lst
inlineToOrg (Quoted SingleQuote lst) = do
  contents <- inlineListToOrg lst
  return $ "'" <> contents <> "'"
inlineToOrg (Quoted DoubleQuote lst) = do
  contents <- inlineListToOrg lst
  return $ "\"" <> contents <> "\""
inlineToOrg (Cite _  lst) = inlineListToOrg lst
inlineToOrg (Code _ str) = return $ "=" <> text 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 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
  case txt of
        [Str x] | escapeURI x == src ->  -- autolink
             do return $ "[[" <> text (orgPath x) <> "]]"
        _ -> do contents <- inlineListToOrg txt
                return $ "[[" <> text (orgPath src) <> "][" <> contents <> "]]"
inlineToOrg (Image _ _ (source, _)) = do
  return $ "[[" <> text (orgPath source) <> "]]"
inlineToOrg (Note contents) = do
  -- add to notes in state
  notes <- get >>= (return . stNotes)
  modify $ \st -> st { stNotes = contents:notes }
  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
 where
   isFilePath :: String -> Bool
   isFilePath cs = any (`isPrefixOf` cs) ["/", "./", "../", "file:"]

   isUrl :: String -> Bool
   isUrl cs =
     let (scheme, path) = break (== ':') cs
     in all (\c -> isAlphaNum c || c `elem` (".-"::String)) scheme
          && not (null path)

-- | Translate from pandoc's programming language identifiers to those used by
-- org-mode.
pandocLangToOrg :: String -> String
pandocLangToOrg cs =
  case cs of
    "c"          -> "C"
    "cpp"        -> "C++"
    "commonlisp" -> "lisp"
    "r"          -> "R"
    "bash"       -> "sh"
    _            -> cs

-- | List of language identifiers recognized by org-mode.
orgLangIdentifiers :: [String]
orgLangIdentifiers =
  [ "asymptote", "awk", "C", "C++", "clojure", "css", "d", "ditaa", "dot"
  , "calc", "emacs-lisp", "fortran", "gnuplot", "haskell", "java", "js"
  , "latex", "ledger", "lisp", "lilypond", "matlab", "mscgen", "ocaml"
  , "octave", "org", "oz", "perl", "plantuml", "processing", "python", "R"
  , "ruby", "sass", "scheme", "screen", "sed", "sh", "sql", "sqlite"
  ]