@@ -0,0 +1,426 @@
1+{-
2+Copyright (C) 2007-2015 John MacFarlane <jgm@berkeley.edu>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+
19+{- |
20+ Module : Text.Pandoc.Writers.Ms
21+ Copyright : Copyright (C) 2007-2015 John MacFarlane
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : John MacFarlane <jgm@berkeley.edu>
25+ Stability : alpha
26+ Portability : portable
27+
28+Conversion of 'Pandoc' documents to groff man page format.
29+
30+TODO:
31+
32+[ ] warning for non-rendered raw content
33+[ ] is there a better way to do strikeout?
34+[ ] strong + em doesn't seem to work
35+[ ] super + subscript don't seem to work
36+[ ] options for hyperlink rendering (currently footnote)
37+[ ] avoid note-in-note (which we currently get easily with
38+ links in footnotes)
39+[ ] can we get prettier output using .B, etc. instead of
40+ the inline forms?
41+[ ] tight/loose list distinction
42+[ ] internal hyperlinks (this seems to be possible since
43+ they exist in the groff manual PDF version)
44+[ ] use a custom macro for defn lists so they're configurable
45+[ ] better handling of accented characters and other non-ascii
46+ characters (e.g. curly quotes) -- we shouldn't rely on a
47+ utf8 compatible groff
48+[ ] avoid blank line after footnote marker when footnote has a
49+ paragraph
50+[ ] add via groff option to PDF module
51+[ ] better handling of autolinks?
52+[ ] better handling of images, perhaps converting to eps when
53+ going to PDF?
54+[ ] better template, with configurable page number, table of contents,
55+ columns, etc.
56+-}
57+
58+module Text.Pandoc.Writers.Ms ( writeMs ) where
59+import Text.Pandoc.Definition
60+import Text.Pandoc.Templates
61+import Text.Pandoc.Shared
62+import Text.Pandoc.Writers.Shared
63+import Text.Pandoc.Options
64+import Text.Pandoc.Writers.Math
65+import Text.Printf ( printf )
66+import Data.List ( stripPrefix, intersperse, intercalate )
67+import Data.Maybe (fromMaybe)
68+import Text.Pandoc.Pretty
69+import Text.Pandoc.Builder (deleteMeta)
70+import Text.Pandoc.Class (PandocMonad)
71+import Control.Monad.State
72+import Data.Char ( isDigit )
73+import Text.TeXMath (writeEqn)
74+
75+data WriterState = WriterState { stHasInlineMath :: Bool
76+ , stNotes :: [Note] }
77+type Note = [Block]
78+
79+type MS = StateT WriterState
80+
81+-- | Convert Pandoc to Ms.
82+writeMs :: PandocMonad m => WriterOptions -> Pandoc -> m String
83+writeMs opts document =
84+ evalStateT (pandocToMs opts document) (WriterState False [])
85+
86+-- | Return groff man representation of document.
87+pandocToMs :: PandocMonad m => WriterOptions -> Pandoc -> MS m String
88+pandocToMs opts (Pandoc meta blocks) = do
89+ let colwidth = if writerWrapText opts == WrapAuto
90+ then Just $ writerColumns opts
91+ else Nothing
92+ let render' = render colwidth
93+ titleText <- inlineListToMs' opts $ docTitle meta
94+ let title' = render' titleText
95+ let setFieldsFromTitle =
96+ case break (== ' ') title' of
97+ (cmdName, rest) -> case reverse cmdName of
98+ (')':d:'(':xs) | isDigit d ->
99+ defField "title" (reverse xs) .
100+ defField "section" [d] .
101+ case splitBy (=='|') rest of
102+ (ft:hds) ->
103+ defField "footer" (trim ft) .
104+ defField "header"
105+ (trim $ concat hds)
106+ [] -> id
107+ _ -> defField "title" title'
108+ metadata <- metaToJSON opts
109+ (fmap (render colwidth) . blockListToMs opts)
110+ (fmap (render colwidth) . inlineListToMs' opts)
111+ $ deleteMeta "title" meta
112+ body <- blockListToMs opts blocks
113+ let main = render' body
114+ hasInlineMath <- gets stHasInlineMath
115+ let context = defField "body" main
116+ $ setFieldsFromTitle
117+ $ defField "has-inline-math" hasInlineMath
118+ $ defField "hyphenate" True
119+ $ defField "pandoc-version" pandocVersion
120+ $ metadata
121+ case writerTemplate opts of
122+ Nothing -> return main
123+ Just tpl -> return $ renderTemplate' tpl context
124+
125+-- | Association list of characters to escape.
126+manEscapes :: [(Char, String)]
127+manEscapes = [ ('\160', "\\ ")
128+ , ('\'', "\\[aq]")
129+ , ('’', "'")
130+ , ('\x2014', "\\[em]")
131+ , ('\x2013', "\\[en]")
132+ , ('\x2026', "\\&...")
133+ , ('|', "\\[u007C]") -- because we use | for inline math
134+ ] ++ backslashEscapes "-@\\"
135+
136+-- | Escape | character, used to mark inline math, inside math.
137+escapeBar :: String -> String
138+escapeBar = concatMap go
139+ where go '|' = "\\[u007C]"
140+ go c = [c]
141+
142+-- | Escape special characters for Ms.
143+escapeString :: String -> String
144+escapeString = escapeStringUsing manEscapes
145+
146+-- | Escape a literal (code) section for Ms.
147+escapeCode :: String -> String
148+escapeCode = concat . intersperse "\n" . map escapeLine . lines where
149+ escapeLine codeline =
150+ case escapeStringUsing (manEscapes ++ backslashEscapes "\t ") codeline of
151+ a@('.':_) -> "\\&" ++ a
152+ b -> b
153+
154+-- We split inline lists into sentences, and print one sentence per
155+-- line. groff/troff treats the line-ending period differently.
156+-- See http://code.google.com/p/pandoc/issues/detail?id=148.
157+
158+-- | Returns the first sentence in a list of inlines, and the rest.
159+breakSentence :: [Inline] -> ([Inline], [Inline])
160+breakSentence [] = ([],[])
161+breakSentence xs =
162+ let isSentenceEndInline (Str ys@(_:_)) | last ys == '.' = True
163+ isSentenceEndInline (Str ys@(_:_)) | last ys == '?' = True
164+ isSentenceEndInline (LineBreak) = True
165+ isSentenceEndInline _ = False
166+ (as, bs) = break isSentenceEndInline xs
167+ in case bs of
168+ [] -> (as, [])
169+ [c] -> (as ++ [c], [])
170+ (c:Space:cs) -> (as ++ [c], cs)
171+ (c:SoftBreak:cs) -> (as ++ [c], cs)
172+ (Str ".":Str (')':ys):cs) -> (as ++ [Str ".", Str (')':ys)], cs)
173+ (x@(Str ('.':')':_)):cs) -> (as ++ [x], cs)
174+ (LineBreak:x@(Str ('.':_)):cs) -> (as ++[LineBreak], x:cs)
175+ (c:cs) -> (as ++ [c] ++ ds, es)
176+ where (ds, es) = breakSentence cs
177+
178+-- | Split a list of inlines into sentences.
179+splitSentences :: [Inline] -> [[Inline]]
180+splitSentences xs =
181+ let (sent, rest) = breakSentence xs
182+ in if null rest then [sent] else sent : splitSentences rest
183+
184+blockToMs :: PandocMonad m
185+ => WriterOptions -- ^ Options
186+ -> Block -- ^ Block element
187+ -> MS m Doc
188+blockToMs _ Null = return empty
189+blockToMs opts (Div _ bs) = blockListToMs opts bs
190+blockToMs opts (Plain inlines) =
191+ liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines
192+blockToMs opts (Para inlines) = do
193+ contents <- liftM vcat $ mapM (inlineListToMs' opts) $
194+ splitSentences inlines
195+ return $ text ".LP" $$ contents
196+blockToMs _ (RawBlock f str)
197+ | f == Format "man" = return $ text str
198+ | otherwise = return empty
199+blockToMs _ HorizontalRule = return $ text ".PP" $$ text " * * * * *"
200+blockToMs opts (Header level _ inlines) = do
201+ contents <- inlineListToMs' opts inlines
202+ let heading = if writerNumberSections opts
203+ then ".NH"
204+ else ".SH"
205+ return $ text heading <> space <> text (show level) $$ contents
206+blockToMs _ (CodeBlock _ str) = return $
207+ text ".IP" $$
208+ text ".nf" $$
209+ text "\\f[C]" $$
210+ text (escapeCode str) $$
211+ text "\\f[]" $$
212+ text ".fi"
213+blockToMs opts (LineBlock ls) = do
214+ blockToMs opts $ Para $ intercalate [LineBreak] ls
215+blockToMs opts (BlockQuote blocks) = do
216+ contents <- blockListToMs opts blocks
217+ return $ text ".RS" $$ contents $$ text ".RE"
218+blockToMs opts (Table caption alignments widths headers rows) =
219+ let aligncode AlignLeft = "l"
220+ aligncode AlignRight = "r"
221+ aligncode AlignCenter = "c"
222+ aligncode AlignDefault = "l"
223+ in do
224+ caption' <- inlineListToMs' opts caption
225+ let iwidths = if all (== 0) widths
226+ then repeat ""
227+ else map (printf "w(%0.1fn)" . (70 *)) widths
228+ -- 78n default width - 8n indent = 70n
229+ let coldescriptions = text $ intercalate " "
230+ (zipWith (\align width -> aligncode align ++ width)
231+ alignments iwidths) ++ "."
232+ colheadings <- mapM (blockListToMs opts) headers
233+ let makeRow cols = text "T{" $$
234+ (vcat $ intersperse (text "T}@T{") cols) $$
235+ text "T}"
236+ let colheadings' = if all null headers
237+ then empty
238+ else makeRow colheadings $$ char '_'
239+ body <- mapM (\row -> do
240+ cols <- mapM (blockListToMs opts) row
241+ return $ makeRow cols) rows
242+ return $ text ".PP" $$ caption' $$
243+ text ".TS" $$ text "tab(@);" $$ coldescriptions $$
244+ colheadings' $$ vcat body $$ text ".TE"
245+
246+blockToMs opts (BulletList items) = do
247+ contents <- mapM (bulletListItemToMs opts) items
248+ return (vcat contents)
249+blockToMs opts (OrderedList attribs items) = do
250+ let markers = take (length items) $ orderedListMarkers attribs
251+ let indent = 1 + (maximum $ map length markers)
252+ contents <- mapM (\(num, item) -> orderedListItemToMs opts num indent item) $
253+ zip markers items
254+ return (vcat contents)
255+blockToMs opts (DefinitionList items) = do
256+ contents <- mapM (definitionListItemToMs opts) items
257+ return (vcat contents)
258+
259+-- | Convert bullet list item (list of blocks) to man.
260+bulletListItemToMs :: PandocMonad m => WriterOptions -> [Block] -> MS m Doc
261+bulletListItemToMs _ [] = return empty
262+bulletListItemToMs opts ((Para first):rest) =
263+ bulletListItemToMs opts ((Plain first):rest)
264+bulletListItemToMs opts ((Plain first):rest) = do
265+ first' <- blockToMs opts (Plain first)
266+ rest' <- blockListToMs opts rest
267+ let first'' = text ".IP \\[bu] 2" $$ first'
268+ let rest'' = if null rest
269+ then empty
270+ else text ".RS 2" $$ rest' $$ text ".RE"
271+ return (first'' $$ rest'')
272+bulletListItemToMs opts (first:rest) = do
273+ first' <- blockToMs opts first
274+ rest' <- blockListToMs opts rest
275+ return $ text "\\[bu] .RS 2" $$ first' $$ rest' $$ text ".RE"
276+
277+-- | Convert ordered list item (a list of blocks) to man.
278+orderedListItemToMs :: PandocMonad m
279+ => WriterOptions -- ^ options
280+ -> String -- ^ order marker for list item
281+ -> Int -- ^ number of spaces to indent
282+ -> [Block] -- ^ list item (list of blocks)
283+ -> MS m Doc
284+orderedListItemToMs _ _ _ [] = return empty
285+orderedListItemToMs opts num indent ((Para first):rest) =
286+ orderedListItemToMs opts num indent ((Plain first):rest)
287+orderedListItemToMs opts num indent (first:rest) = do
288+ first' <- blockToMs opts first
289+ rest' <- blockListToMs opts rest
290+ let num' = printf ("%" ++ show (indent - 1) ++ "s") num
291+ let first'' = text (".IP \"" ++ num' ++ "\" " ++ show indent) $$ first'
292+ let rest'' = if null rest
293+ then empty
294+ else text ".RS 4" $$ rest' $$ text ".RE"
295+ return $ first'' $$ rest''
296+
297+-- | Convert definition list item (label, list of blocks) to man.
298+definitionListItemToMs :: PandocMonad m
299+ => WriterOptions
300+ -> ([Inline],[[Block]])
301+ -> MS m Doc
302+definitionListItemToMs opts (label, defs) = do
303+ labelText <- inlineListToMs' opts label
304+ contents <- if null defs
305+ then return empty
306+ else liftM vcat $ forM defs $ \blocks -> do
307+ let (first, rest) = case blocks of
308+ ((Para x):y) -> (Plain x,y)
309+ (x:y) -> (x,y)
310+ [] -> error "blocks is null"
311+ rest' <- liftM vcat $
312+ mapM (\item -> blockToMs opts item) rest
313+ first' <- blockToMs opts first
314+ return $ first' $$ text ".RS" $$ rest' $$ text ".RE"
315+ return $ text ".XP" $$ nowrap (text ".B \"" <> labelText <> text "\"")
316+ $$ text "\\~\\~" <> contents
317+
318+-- | Convert list of Pandoc block elements to man.
319+blockListToMs :: PandocMonad m
320+ => WriterOptions -- ^ Options
321+ -> [Block] -- ^ List of block elements
322+ -> MS m Doc
323+blockListToMs opts blocks =
324+ mapM (blockToMs opts) blocks >>= (return . vcat)
325+
326+-- | Convert list of Pandoc inline elements to ms.
327+inlineListToMs :: PandocMonad m => WriterOptions -> [Inline] -> MS m Doc
328+-- if list starts with ., insert a zero-width character \& so it
329+-- won't be interpreted as markup if it falls at the beginning of a line.
330+inlineListToMs opts lst@(Str ('.':_) : _) = mapM (inlineToMs opts) lst >>=
331+ (return . (text "\\&" <>) . hcat)
332+inlineListToMs opts lst = hcat <$> mapM (inlineToMs opts) lst
333+
334+-- This version to be used when there is no further inline content;
335+-- forces a note at the end.
336+inlineListToMs' :: PandocMonad m => WriterOptions -> [Inline] -> MS m Doc
337+inlineListToMs' opts lst = do
338+ x <- hcat <$> mapM (inlineToMs opts) lst
339+ y <- handleNotes opts empty
340+ return $ x <> y
341+
342+-- | Convert Pandoc inline element to man.
343+inlineToMs :: PandocMonad m => WriterOptions -> Inline -> MS m Doc
344+inlineToMs opts (Span _ ils) = inlineListToMs opts ils
345+inlineToMs opts (Emph lst) = do
346+ contents <- inlineListToMs opts lst
347+ return $ text "\\f[I]" <> contents <> text "\\f[]"
348+inlineToMs opts (Strong lst) = do
349+ contents <- inlineListToMs opts lst
350+ return $ text "\\f[B]" <> contents <> text "\\f[]"
351+inlineToMs opts (Strikeout lst) = do
352+ contents <- inlineListToMs opts lst
353+ return $ text "[STRIKEOUT:" <> contents <> char ']'
354+inlineToMs opts (Superscript lst) = do
355+ contents <- inlineListToMs opts lst
356+ return $ char '^' <> contents <> char '^'
357+inlineToMs opts (Subscript lst) = do
358+ contents <- inlineListToMs opts lst
359+ return $ char '~' <> contents <> char '~'
360+inlineToMs opts (SmallCaps lst) = inlineListToMs opts lst -- not supported
361+inlineToMs opts (Quoted SingleQuote lst) = do
362+ contents <- inlineListToMs opts lst
363+ return $ char '`' <> contents <> char '\''
364+inlineToMs opts (Quoted DoubleQuote lst) = do
365+ contents <- inlineListToMs opts lst
366+ return $ text "\\[lq]" <> contents <> text "\\[rq]"
367+inlineToMs opts (Cite _ lst) =
368+ inlineListToMs opts lst
369+inlineToMs _ (Code _ str) =
370+ return $ text $ "\\f[C]" ++ escapeCode str ++ "\\f[]"
371+inlineToMs _ (Str str) = return $ text $ escapeString str
372+inlineToMs opts (Math InlineMath str) = do
373+ modify $ \st -> st{ stHasInlineMath = True }
374+ res <- convertMath writeEqn InlineMath str
375+ case res of
376+ Left il -> inlineToMs opts il
377+ Right r -> return $ text "|" <> text (escapeBar r) <> text "|"
378+inlineToMs opts (Math DisplayMath str) = do
379+ res <- convertMath writeEqn InlineMath str
380+ case res of
381+ Left il -> do
382+ contents <- inlineToMs opts il
383+ return $ cr <> text ".RS" $$ contents $$ text ".RE"
384+ Right r -> return $
385+ cr <> text ".EQ" $$ text (escapeBar r) $$ text ".EN"
386+inlineToMs _ (RawInline f str)
387+ | f == Format "man" = return $ text str
388+ | otherwise = return empty
389+inlineToMs _ (LineBreak) = return $
390+ cr <> text ".PD 0" $$ text ".P" $$ text ".PD" <> cr
391+inlineToMs opts SoftBreak = handleNotes opts cr
392+inlineToMs opts Space = handleNotes opts space
393+inlineToMs opts (Link _ txt (src, _)) = do
394+ let srcSuffix = fromMaybe src (stripPrefix "mailto:" src)
395+ case txt of
396+ [Str s]
397+ | escapeURI s == srcSuffix ->
398+ return $ char '<' <> text srcSuffix <> char '>'
399+ _ -> do
400+ let linknote = [Plain [Str src]]
401+ inlineListToMs opts (txt ++ [Note linknote])
402+inlineToMs opts (Image attr alternate (source, tit)) = do
403+ let txt = if (null alternate) || (alternate == [Str ""]) ||
404+ (alternate == [Str source]) -- to prevent autolinks
405+ then [Str "image"]
406+ else alternate
407+ linkPart <- inlineToMs opts (Link attr txt (source, tit))
408+ return $ char '[' <> text "IMAGE: " <> linkPart <> char ']'
409+inlineToMs _ (Note contents) = do
410+ modify $ \st -> st{ stNotes = contents : stNotes st }
411+ return $ text "\\**"
412+
413+handleNotes :: PandocMonad m => WriterOptions -> Doc -> MS m Doc
414+handleNotes opts fallback = do
415+ notes <- gets stNotes
416+ if null notes
417+ then return fallback
418+ else do
419+ modify $ \st -> st{ stNotes = [] }
420+ vcat <$> mapM (handleNote opts) notes
421+
422+handleNote :: PandocMonad m => WriterOptions -> Note -> MS m Doc
423+handleNote opts bs = do
424+ contents <- blockListToMs opts bs
425+ return $ cr <> text ".FS" $$ contents $$ text ".FE" <> cr
426+