@@ -0,0 +1,357 @@
1+{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-}
2+{-
3+Copyright (C) 2014 John MacFarlane <jgm@berkeley.edu>
4+
5+This program is free software; you can redistribute it and/or modify
6+it under the terms of the GNU General Public License as published by
7+the Free Software Foundation; either version 2 of the License, or
8+(at your option) any later version.
9+
10+This program is distributed in the hope that it will be useful,
11+but WITHOUT ANY WARRANTY; without even the implied warranty of
12+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+GNU General Public License for more details.
14+
15+You should have received a copy of the GNU General Public License
16+along with this program; if not, write to the Free Software
17+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18+-}
19+
20+{- |
21+ Module : Text.Pandoc.Writers.Haddock
22+ Copyright : Copyright (C) 2014 John MacFarlane
23+ License : GNU GPL, version 2 or above
24+
25+ Maintainer : John MacFarlane <jgm@berkeley.edu>
26+ Stability : alpha
27+ Portability : portable
28+
29+Conversion of 'Pandoc' documents to haddock markup.
30+
31+Haddock: <http://www.haskell.org/haddock/doc/html/>
32+-}
33+module Text.Pandoc.Writers.Haddock (writeHaddock) where
34+import Text.Pandoc.Definition
35+import Text.Pandoc.Templates (renderTemplate')
36+import Text.Pandoc.Shared
37+import Text.Pandoc.Writers.Shared
38+import Text.Pandoc.Options
39+import Data.List ( intersperse, transpose )
40+import Text.Pandoc.Pretty
41+import Control.Monad.State
42+import Text.Pandoc.Readers.TeXMath (readTeXMath')
43+import Network.URI (isURI)
44+import Data.Default
45+
46+type Notes = [[Block]]
47+data WriterState = WriterState { stNotes :: Notes }
48+instance Default WriterState
49+ where def = WriterState{ stNotes = [] }
50+
51+-- | Convert Pandoc to Haddock.
52+writeHaddock :: WriterOptions -> Pandoc -> String
53+writeHaddock opts document =
54+ evalState (pandocToHaddock opts{
55+ writerWrapText = writerWrapText opts } document) def
56+
57+-- | Return haddock representation of document.
58+pandocToHaddock :: WriterOptions -> Pandoc -> State WriterState String
59+pandocToHaddock opts (Pandoc meta blocks) = do
60+ let colwidth = if writerWrapText opts
61+ then Just $ writerColumns opts
62+ else Nothing
63+ body <- blockListToHaddock opts blocks
64+ st <- get
65+ notes' <- notesToHaddock opts (reverse $ stNotes st)
66+ let render' :: Doc -> String
67+ render' = render colwidth
68+ let main = render' $ body <>
69+ (if isEmpty notes' then empty else blankline <> notes')
70+ metadata <- metaToJSON opts
71+ (fmap (render colwidth) . blockListToHaddock opts)
72+ (fmap (render colwidth) . inlineListToHaddock opts)
73+ meta
74+ let context = defField "body" main
75+ $ metadata
76+ if writerStandalone opts
77+ then return $ renderTemplate' (writerTemplate opts) context
78+ else return main
79+
80+-- | Return haddock representation of notes.
81+notesToHaddock :: WriterOptions -> [[Block]] -> State WriterState Doc
82+notesToHaddock opts notes =
83+ mapM (\(num, note) -> noteToHaddock opts num note) (zip [1..] notes) >>=
84+ return . vsep
85+
86+-- | Return haddock representation of a note.
87+noteToHaddock :: WriterOptions -> Int -> [Block] -> State WriterState Doc
88+noteToHaddock opts num blocks = do
89+ contents <- blockListToHaddock opts blocks
90+ let num' = text $ writerIdentifierPrefix opts ++ show num
91+ let marker = text "[" <> num' <> text "]"
92+ let markerSize = 4 + offset num'
93+ let spacer = case writerTabStop opts - markerSize of
94+ n | n > 0 -> text $ replicate n ' '
95+ _ -> text " "
96+ return $ if isEnabled Ext_footnotes opts
97+ then hang (writerTabStop opts) (marker <> spacer) contents
98+ else marker <> spacer <> contents
99+
100+-- | Escape special characters for Haddock.
101+escapeString :: String -> String
102+escapeString = escapeStringUsing haddockEscapes
103+ where haddockEscapes = backslashEscapes "\\/'`\"@<"
104+
105+-- | Convert Pandoc block element to haddock.
106+blockToHaddock :: WriterOptions -- ^ Options
107+ -> Block -- ^ Block element
108+ -> State WriterState Doc
109+blockToHaddock _ Null = return empty
110+blockToHaddock opts (Div _ ils) = do
111+ contents <- blockListToHaddock opts ils
112+ return $ contents <> blankline
113+blockToHaddock opts (Plain inlines) = do
114+ contents <- inlineListToHaddock opts inlines
115+ return $ contents <> cr
116+-- title beginning with fig: indicates figure
117+blockToHaddock opts (Para [Image alt (src,'f':'i':'g':':':tit)]) =
118+ blockToHaddock opts (Para [Image alt (src,tit)])
119+blockToHaddock opts (Para inlines) =
120+ -- TODO: if it contains linebreaks, we need to use a @...@ block
121+ (<> blankline) `fmap` blockToHaddock opts (Plain inlines)
122+blockToHaddock _ (RawBlock f str)
123+ | f == "haddock" = do
124+ return $ text str <> text "\n"
125+ | otherwise = return empty
126+blockToHaddock _ HorizontalRule =
127+ return $ blankline <> text "--------------" <> blankline
128+blockToHaddock opts (Header level (ident,_,_) inlines) = do
129+ contents <- inlineListToHaddock opts inlines
130+ let attr' = if null ident
131+ then empty
132+ else cr <> text "#" <> text ident <> text "#"
133+ return $ nowrap (text (replicate level '=') <> space <> contents)
134+ <> attr' <> blankline
135+blockToHaddock _ (CodeBlock (_,_,_) str) =
136+ return $ prefixed "> " (text str) <> blankline
137+-- Nothing in haddock corresponds to block quotes:
138+blockToHaddock opts (BlockQuote blocks) =
139+ blockListToHaddock opts blocks
140+-- Haddock doesn't have tables. Use haddock tables in code.
141+blockToHaddock opts (Table caption aligns widths headers rows) = do
142+ caption' <- inlineListToHaddock opts caption
143+ let caption'' = if null caption || not (isEnabled Ext_table_captions opts)
144+ then empty
145+ else blankline <> caption' <> blankline
146+ rawHeaders <- mapM (blockListToHaddock opts) headers
147+ rawRows <- mapM (mapM (blockListToHaddock opts)) rows
148+ let isSimple = all (==0) widths
149+ let isPlainBlock (Plain _) = True
150+ isPlainBlock _ = False
151+ let hasBlocks = not (all isPlainBlock $ concat . concat $ headers:rows)
152+ (nst,tbl) <- case True of
153+ _ | isSimple -> fmap (nest 2,) $
154+ pandocTable opts (all null headers) aligns widths
155+ rawHeaders rawRows
156+ | not hasBlocks -> fmap (nest 2,) $
157+ pandocTable opts (all null headers) aligns widths
158+ rawHeaders rawRows
159+ | otherwise -> fmap (id,) $
160+ gridTable opts (all null headers) aligns widths
161+ rawHeaders rawRows
162+ return $ prefixed "> " $ nst $ tbl $$ blankline $$ caption'' $$ blankline
163+blockToHaddock opts (BulletList items) = do
164+ contents <- mapM (bulletListItemToHaddock opts) items
165+ return $ cat contents <> blankline
166+blockToHaddock opts (OrderedList (start,sty,delim) items) = do
167+ let attribs = (start, sty, delim)
168+ let markers = orderedListMarkers attribs
169+ let markers' = map (\m -> if length m < 3
170+ then m ++ replicate (3 - length m) ' '
171+ else m) markers
172+ contents <- mapM (\(item, num) -> orderedListItemToHaddock opts item num) $
173+ zip markers' items
174+ return $ cat contents <> blankline
175+blockToHaddock opts (DefinitionList items) = do
176+ contents <- mapM (definitionListItemToHaddock opts) items
177+ return $ cat contents <> blankline
178+
179+pandocTable :: WriterOptions -> Bool -> [Alignment] -> [Double]
180+ -> [Doc] -> [[Doc]] -> State WriterState Doc
181+pandocTable opts headless aligns widths rawHeaders rawRows = do
182+ let isSimple = all (==0) widths
183+ let alignHeader alignment = case alignment of
184+ AlignLeft -> lblock
185+ AlignCenter -> cblock
186+ AlignRight -> rblock
187+ AlignDefault -> lblock
188+ let numChars = maximum . map offset
189+ let widthsInChars = if isSimple
190+ then map ((+2) . numChars)
191+ $ transpose (rawHeaders : rawRows)
192+ else map
193+ (floor . (fromIntegral (writerColumns opts) *))
194+ widths
195+ let makeRow = hcat . intersperse (lblock 1 (text " ")) .
196+ (zipWith3 alignHeader aligns widthsInChars)
197+ let rows' = map makeRow rawRows
198+ let head' = makeRow rawHeaders
199+ let maxRowHeight = maximum $ map height (head':rows')
200+ let underline = cat $ intersperse (text " ") $
201+ map (\width -> text (replicate width '-')) widthsInChars
202+ let border = if maxRowHeight > 1
203+ then text (replicate (sum widthsInChars +
204+ length widthsInChars - 1) '-')
205+ else if headless
206+ then underline
207+ else empty
208+ let head'' = if headless
209+ then empty
210+ else border <> cr <> head'
211+ let body = if maxRowHeight > 1
212+ then vsep rows'
213+ else vcat rows'
214+ let bottom = if headless
215+ then underline
216+ else border
217+ return $ head'' $$ underline $$ body $$ bottom
218+
219+gridTable :: WriterOptions -> Bool -> [Alignment] -> [Double]
220+ -> [Doc] -> [[Doc]] -> State WriterState Doc
221+gridTable opts headless _aligns widths headers' rawRows = do
222+ let numcols = length headers'
223+ let widths' = if all (==0) widths
224+ then replicate numcols (1.0 / fromIntegral numcols)
225+ else widths
226+ let widthsInChars = map (floor . (fromIntegral (writerColumns opts) *)) widths'
227+ let hpipeBlocks blocks = hcat [beg, middle, end]
228+ where h = maximum (map height blocks)
229+ sep' = lblock 3 $ vcat (map text $ replicate h " | ")
230+ beg = lblock 2 $ vcat (map text $ replicate h "| ")
231+ end = lblock 2 $ vcat (map text $ replicate h " |")
232+ middle = chomp $ hcat $ intersperse sep' blocks
233+ let makeRow = hpipeBlocks . zipWith lblock widthsInChars
234+ let head' = makeRow headers'
235+ let rows' = map (makeRow . map chomp) rawRows
236+ let border ch = char '+' <> char ch <>
237+ (hcat $ intersperse (char ch <> char '+' <> char ch) $
238+ map (\l -> text $ replicate l ch) widthsInChars) <>
239+ char ch <> char '+'
240+ let body = vcat $ intersperse (border '-') rows'
241+ let head'' = if headless
242+ then empty
243+ else head' $$ border '='
244+ return $ border '-' $$ head'' $$ body $$ border '-'
245+
246+-- | Convert bullet list item (list of blocks) to haddock
247+bulletListItemToHaddock :: WriterOptions -> [Block] -> State WriterState Doc
248+bulletListItemToHaddock opts items = do
249+ contents <- blockListToHaddock opts items
250+ let sps = replicate (writerTabStop opts - 2) ' '
251+ let start = text ('-' : ' ' : sps)
252+ -- remove trailing blank line if it is a tight list
253+ let contents' = case reverse items of
254+ (BulletList xs:_) | isTightList xs ->
255+ chomp contents <> cr
256+ (OrderedList _ xs:_) | isTightList xs ->
257+ chomp contents <> cr
258+ _ -> contents
259+ return $ hang (writerTabStop opts) start $ contents' <> cr
260+
261+-- | Convert ordered list item (a list of blocks) to haddock
262+orderedListItemToHaddock :: WriterOptions -- ^ options
263+ -> String -- ^ list item marker
264+ -> [Block] -- ^ list item (list of blocks)
265+ -> State WriterState Doc
266+orderedListItemToHaddock opts marker items = do
267+ contents <- blockListToHaddock opts items
268+ let sps = case length marker - writerTabStop opts of
269+ n | n > 0 -> text $ replicate n ' '
270+ _ -> text " "
271+ let start = text marker <> sps
272+ return $ hang (writerTabStop opts) start $ contents <> cr
273+
274+-- | Convert definition list item (label, list of blocks) to haddock
275+definitionListItemToHaddock :: WriterOptions
276+ -> ([Inline],[[Block]])
277+ -> State WriterState Doc
278+definitionListItemToHaddock opts (label, defs) = do
279+ labelText <- inlineListToHaddock opts label
280+ defs' <- mapM (mapM (blockToHaddock opts)) defs
281+ let contents = vcat $ map (\d -> hang 4 empty $ vcat d <> cr) defs'
282+ return $ nowrap (brackets labelText) <> cr <> contents <> cr
283+
284+-- | Convert list of Pandoc block elements to haddock
285+blockListToHaddock :: WriterOptions -- ^ Options
286+ -> [Block] -- ^ List of block elements
287+ -> State WriterState Doc
288+blockListToHaddock opts blocks =
289+ mapM (blockToHaddock opts) blocks >>= return . cat
290+
291+-- | Convert list of Pandoc inline elements to haddock.
292+inlineListToHaddock :: WriterOptions -> [Inline] -> State WriterState Doc
293+inlineListToHaddock opts lst =
294+ mapM (inlineToHaddock opts) lst >>= return . cat
295+
296+-- | Convert Pandoc inline element to haddock.
297+inlineToHaddock :: WriterOptions -> Inline -> State WriterState Doc
298+inlineToHaddock opts (Span (ident,_,_) ils) = do
299+ contents <- inlineListToHaddock opts ils
300+ if not (null ident) && null ils
301+ then return $ "#" <> text ident <> "#"
302+ else return contents
303+inlineToHaddock opts (Emph lst) = do
304+ contents <- inlineListToHaddock opts lst
305+ return $ "/" <> contents <> "/"
306+inlineToHaddock opts (Strong lst) = do
307+ contents <- inlineListToHaddock opts lst
308+ return $ "__" <> contents <> "__"
309+inlineToHaddock opts (Strikeout lst) = do
310+ contents <- inlineListToHaddock opts lst
311+ -- not supported in haddock, but we fake it:
312+ return $ "~~" <> contents <> "~~"
313+-- not supported in haddock:
314+inlineToHaddock opts (Superscript lst) = inlineListToHaddock opts lst
315+-- not supported in haddock:
316+inlineToHaddock opts (Subscript lst) = inlineListToHaddock opts lst
317+-- not supported in haddock:
318+inlineToHaddock opts (SmallCaps lst) = inlineListToHaddock opts lst
319+inlineToHaddock opts (Quoted SingleQuote lst) = do
320+ contents <- inlineListToHaddock opts lst
321+ return $ "‘" <> contents <> "’"
322+inlineToHaddock opts (Quoted DoubleQuote lst) = do
323+ contents <- inlineListToHaddock opts lst
324+ return $ "“" <> contents <> "”"
325+inlineToHaddock _ (Code _ str) =
326+ return $ "@" <> text (escapeString str) <> "@"
327+inlineToHaddock _ (Str str) = do
328+ return $ text $ escapeString str
329+inlineToHaddock opts (Math mt str) = do
330+ let adjust x = case mt of
331+ DisplayMath -> cr <> x <> cr
332+ InlineMath -> x
333+ adjust `fmap` (inlineListToHaddock opts $ readTeXMath' mt str)
334+inlineToHaddock _ (RawInline f str)
335+ | f == "haddock" = return $ text str
336+ | otherwise = return empty
337+-- no line break in haddock (see above on CodeBlock)
338+inlineToHaddock _ (LineBreak) = return cr
339+inlineToHaddock _ Space = return space
340+inlineToHaddock opts (Cite _ lst) = inlineListToHaddock opts lst
341+inlineToHaddock opts (Link txt (src, _)) = do
342+ linktext <- inlineListToHaddock opts txt
343+ let useAuto = isURI src &&
344+ case txt of
345+ [Str s] | escapeURI s == src -> True
346+ _ -> False
347+ return $ nowrap $ "<" <> text src <>
348+ (if useAuto then empty else space <> linktext) <> ">"
349+inlineToHaddock opts (Image alternate (source, tit)) = do
350+ linkhaddock <- inlineToHaddock opts (Link alternate (source, tit))
351+ return $ "<" <> linkhaddock <> ">"
352+-- haddock doesn't have notes, but we can fake it:
353+inlineToHaddock opts (Note contents) = do
354+ modify (\st -> st{ stNotes = contents : stNotes st })
355+ st <- get
356+ let ref = text $ writerIdentifierPrefix opts ++ show (length $ stNotes st)
357+ return $ "[" <> ref <> "]"