Very WIP: markdown support

haddock-api/src/Haddock/Backends/Hoogle.hs

@@ -323,8 +323,9 @@ markupTag dflags = Markup {
   markupUnorderedList        = box (TagL 'u'),
   markupOrderedList          = box (TagL 'o'),
   markupDefList              = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
-  markupCodeBlock            = box TagPre,
-  markupHyperlink            = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
+  markupCodeBlock            = \(CodeBlock _ d) -> box TagPre d,
+  markupBlockQuote           = \_ -> str "TODO: block quote",
+  markupHyperlink            = \(Hyperlink url mLabel) -> (box (TagInline "a")) (fromMaybe (str url) mLabel),
   markupAName                = const $ str "",
   markupProperty             = box TagPre . str,
   markupExample              = box TagPre . str . unlines . map exampleToString,

haddock-api/src/Haddock/Backends/LaTeX.hs

@@ -1134,8 +1134,9 @@ parLatexMarkup ppId = Markup {
   markupMathDisplay          = \p _ -> markupMathDisplay p,
   markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
   markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
-  markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
-  markupHyperlink            = \l _ -> markupLink l,
+  markupCodeBlock            = \(CodeBlock _ p) _ -> quote (verb (p Verb)) $$ text "",
+  markupBlockQuote           = \p v -> quote (p v), 
+  markupHyperlink            = \l v -> markupLink (fmap ($v) l),
   markupAName                = \_ _ -> empty,
   markupProperty             = \p _ -> quote $ verb $ text p,
   markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
@@ -1156,7 +1157,7 @@ parLatexMarkup ppId = Markup {
     fixString Mono  s = latexMonoFilter s
 
     markupLink (Hyperlink url mLabel) = case mLabel of
-      Just label -> text "\\href" <> braces (text url) <> braces (text label)
+      Just label -> text "\\href" <> braces (text url) <> braces label
       Nothing    -> text "\\url"  <> braces (text url)
 
     -- Is there a better way of doing this? Just a space is an aribtrary choice.

haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs

@@ -58,12 +58,13 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
   markupUnorderedList        = unordList,
   markupOrderedList          = ordList,
   markupDefList              = defList,
-  markupCodeBlock            = pre,
+  markupCodeBlock            = \(CodeBlock _ d) -> pre d,
+  markupBlockQuote           = blockquote,
   markupHyperlink            = \(Hyperlink url mLabel)
-                               -> if insertAnchors
-                                  then anchor ! [href url]
-                                       << fromMaybe url mLabel
-                                  else toHtml $ fromMaybe url mLabel,
+                               -> let u = fromMaybe (toHtml url) (fmap toHtml mLabel)
+                                  in if insertAnchors
+                                       then anchor ! [href url] << u
+                                       else u,
   markupAName                = \aname
                                -> if insertAnchors
                                   then namedAnchor aname << ""

haddock-api/src/Haddock/Interface/Create.hs

@@ -297,6 +297,7 @@ parseOption "prune"           = return (Just OptPrune)
 parseOption "ignore-exports"  = return (Just OptIgnoreExports)
 parseOption "not-home"        = return (Just OptNotHome)
 parseOption "show-extensions" = return (Just OptShowExtensions)
+parseOption "markdown"        = return (Just OptMarkdown)
 parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
 
 

haddock-api/src/Haddock/Interface/LexParseRn.hs

@@ -130,10 +130,11 @@ rename dflags gre = rn
       DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
       DocOrderedList docs -> DocOrderedList <$> traverse rn docs
       DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
-      DocCodeBlock doc -> DocCodeBlock <$> rn doc
+      DocCodeBlock (CodeBlock lbl doc) -> DocCodeBlock . CodeBlock lbl <$> rn doc
+      DocBlockQuote doc -> DocBlockQuote <$> rn doc
       DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
       DocModule str -> pure (DocModule str)
-      DocHyperlink l -> pure (DocHyperlink l)
+      DocHyperlink (Hyperlink url doc) -> DocHyperlink . Hyperlink url <$> traverse rn doc
       DocPic str -> pure (DocPic str)
       DocMathInline str -> pure (DocMathInline str)
       DocMathDisplay str -> pure (DocMathDisplay str)

haddock-api/src/Haddock/InterfaceFile.hs

@@ -412,6 +412,8 @@ instance Binary DocOption where
             putByte bh 3
     put_ bh OptShowExtensions = do
             putByte bh 4
+    put_ bh OptMarkdown = do
+            putByte bh 5
     get bh = do
             h <- getByte bh
             case h of
@@ -425,9 +427,20 @@ instance Binary DocOption where
                     return OptNotHome
               4 -> do
                     return OptShowExtensions
+              5 -> do
+                    return OptMarkdown
               _ -> fail "invalid binary data found"
 
 
+instance Binary a => Binary (CodeBlock a) where
+    put_ bh (CodeBlock label doc) = do
+        put_ bh label
+        put_ bh doc
+    get bh = do
+        label <- get bh
+        doc <- get bh
+        return (CodeBlock label doc)
+
 instance Binary Example where
     put_ bh (Example expression result) = do
         put_ bh expression
@@ -437,7 +450,7 @@ instance Binary Example where
         result <- get bh
         return (Example expression result)
 
-instance Binary Hyperlink where
+instance Binary a => Binary (Hyperlink a) where
     put_ bh (Hyperlink url label) = do
         put_ bh url
         put_ bh label
@@ -576,6 +589,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
     put_ bh (DocTable x) = do
             putByte bh 23
             put_ bh x
+    put_ bh (DocBlockQuote al) = do
+            putByte bh 24
+            put_ bh al
 
     get bh = do
             h <- getByte bh
@@ -652,6 +668,9 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where
               23 -> do
                     x <- get bh
                     return (DocTable x)
+              24 -> do
+                    x <- get bh
+                    return (DocBlockQuote x)
               _ -> error "invalid binary data found in the interface file"
 
 

haddock-api/src/Haddock/Types.hs

@@ -463,6 +463,7 @@ instance (NFData a, NFData mod)
     DocOrderedList a          -> a `deepseq` ()
     DocDefList a              -> a `deepseq` ()
     DocCodeBlock a            -> a `deepseq` ()
+    DocBlockQuote a           -> a `deepseq` ()
     DocHyperlink a            -> a `deepseq` ()
     DocPic a                  -> a `deepseq` ()
     DocMathInline a           -> a `deepseq` ()
@@ -480,10 +481,13 @@ instance NFData OccName where rnf x = seq x ()
 instance NFData ModuleName where rnf x = seq x ()
 #endif
 
+instance NFData id => NFData (CodeBlock id) where
+  rnf (CodeBlock a b) = a `deepseq` b `deepseq` ()
+
 instance NFData id => NFData (Header id) where
   rnf (Header a b) = a `deepseq` b `deepseq` ()
 
-instance NFData Hyperlink where
+instance NFData id => NFData (Hyperlink id) where
   rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
 
 instance NFData Picture where
@@ -545,6 +549,7 @@ data DocOption
   | OptNotHome         -- ^ Not the best place to get docs for things
                        -- exported by this module.
   | OptShowExtensions  -- ^ Render enabled extensions for this module.
+  | OptMarkdown        -- ^ Expect documentation to be in the Markdown format
   deriving (Eq, Show)
 
 

haddock-library/haddock-library.cabal

@@ -41,6 +41,11 @@ library
     Documentation.Haddock.Parser.Monad
     Documentation.Haddock.Types
     Documentation.Haddock.Utf8
+    Documentation.Markdown.Parse
+    Documentation.Markdown.ParserCombinators
+    Documentation.Markdown.Types
+    Documentation.Markdown.Inlines
+    Documentation.Markdown.Util
 
   other-modules:
     Documentation.Haddock.Parser.Util

haddock-library/src/Documentation/Haddock/Doc.hs

@@ -56,17 +56,17 @@ docAppend d1 d2 = DocAppend d1 d2
 -- is a DocMonospaced and make it into a DocCodeBlock
 docParagraph :: DocH mod id -> DocH mod id
 docParagraph (DocMonospaced p)
-  = DocCodeBlock (docCodeBlock p)
+  = DocCodeBlock (CodeBlock Nothing (docCodeBlock p))
 docParagraph (DocAppend (DocString s1) (DocMonospaced p))
   | all isSpace s1
-  = DocCodeBlock (docCodeBlock p)
+  = DocCodeBlock (CodeBlock Nothing (docCodeBlock p))
 docParagraph (DocAppend (DocString s1)
     (DocAppend (DocMonospaced p) (DocString s2)))
   | all isSpace s1 && all isSpace s2
-  = DocCodeBlock (docCodeBlock p)
+  = DocCodeBlock (CodeBlock Nothing (docCodeBlock p))
 docParagraph (DocAppend (DocMonospaced p) (DocString s2))
   | all isSpace s2
-  = DocCodeBlock (docCodeBlock p)
+  = DocCodeBlock (CodeBlock Nothing (docCodeBlock p))
 docParagraph p
   = DocParagraph p
 

haddock-library/src/Documentation/Haddock/Markup.hs

@@ -7,30 +7,31 @@ module Documentation.Haddock.Markup (
 import Documentation.Haddock.Types
 
 markup :: DocMarkupH mod id a -> DocH mod id -> a
-markup m DocEmpty                    = markupEmpty m
-markup m (DocAppend d1 d2)           = markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s)               = markupString m s
-markup m (DocParagraph d)            = markupParagraph m (markup m d)
-markup m (DocIdentifier x)           = markupIdentifier m x
-markup m (DocIdentifierUnchecked x)  = markupIdentifierUnchecked m x
-markup m (DocModule mod0)            = markupModule m mod0
-markup m (DocWarning d)              = markupWarning m (markup m d)
-markup m (DocEmphasis d)             = markupEmphasis m (markup m d)
-markup m (DocBold d)                 = markupBold m (markup m d)
-markup m (DocMonospaced d)           = markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds)         = markupOrderedList m (map (markup m) ds)
-markup m (DocDefList ds)             = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)
-markup m (DocHyperlink l)            = markupHyperlink m l
-markup m (DocAName ref)              = markupAName m ref
-markup m (DocPic img)                = markupPic m img
-markup m (DocMathInline mathjax)     = markupMathInline m mathjax
-markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax
-markup m (DocProperty p)             = markupProperty m p
-markup m (DocExamples e)             = markupExample m e
-markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))
-markup m (DocTable (Table h b))      = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))
+markup m DocEmpty                       = markupEmpty m
+markup m (DocAppend d1 d2)              = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s)                  = markupString m s
+markup m (DocParagraph d)               = markupParagraph m (markup m d)
+markup m (DocIdentifier x)              = markupIdentifier m x
+markup m (DocIdentifierUnchecked x)     = markupIdentifierUnchecked m x
+markup m (DocModule mod0)               = markupModule m mod0
+markup m (DocWarning d)                 = markupWarning m (markup m d)
+markup m (DocEmphasis d)                = markupEmphasis m (markup m d)
+markup m (DocBold d)                    = markupBold m (markup m d)
+markup m (DocMonospaced d)              = markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds)          = markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds)            = markupOrderedList m (map (markup m) ds)
+markup m (DocDefList ds)                = markupDefList m (map (markupPair m) ds)
+markup m (DocCodeBlock (CodeBlock l d)) = markupCodeBlock m (CodeBlock l (markup m d))
+markup m (DocBlockQuote d)              = markupBlockQuote m (markup m d)
+markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))
+markup m (DocAName ref)                 = markupAName m ref
+markup m (DocPic img)                   = markupPic m img
+markup m (DocMathInline mathjax)        = markupMathInline m mathjax
+markup m (DocMathDisplay mathjax)       = markupMathDisplay m mathjax
+markup m (DocProperty p)                = markupProperty m p
+markup m (DocExamples e)                = markupExample m e
+markup m (DocHeader (Header l t))       = markupHeader m (Header l (markup m t))
+markup m (DocTable (Table h b))         = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))
 
 markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a)
 markupPair m (a,b) = (markup m a, markup m b)
@@ -53,6 +54,7 @@ idMarkup = Markup {
   markupOrderedList          = DocOrderedList,
   markupDefList              = DocDefList,
   markupCodeBlock            = DocCodeBlock,
+  markupBlockQuote           = DocBlockQuote,
   markupHyperlink            = DocHyperlink,
   markupAName                = DocAName,
   markupPic                  = DocPic,

haddock-library/src/Documentation/Haddock/Parser.hs

@@ -36,6 +36,10 @@ import           Documentation.Haddock.Utf8
 import           Prelude hiding (takeWhile)
 import qualified Prelude as P
 
+
+import Documentation.Markdown.Parse (markdown)
+import Documentation.Markdown.Types (docToDoc)
+
 -- $setup
 -- >>> :set -XOverloadedStrings
 
@@ -72,8 +76,9 @@ overIdentifier f d = g d
     g (DocUnorderedList x) = DocUnorderedList $ fmap g x
     g (DocOrderedList x) = DocOrderedList $ fmap g x
     g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x
-    g (DocCodeBlock x) = DocCodeBlock $ g x
-    g (DocHyperlink x) = DocHyperlink x
+    g (DocCodeBlock (CodeBlock l x)) = DocCodeBlock . CodeBlock l $ g x
+    g (DocBlockQuote x) = DocBlockQuote (g x)
+    g (DocHyperlink (Hyperlink u x)) = DocHyperlink . Hyperlink u $ fmap g x
     g (DocPic x) = DocPic x
     g (DocMathInline x) = DocMathInline x
     g (DocMathDisplay x) = DocMathDisplay x
@@ -94,7 +99,7 @@ parseParas :: String -- ^ String to parse
            -> MetaDoc mod Identifier
 parseParas input = case parseParasState input of
   (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state }
-                        , _doc = a
+                        , _doc = docToDoc (markdown input)
                         }
 
 parseParasState :: String -> (ParserState, DocH mod Identifier)
@@ -250,7 +255,7 @@ mathDisplay = DocMathDisplay . decodeUtf8
 markdownImage :: Parser (DocH mod a)
 markdownImage = fromHyperlink <$> ("!" *> linkParser)
   where
-    fromHyperlink (Hyperlink url label) = DocPic (Picture url label)
+    fromHyperlink (Hyperlink url label) = DocPic (Picture url (fmap (\(DocString l) -> l) label))
 
 -- | Paragraph parser, called by 'parseParas'.
 paragraph :: Parser (DocH mod Identifier)
@@ -619,7 +624,11 @@ takeIndent = do
 -- >> baz
 --
 birdtracks :: Parser (DocH mod a)
-birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line
+birdtracks = DocCodeBlock
+           . CodeBlock Nothing
+           . DocString
+           . intercalate "\n"
+           . stripSpace <$> many1 line
   where
     line = skipHorizontalSpace *> ">" *> takeLine
 
@@ -683,7 +692,7 @@ property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n')
 -- for markup.
 codeblock :: Parser (DocH mod Identifier)
 codeblock =
-  DocCodeBlock . parseStringBS . dropSpaces
+  DocCodeBlock . CodeBlock Nothing . parseStringBS . dropSpaces
   <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
   where
     dropSpaces xs =
@@ -717,16 +726,16 @@ codeblock =
           | otherwise = Just $ c == '\n'
 
 hyperlink :: Parser (DocH mod a)
-hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8
+hyperlink = DocHyperlink . makeLabeled (\u d -> Hyperlink u (fmap DocString d)) . decodeUtf8
               <$> disallowNewline ("<" *> takeUntil ">")
             <|> autoUrl
             <|> markdownLink
 
 markdownLink :: Parser (DocH mod a)
 markdownLink = DocHyperlink <$> linkParser
 
-linkParser :: Parser Hyperlink
-linkParser = flip Hyperlink <$> label <*> (whitespace *> url)
+linkParser :: Parser (Hyperlink (DocH mod a))
+linkParser = flip Hyperlink <$> (fmap DocString <$> label) <*> (whitespace *> url)
   where
     label :: Parser (Maybe String)
     label = Just . strip . decode <$> ("[" *> takeUntil "]")