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