1{-# LANGUAGE CPP               #-}
2{-# LANGUAGE OverloadedStrings #-}
3{- |
4   Module      : Text.Pandoc.Readers.Haddock
5   Copyright   : Copyright (C) 2013 David Lazar
6   License     : GNU GPL, version 2 or above
7
8   Maintainer  : David Lazar <lazar6@illinois.edu>,
9                 John MacFarlane <jgm@berkeley.edu>
10   Stability   : alpha
11
12Conversion of Haddock markup to 'Pandoc' document.
13-}
14module Text.Pandoc.Readers.Haddock
15    ( readHaddock
16    ) where
17
18import Control.Monad.Except (throwError)
19import Data.List (intersperse)
20import Data.Maybe (fromMaybe)
21import Data.Text (Text, unpack)
22import qualified Data.Text as T
23import Documentation.Haddock.Parser
24import Documentation.Haddock.Types as H
25import Text.Pandoc.Builder (Blocks, Inlines)
26import qualified Text.Pandoc.Builder as B
27import Text.Pandoc.Class.PandocMonad (PandocMonad)
28import Text.Pandoc.Definition
29import Text.Pandoc.Error
30import Text.Pandoc.Options
31import Text.Pandoc.Shared (crFilter, splitTextBy, trim)
32
33
34-- | Parse Haddock markup and return a 'Pandoc' document.
35readHaddock :: PandocMonad m
36            => ReaderOptions
37            -> Text
38            -> m Pandoc
39readHaddock opts s = case readHaddockEither opts (unpack (crFilter s)) of
40  Right result -> return result
41  Left e       -> throwError e
42
43readHaddockEither :: ReaderOptions -- ^ Reader options
44                  -> String        -- ^ String to parse
45                  -> Either PandocError Pandoc
46readHaddockEither _opts =
47  Right . B.doc . docHToBlocks . _doc . parseParas Nothing
48
49docHToBlocks :: DocH String Identifier -> Blocks
50docHToBlocks d' =
51  case d' of
52    DocEmpty -> mempty
53    DocAppend (DocParagraph (DocHeader h)) (DocParagraph (DocAName ident)) ->
54         B.headerWith (T.pack ident,[],[]) (headerLevel h)
55            (docHToInlines False $ headerTitle h)
56    DocAppend d1 d2 -> mappend (docHToBlocks d1) (docHToBlocks d2)
57    DocString _ -> inlineFallback
58    DocParagraph (DocAName h) -> B.plain $ docHToInlines False $ DocAName h
59    DocParagraph x -> B.para $ docHToInlines False x
60    DocIdentifier _ -> inlineFallback
61    DocIdentifierUnchecked _ -> inlineFallback
62    DocModule s -> B.plain $ docHToInlines False $ DocModule s
63    DocWarning _ -> mempty -- TODO
64    DocEmphasis _ -> inlineFallback
65    DocMonospaced _ -> inlineFallback
66    DocBold _ -> inlineFallback
67    DocMathInline _ -> inlineFallback
68    DocMathDisplay _ -> inlineFallback
69    DocHeader h -> B.header (headerLevel h)
70                           (docHToInlines False $ headerTitle h)
71    DocUnorderedList items -> B.bulletList (map docHToBlocks items)
72    DocOrderedList items -> B.orderedList (map docHToBlocks items)
73    DocDefList items -> B.definitionList (map (\(d,t) ->
74                               (docHToInlines False d,
75                                [consolidatePlains $ docHToBlocks t])) items)
76    DocCodeBlock (DocString s) -> B.codeBlockWith ("",[],[]) $ T.pack s
77    DocCodeBlock d -> B.para $ docHToInlines True d
78    DocHyperlink _ -> inlineFallback
79    DocPic _ -> inlineFallback
80    DocAName _ -> inlineFallback
81    DocProperty s -> B.codeBlockWith ("",["property","haskell"],[]) (trim $ T.pack s)
82    DocExamples es -> mconcat $ map (\e ->
83       makeExample ">>>" (exampleExpression e) (exampleResult e)) es
84    DocTable H.Table{ tableHeaderRows = headerRows
85                    , tableBodyRows = bodyRows
86                    }
87      -> let toCells = map (docHToBlocks . tableCellContents) . tableRowCells
88             toRow = Row nullAttr . map B.simpleCell
89             toHeaderRow l = [toRow l | not (null l)]
90             (header, body) =
91               if null headerRows
92                  then ([], map toCells bodyRows)
93                  else (toCells (head headerRows),
94                        map toCells (tail headerRows ++ bodyRows))
95             colspecs = replicate (maximum (map length body))
96                             (AlignDefault, ColWidthDefault)
97         in  B.table B.emptyCaption
98                     colspecs
99                     (TableHead nullAttr $ toHeaderRow header)
100                     [TableBody nullAttr 0 [] $ map toRow body]
101                     (TableFoot nullAttr [])
102
103  where inlineFallback = B.plain $ docHToInlines False d'
104        consolidatePlains = B.fromList . consolidatePlains' . B.toList
105        consolidatePlains' zs@(Plain _ : _) =
106          let (xs, ys) = span isPlain zs in
107          Para (concatMap extractContents xs) : consolidatePlains' ys
108        consolidatePlains' (x : xs) = x : consolidatePlains' xs
109        consolidatePlains' [] = []
110        isPlain (Plain _) = True
111        isPlain _         = False
112        extractContents (Plain xs) = xs
113        extractContents _          = []
114
115docHToInlines :: Bool -> DocH String Identifier -> Inlines
116docHToInlines isCode d' =
117  case d' of
118    DocEmpty -> mempty
119    DocAppend d1 d2 -> mappend (docHToInlines isCode d1)
120                               (docHToInlines isCode d2)
121    DocString s
122      | isCode -> mconcat $ intersperse B.linebreak
123                              $ map B.code $ splitTextBy (=='\n') $ T.pack s
124      | otherwise  -> B.text $ T.pack s
125    DocParagraph _ -> mempty
126    DocIdentifier ident ->
127        case toRegular (DocIdentifier ident) of
128          DocIdentifier s -> B.codeWith ("",["haskell","identifier"],[]) $ T.pack s
129          _               -> mempty
130    DocIdentifierUnchecked s -> B.codeWith ("",["haskell","identifier"],[]) $ T.pack s
131    DocModule s -> B.codeWith ("",["haskell","module"],[]) $ T.pack s
132    DocWarning _ -> mempty -- TODO
133    DocEmphasis d -> B.emph (docHToInlines isCode d)
134    DocMonospaced (DocString s) -> B.code $ T.pack s
135    DocMonospaced d -> docHToInlines True d
136    DocBold d -> B.strong (docHToInlines isCode d)
137    DocMathInline s -> B.math $ T.pack s
138    DocMathDisplay s -> B.displayMath $ T.pack s
139    DocHeader _ -> mempty
140    DocUnorderedList _ -> mempty
141    DocOrderedList _ -> mempty
142    DocDefList _ -> mempty
143    DocCodeBlock _ -> mempty
144    DocHyperlink h -> B.link (T.pack $ hyperlinkUrl h) (T.pack $ hyperlinkUrl h)
145             (maybe (B.text $ T.pack $ hyperlinkUrl h) (docHToInlines isCode)
146               (hyperlinkLabel h))
147    DocPic p -> B.image (T.pack $ pictureUri p) (T.pack $ fromMaybe (pictureUri p) $ pictureTitle p)
148                        (maybe mempty (B.text . T.pack) $ pictureTitle p)
149    DocAName s -> B.spanWith (T.pack s,["anchor"],[]) mempty
150    DocProperty _ -> mempty
151    DocExamples _ -> mempty
152    DocTable _ -> mempty
153
154-- | Create an 'Example', stripping superfluous characters as appropriate
155makeExample :: T.Text -> String -> [String] -> Blocks
156makeExample prompt expression result =
157    B.para $ B.codeWith ("",["prompt"],[]) prompt
158        <> B.space
159        <> B.codeWith ("", ["haskell","expr"], []) (trim $ T.pack expression)
160        <> B.linebreak
161        <> mconcat (intersperse B.linebreak $ map coder result')
162  where
163    -- 1. drop trailing whitespace from the prompt, remember the prefix
164    prefix = T.takeWhile (`elem` (" \t" :: String)) prompt
165
166    -- 2. drop, if possible, the exact same sequence of whitespace
167    -- characters from each result line
168    --
169    -- 3. interpret lines that only contain the string "<BLANKLINE>" as an
170    -- empty line
171    result' = map (substituteBlankLine . tryStripPrefix prefix . T.pack) result
172      where
173        tryStripPrefix xs ys = fromMaybe ys $ T.stripPrefix xs ys
174
175        substituteBlankLine "<BLANKLINE>" = ""
176        substituteBlankLine line          = line
177    coder = B.codeWith ("", ["result"], [])
178