Add markup support for interactive examples

3 files changed, 22 insertions, 3 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 25c5d91e..2d4ece4b 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -240,7 +240,8 @@ markupTag = Markup {
   markupDefList       = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
   markupCodeBlock     = box TagPre,
   markupURL           = box (TagInline "a") . str,
-  markupAName         = const $ str ""
+  markupAName         = const $ str "",
+  markupExample       = box TagPre . str . unlines . (map exampleToString)
   }
 
 
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 47930ed4..68d1da42 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -1725,7 +1725,8 @@ parHtmlMarkup ppId isTyCon = Markup {
   markupDefList       = dlist . concatHtml . map markupDef,
   markupCodeBlock     = pre,
   markupURL	      = \url -> anchor ! [href url] << toHtml url,
-  markupAName	      = \aname -> namedAnchor aname << toHtml ""
+  markupAName	      = \aname -> namedAnchor aname << toHtml "",
+  markupExample       = examplesToHtml
   }
   where
     -- If an id can refer to multiple things, we give precedence to type
@@ -1739,6 +1740,14 @@ parHtmlMarkup ppId isTyCon = Markup {
       | isTyCon x = x
       | otherwise = y
 
+    examplesToHtml l = (pre $ concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+
+    exampleToHtml (Example expression result) = htmlExample
+      where
+        htmlExample = htmlPrompt +++ htmlExpression +++ (toHtml $ unlines result)
+        htmlPrompt = (thecode . toHtml $ "ghci> ") ! [theclass "prompt"]
+        htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+
 
 markupDef :: (HTML a, HTML b) => (a, b) -> Html
 markupDef (a,b) = dterm << a +++ ddef << b
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 72314aec..5ecd0aea 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -42,7 +42,8 @@ parHtmlMarkup ppId isTyCon = Markup {
   markupDefList       = dlist . concatHtml . map markupDef,
   markupCodeBlock     = pre,
   markupURL           = \url -> anchor ! [href url] << toHtml url,
-  markupAName         = \aname -> namedAnchor aname << toHtml ""
+  markupAName         = \aname -> namedAnchor aname << toHtml "",
+  markupExample       = examplesToHtml
   }
   where
     -- If an id can refer to multiple things, we give precedence to type
@@ -56,6 +57,14 @@ parHtmlMarkup ppId isTyCon = Markup {
       | isTyCon x = x
       | otherwise = y
 
+    examplesToHtml l = (pre $ concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+
+    exampleToHtml (Example expression result) = htmlExample
+      where
+        htmlExample = htmlPrompt +++ htmlExpression +++ (toHtml $ unlines result)
+        htmlPrompt = (thecode . toHtml $ "ghci> ") ! [theclass "prompt"]
+        htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+
 
 markupDef :: (HTML a, HTML b) => (a, b) -> Html
 markupDef (a,b) = dterm << a +++ ddef << b