aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Hoogle.hs3
-rw-r--r--src/Haddock/Backends/Html.hs11
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs11
-rw-r--r--src/Haddock/Interface/Rename.hs1
-rw-r--r--src/Haddock/Interface/Rn.hs2
-rw-r--r--src/Haddock/InterfaceFile.hs16
-rw-r--r--src/Haddock/Lex.x14
-rw-r--r--src/Haddock/Parse.y41
-rw-r--r--src/Haddock/Types.hs12
-rw-r--r--src/Haddock/Utils.hs4
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
}
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 07:46:02 +0000