Add markup support for interactive examples

10 files changed, 109 insertions, 6 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
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 80dc7d14..8e1476d3 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -202,6 +202,7 @@ renameDoc d = case d of
   DocURL str -> return (DocURL str)
   DocPic str -> return (DocPic str)
   DocAName str -> return (DocAName str)
+  DocExamples e -> return (DocExamples e)
 
 
 renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
index 5127e49b..a115225a 100644
--- a/src/Haddock/Interface/Rn.hs
+++ b/src/Haddock/Interface/Rn.hs
@@ -80,3 +80,5 @@ rnDoc gre = unId . do_rn
   DocPic str -> return (DocPic str)
 
   DocAName str -> return (DocAName str)
+
+  DocExamples e -> return (DocExamples e)
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index eed44714..6a3e777c 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -371,6 +371,16 @@ instance Binary DocOption where
               _ -> fail "invalid binary data found"
 
 
+instance Binary Example where
+    put_ bh (Example expression result) = do
+        put_ bh expression
+        put_ bh result
+    get bh = do
+        expression <- get bh
+        result <- get bh
+        return (Example expression result)
+
+
 {-* Generated by DrIFT : Look, but Don't Touch. *-}
 instance (Binary id) => Binary (Doc id) where
     put_ bh DocEmpty = do
@@ -418,6 +428,9 @@ instance (Binary id) => Binary (Doc id) where
     put_ bh (DocAName an) = do
             putByte bh 14
             put_ bh an
+    put_ bh (DocExamples ao) = do
+            putByte bh 15
+            put_ bh ao
     get bh = do
             h <- getByte bh
             case h of
@@ -466,6 +479,9 @@ instance (Binary id) => Binary (Doc id) where
               14 -> do
                     an <- get bh
                     return (DocAName an)
+              15 -> do
+                    ao <- get bh
+                    return (DocExamples ao)
               _ -> fail "invalid binary data found"
 
 
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index 04b9f0c3..40ffbe92 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -45,6 +45,7 @@ $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
 <0,para> {
  $ws* \n		;
  $ws* \>		{ begin birdtrack }
+ $ws* ghci \>	        { strtoken TokExamplePrompt `andBegin` exampleexpr }
  $ws* [\*\-]		{ token TokBullet `andBegin` string }
  $ws* \[		{ token TokDefStart `andBegin` def }
  $ws* \( $digit+ \) 	{ token TokNumber `andBegin` string }
@@ -66,6 +67,16 @@ $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
 
 <birdtrack> .*	\n?	{ strtokenNL TokBirdTrack `andBegin` line }
 
+<example> {
+  $ws*	\n		{ token TokPara `andBegin` para }
+  $ws* ghci \>	        { strtoken TokExamplePrompt `andBegin` exampleexpr }
+  ()			{ begin exampleresult }
+}
+
+<exampleexpr> .* \n	{ strtokenNL TokExampleExpression `andBegin` example }
+
+<exampleresult> .* \n	{ strtokenNL TokExampleResult `andBegin` example }
+
 <string,def> {
   $special			{ strtoken $ \s -> TokSpecial (head s) }
   \<\<.*\>\>                    { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }
@@ -108,6 +119,9 @@ data Token
   | TokEmphasis String
   | TokAName String
   | TokBirdTrack String
+  | TokExamplePrompt String
+  | TokExampleExpression String
+  | TokExampleResult String
 --  deriving Show
 
 -- -----------------------------------------------------------------------------
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
index 42553343..d1146da3 100644
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -9,10 +9,13 @@
 module Haddock.Parse where
 
 import Haddock.Lex
-import Haddock.Types (Doc(..))
+import Haddock.Types (Doc(..), Example(Example))
 import Haddock.Doc
 import HsSyn
 import RdrName
+import Data.Char  (isSpace)
+import Data.Maybe (fromMaybe)
+import Data.List  (stripPrefix)
 }
 
 %expect 0
@@ -31,6 +34,9 @@ import RdrName
 	'-'	{ TokBullet }
 	'(n)'	{ TokNumber }
 	'>..'	{ TokBirdTrack $$ }
+	PROMPT	{ TokExamplePrompt $$ }
+	RESULT	{ TokExampleResult $$ }
+	EXP	{ TokExampleExpression $$ }
 	IDENT   { TokIdent $$ }
 	PARA    { TokPara }
 	STRING	{ TokString $$ }
@@ -66,11 +72,24 @@ defpara :: { (Doc RdrName, Doc RdrName) }
 para    :: { Doc RdrName }
 	: seq			{ docParagraph $1 }
 	| codepara		{ DocCodeBlock $1 }
+	| examples		{ DocExamples $1 }
 
 codepara :: { Doc RdrName }
 	: '>..' codepara	{ docAppend (DocString $1) $2 }
 	| '>..'			{ DocString $1 }
 
+examples :: { [Example] }
+	: example examples	{ $1 : $2 }
+	| example		{ [$1] }
+
+example :: { Example }
+	: PROMPT EXP result	{ makeExample $1 $2 (lines $3) }
+	| PROMPT EXP		{ makeExample $1 $2 [] }
+
+result :: { String }
+	: RESULT result		{ $1 ++ $2 }
+	| RESULT		{ $1 }
+
 seq	:: { Doc RdrName }
 	: elem seq		{ docAppend $1 $2 }
 	| elem			{ $1 }
@@ -100,4 +119,24 @@ strings  :: { String }
 {
 happyError :: [Token] -> Maybe a
 happyError toks = Nothing
+
+-- | Create an 'Example', stripping superfluous characters as appropriate
+makeExample :: String -> String -> [String] -> Example
+makeExample prompt expression result =
+  Example
+	(strip expression)	-- we do not care about leading and trailing
+				-- whitespace in expressions, so drop them
+	result'
+  where
+	-- drop trailing whitespace from the prompt, remember the prefix
+	(prefix, _) = span isSpace prompt
+	-- drop, if possible, the exact same sequence of whitespace characters
+	-- from each result line
+	result' = map (tryStripPrefix prefix) result
+	  where
+		tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys
+
+-- | Remove all leading and trailing whitespace
+strip :: String -> String
+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
 }
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 4e076a26..610f958c 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -278,8 +278,17 @@ data Doc id
   | DocURL String
   | DocPic String
   | DocAName String
+  | DocExamples [Example]
   deriving (Eq, Show, Functor)
 
+data Example = Example { exampleExpression :: String
+                       , exampleResult     :: [String]
+                       }
+                       deriving (Eq, Show)
+
+exampleToString :: Example -> String
+exampleToString (Example expression result) =
+    "ghci> " ++ expression ++ "\n" ++  unlines result
 
 #ifdef TEST
 -- TODO: use derive
@@ -321,7 +330,8 @@ data DocMarkup id a = Markup {
   markupCodeBlock     :: a -> a,
   markupURL           :: String -> a,
   markupAName         :: String -> a,
-  markupPic           :: String -> a
+  markupPic           :: String -> a,
+  markupExample       :: [Example] -> a
 }
 
 
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index da144355..11366b3f 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -327,6 +327,7 @@ markup m (DocCodeBlock d)      = markupCodeBlock m (markup m d)
 markup m (DocURL url)          = markupURL m url
 markup m (DocAName ref)        = markupAName m ref
 markup m (DocPic img)          = markupPic m img
+markup m (DocExamples e)       = markupExample m e
 
 markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
 markupPair m (a,b) = (markup m a, markup m b)
@@ -348,7 +349,8 @@ idMarkup = Markup {
   markupCodeBlock     = DocCodeBlock,
   markupURL           = DocURL,
   markupAName         = DocAName,
-  markupPic           = DocPic
+  markupPic           = DocPic,
+  markupExample       = DocExamples
   }