From 28bd97759174c9169b7633ee45d39c82fd069dd9 Mon Sep 17 00:00:00 2001 From: "simon.hengel" Date: Fri, 2 Apr 2010 14:08:40 +0000 Subject: Add markup support for interactive examples --- src/Haddock/Backends/Hoogle.hs | 3 ++- src/Haddock/Backends/Html.hs | 11 ++++++++- src/Haddock/Backends/Xhtml/DocMarkup.hs | 11 ++++++++- src/Haddock/Interface/Rename.hs | 1 + src/Haddock/Interface/Rn.hs | 2 ++ src/Haddock/InterfaceFile.hs | 16 +++++++++++++ src/Haddock/Lex.x | 14 +++++++++++ src/Haddock/Parse.y | 41 ++++++++++++++++++++++++++++++++- src/Haddock/Types.hs | 12 +++++++++- src/Haddock/Utils.hs | 4 +++- 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 \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] .* \n? { strtokenNL TokBirdTrack `andBegin` line } + { + $ws* \n { token TokPara `andBegin` para } + $ws* ghci \> { strtoken TokExamplePrompt `andBegin` exampleexpr } + () { begin exampleresult } +} + + .* \n { strtokenNL TokExampleExpression `andBegin` example } + + .* \n { strtokenNL TokExampleResult `andBegin` example } + { $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 } -- cgit v1.2.3