Added groff man writer.

git-svn-id: https://pandoc.googlecode.com/svn/trunk@606 788f1e2b-df1e-0410-8736-df70ead52e1b

src/Text/Pandoc/Writers/Man.hs

@@ -0,0 +1,263 @@
+{-
+Copyright (C) 2006 John MacFarlane <jgm at berkeley dot 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.Man 
+   Copyright   : Copyright (C) 2006 John MacFarlane
+   License     : GNU GPL, version 2 or above 
+
+   Maintainer  : John MacFarlane <jgm at berkeley dot edu>
+   Stability   : alpha
+   Portability : portable
+
+Conversion of 'Pandoc' documents to groff man page format.
+
+-}
+module Text.Pandoc.Writers.Man (
+                                     writeMan
+                                    ) where
+import Text.Pandoc.Definition
+import Text.Pandoc.Shared 
+import Data.Char ( toUpper )
+import Data.List ( group, isPrefixOf, drop, find )
+import Text.PrettyPrint.HughesPJ hiding ( Str )
+import Control.Monad.State
+
+type Notes = [[Block]]
+type WriterState = Notes
+
+-- | Convert Pandoc to Man.
+writeMan :: WriterOptions -> Pandoc -> String
+writeMan opts document = 
+  render $ evalState (pandocToMan opts document) [] 
+
+-- | Return groff man representation of document.
+pandocToMan :: WriterOptions -> Pandoc -> State WriterState Doc
+pandocToMan opts (Pandoc meta blocks) = do
+  let before  = writerIncludeBefore opts
+  let after   = writerIncludeAfter opts
+      before' = if null before then empty else text before
+      after'  = if null after then empty else text after
+  (head, foot) <- metaToMan opts meta
+  body <- blockListToMan opts blocks
+  notes <- get
+  notes' <- notesToMan opts (reverse notes)
+  return $ head $$ before' $$ body $$ notes' $$ foot $$ after'
+
+-- | Insert bibliographic information into Man header and footer.
+metaToMan :: WriterOptions -- ^ Options, including Man header
+          -> Meta          -- ^ Meta with bibliographic information
+          -> State WriterState (Doc, Doc)
+metaToMan options (Meta title authors date) = do
+  title' <- inlineListToMan options title
+  let head = (text ".TH \"") <> title' <> text ("\" 1 \"" ++ date ++ 
+             "\" \"") <> title' <> text ("\" \"User Manuals\"")
+  let foot = case length authors of
+                0 -> text $ ""
+                1 -> text $ ".SH AUTHOR\n" ++ joinWithSep "\n" authors
+                2 -> text $ ".SH AUTHORS\n" ++ joinWithSep "\n" authors
+  return $ if writerStandalone options
+     then (head, foot)
+     else (empty, empty)
+
+-- | Return man representation of notes.
+notesToMan :: WriterOptions -> [[Block]] -> State WriterState Doc
+notesToMan opts notes =
+  if null notes
+     then return empty
+     else mapM (\(num, note) -> noteToMan opts num note) (zip [1..] notes) >>= 
+          (return . (text ".SH NOTES\n" <>) . vcat)
+
+-- | Return man representation of a note.
+noteToMan :: WriterOptions -> Int -> [Block] -> State WriterState Doc
+noteToMan opts num note = do
+  contents <- blockListToMan opts note
+  let marker = text "\n.SS [" <> text (show num) <> text "]"
+  return $ marker $$ contents 
+
+wrappedMan :: WriterOptions -> [Inline] -> State WriterState Doc
+wrappedMan opts sect = do
+  let chunks = splitBy Space sect
+  chunks' <- mapM (inlineListToMan opts) chunks
+  return $ fsep chunks'
+
+-- | Escape nonbreaking space as \  
+escapeNbsp "" = ""
+escapeNbsp ('\160':xs) = "\\ " ++ escapeNbsp xs
+escapeNbsp str = 
+  let (a,b) = break (=='\160') str in
+  a ++ escapeNbsp b
+
+-- | Escape special characters for Man.
+escapeString :: String -> String
+escapeString = escapeNbsp . backslashEscape "-\\"
+
+-- | Escape a literal (code) section for Man.
+escapeCode :: String -> String
+escapeCode = backslashEscape "-\\\t "
+
+-- | Convert Pandoc block element to man.
+blockToMan :: WriterOptions -- ^ Options
+                -> Block         -- ^ Block element
+                -> State WriterState Doc 
+blockToMan opts Null = return empty
+blockToMan opts (Plain inlines) = wrappedMan opts inlines
+blockToMan opts (Para inlines) = do
+  contents <- wrappedMan opts inlines
+  return $ text "\n.PP" $$ contents 
+blockToMan opts (RawHtml str) = return $ text str
+blockToMan opts HorizontalRule = return $ text $ "\n.PP\n" ++ "   *   *   *   *   *"
+blockToMan opts (Header level inlines) = do
+  contents <- inlineListToMan opts inlines
+  let heading = case level of
+                  1 -> "\n.SH "
+                  _ -> "\n.SS "
+  return $ text heading <> contents 
+blockToMan opts (CodeBlock str) = return $
+  text "\n\\f[B]" $$ text ((unlines . map ("      " ++) . lines) (escapeCode str)) <> 
+  text "\\f[]"
+blockToMan opts (BlockQuote blocks) = do  
+  contents <- blockListToMan opts blocks
+  return $ text "\n.RS" $$ contents $$ text "\n.RE"
+blockToMan opts (Table caption _ _ headers rows) = blockToMan opts 
+  (Para [Str "pandoc: TABLE unsupported in Man writer"])
+
+blockToMan opts (BulletList items) = do
+  contents <- mapM (bulletListItemToMan opts) items
+  return (vcat contents) 
+blockToMan opts (OrderedList items) = do
+  contents <- mapM (\(item, num) -> orderedListItemToMan opts item num) $
+              zip [1..] items  
+  return (vcat contents)
+blockToMan opts (DefinitionList items) = do  
+  contents <- mapM (definitionListItemToMan opts) items
+  return (vcat contents)
+
+-- | Convert bullet list item (list of blocks) to man.
+bulletListItemToMan :: WriterOptions -> [Block] -> State WriterState Doc
+bulletListItemToMan opts [] = return empty
+bulletListItemToMan opts ((Para first):rest) = 
+  bulletListItemToMan opts ((Plain first):rest)
+bulletListItemToMan opts ((Plain first):rest) = do
+  first' <- blockToMan opts (Plain first) 
+  rest' <- blockListToMan opts rest
+  let first'' = text "\n.IP \\[bu] 2" $$ first'
+  let rest''  = if null rest
+                   then empty
+                   else text "\n.RS 2" $$ rest' $$ text "\n.RE"
+  return (first'' $$ rest'') 
+bulletListItemToMan opts (first:rest) = do
+  first' <- blockToMan opts first
+  rest' <- blockListToMan opts rest
+  return $ text "\n\\[bu] \n.RS 2" $$ first' $$ rest' $$ text "\n.RE"
+ 
+-- | Convert ordered list item (a list of blocks) to man.
+orderedListItemToMan :: WriterOptions -- ^ options
+                          -> Int           -- ^ ordinal number of list item
+                          -> [Block]       -- ^ list item (list of blocks)
+                          -> State WriterState Doc
+orderedListItemToMan _ _ [] = return empty
+orderedListItemToMan opts num ((Para first):rest) = 
+  orderedListItemToMan opts num ((Plain first):rest)
+orderedListItemToMan opts num ((Plain first):rest) = do
+  first' <- blockToMan opts (Plain first) 
+  rest' <- blockListToMan opts rest
+  let first'' = text ("\n.IP " ++ show num ++ "." ++ " 4") $$ first'
+  let rest''  = if null rest
+                   then text "\n"
+                   else text "\n.RS 4" $$ rest' $$ text "\n.RE"
+  return (first'' $$ rest'') 
+orderedListItemToMan opts num (first:rest) = do
+  first' <- blockToMan opts first
+  rest' <- blockListToMan opts rest
+  return $ text ("\n.IP " ++ show num ++ "." ++ " 4") $$ first' $$ 
+           rest' $$ text "\n.RE"
+
+-- | Convert definition list item (label, list of blocks) to man.
+definitionListItemToMan :: WriterOptions
+                             -> ([Inline],[Block]) 
+                             -> State WriterState Doc
+definitionListItemToMan opts (label, items) = do
+  labelText <- inlineListToMan opts label
+  contents <- if null items
+                 then return empty
+                 else do 
+                        let (first, rest) = case items of
+                             ((Para x):y) -> (Plain x,y)
+                             (x:y)        -> (x,y)
+                        rest' <- mapM (\item -> blockToMan opts item)
+                                 rest >>= (return . vcat)
+                        first' <- blockToMan opts first
+                        return $ first' $$ text "\n.RS" $$ rest' $$ text "\n.RE"
+  return $ text "\n.TP\n.B " <> labelText $+$ contents
+
+-- | Convert list of Pandoc block elements to man.
+blockListToMan :: WriterOptions -- ^ Options
+                    -> [Block]       -- ^ List of block elements
+                    -> State WriterState Doc 
+blockListToMan opts blocks =
+  mapM (blockToMan opts) blocks >>= (return . vcat)
+
+-- | Convert list of Pandoc inline elements to man.
+inlineListToMan :: WriterOptions -> [Inline] -> State WriterState Doc
+inlineListToMan opts lst = mapM (inlineToMan opts) lst >>= (return . hcat)
+
+-- | Convert Pandoc inline element to man.
+inlineToMan :: WriterOptions -> Inline -> State WriterState Doc
+inlineToMan opts (Emph lst) = do 
+  contents <- inlineListToMan opts lst
+  return $ text "\\f[I]" <> contents <> text "\\f[]"
+inlineToMan opts (Strong lst) = do
+  contents <- inlineListToMan opts lst
+  return $ text "\\f[B]" <> contents <> text "\\f[]"
+inlineToMan opts (Quoted SingleQuote lst) = do
+  contents <- inlineListToMan opts lst
+  return $ char '`' <> contents <> char '\''
+inlineToMan opts (Quoted DoubleQuote lst) = do
+  contents <- inlineListToMan opts lst
+  return $ text "\\[lq]" <> contents <> text "\\[rq]"
+inlineToMan opts EmDash = return $ text "\\[em]"
+inlineToMan opts EnDash = return $ text "\\[en]"
+inlineToMan opts Apostrophe = return $ char '\''
+inlineToMan opts Ellipses = return $ text "\\&..."
+inlineToMan opts (Code str) =
+  return $ text $ "\\f[B]" ++ escapeCode str ++ "\\f[]"
+inlineToMan opts (Str str) = return $ text $ escapeString str
+inlineToMan opts (TeX str) = return $ text $ escapeCode str
+inlineToMan opts (HtmlInline str) = return $ text $ escapeCode str 
+inlineToMan opts (LineBreak) = return $ text "\n.P\n"
+inlineToMan opts Space = return $ char ' '
+inlineToMan opts (Link txt (src, _)) = do
+  linktext <- inlineListToMan opts txt
+  let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src
+  return $ if txt == [Str srcSuffix]
+              then char '<' <> text srcSuffix <> char '>' 
+              else linktext <> text " (" <> text src <> char ')' 
+inlineToMan opts (Image alternate (source, tit)) = do
+  let txt = if (null alternate) || (alternate == [Str ""]) || 
+               (alternate == [Str source]) -- to prevent autolinks
+               then [Str "image"]
+               else alternate
+  linkPart <- inlineToMan opts (Link txt (source, tit)) 
+  return $ char '[' <> text "IMAGE: " <> linkPart <> char ']'
+inlineToMan opts (Note contents) = do 
+  modify (\notes -> contents:notes) -- add to notes in state
+  notes <- get
+  let ref = show $ (length notes)
+  return $ text "[^" <> text ref <> char ']'
+