[commit: haddock] ghc-7.6: Add markup support for properties (72675c1)

Simon Hengel <[email protected]>
Newsgroups gmane.comp.lang.haskell.cvs.ghc
Message-ID <[email protected]> 
Repository : ssh://darcs.haskell.org//srv/darcs/haddock

On branch  : ghc-7.6

http://hackage.haskell.org/trac/ghc/changeset/72675c1bf281b81041a19014b1b7df03a0de9488

>---------------------------------------------------------------

commit 72675c1bf281b81041a19014b1b7df03a0de9488
Author: Kazu Yamamoto <[email protected]>
Date:   Mon Apr 9 15:45:57 2012 +0900

    Add markup support for properties

>---------------------------------------------------------------

 src/Haddock/Backends/Hoogle.hs          |    1 +
 src/Haddock/Backends/LaTeX.hs           |    1 +
 src/Haddock/Backends/Xhtml/DocMarkup.hs |    1 +
 src/Haddock/Interface/LexParseRn.hs     |    1 +
 src/Haddock/Interface/Rename.hs         |    1 +
 src/Haddock/InterfaceFile.hs            |    6 ++++++
 src/Haddock/Lex.x                       |    8 ++++++++
 src/Haddock/Parse.y                     |    6 ++++++
 src/Haddock/Types.hs                    |    2 ++
 src/Haddock/Utils.hs                    |    2 ++
 10 files changed, 29 insertions(+), 0 deletions(-)

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 4949daa..28d35ac 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -256,6 +256,7 @@ markupTag dflags = Markup {
   markupCodeBlock            = box TagPre,
   markupHyperlink            = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
   markupAName                = const $ str "",
+  markupProperty             = box TagPre . str,
   markupExample              = box TagPre . str . unlines . map exampleToString
   }
 
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 68cf715..bf1e6ac 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -1003,6 +1003,7 @@ parLatexMarkup ppId = Markup {
   markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
   markupHyperlink            = \l _ -> markupLink l,
   markupAName                = \_ _ -> empty,
+  markupProperty             = \p _ -> quote $ verb $ text p,
   markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
   }
   where
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index e75cfab..aa4ba37 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -50,6 +50,7 @@ parHtmlMarkup qual ppId = Markup {
   markupHyperlink            = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel,
   markupAName                = \aname -> namedAnchor aname << "",
   markupPic                  = \path -> image ! [src path],
+  markupProperty             = pre . toHtml,
   markupExample              = examplesToHtml
   }
   where
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 3ad9719..ced12d8 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -121,6 +121,7 @@ rename dflags gre = rn
       DocHyperlink l -> DocHyperlink l
       DocPic str -> DocPic str
       DocAName str -> DocAName str
+      DocProperty p -> DocProperty p
       DocExamples e -> DocExamples e
       DocEmpty -> DocEmpty
       DocString str -> DocString str
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 0f70268..55c9a5d 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -202,6 +202,7 @@ renameDoc d = case d of
   DocHyperlink l -> return (DocHyperlink l)
   DocPic str -> return (DocPic str)
   DocAName str -> return (DocAName str)
+  DocProperty p -> return (DocProperty p)
   DocExamples e -> return (DocExamples e)
 
 
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 8fa8ce9..59b83c7 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -481,6 +481,9 @@ instance (Binary id) => Binary (Doc id) where
     put_ bh (DocWarning ag) = do
             putByte bh 17
             put_ bh ag
+    put_ bh (DocProperty x) = do
+            putByte bh 18
+            put_ bh x
     get bh = do
             h <- getByte bh
             case h of
@@ -538,6 +541,9 @@ instance (Binary id) => Binary (Doc id) where
               17 -> do
                     ag <- get bh
                     return (DocWarning ag)
+              18 -> do
+                    x <- get bh
+                    return (DocProperty x)
               _ -> fail "invalid binary data found"
 
 
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index b9ebe68..35e6dd8 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -50,6 +50,7 @@ $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:]
 <0,para> {
  $ws* \n		;
  $ws* \>		{ begin birdtrack }
+ $ws* prop\>            { strtoken TokPropertyPrompt `andBegin` propertyexpr }
  $ws* \>\>\>            { strtoken TokExamplePrompt `andBegin` exampleexpr }
  $ws* [\*\-]		{ token TokBullet `andBegin` string }
  $ws* \[		{ token TokDefStart `andBegin` def }
@@ -61,6 +62,7 @@ $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:]
 -- beginning of a line
 <line> {
   $ws* \>		{ begin birdtrack }
+  $ws* prop\>           { strtoken TokPropertyPrompt `andBegin` propertyexpr }
   $ws* \>\>\>		{ strtoken TokExamplePrompt `andBegin` exampleexpr }
   $ws* \n		{ token TokPara `andBegin` para }
   -- Here, we really want to be able to say
@@ -84,6 +86,10 @@ $ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:]
 
 <exampleresult> .* \n	{ strtokenNL TokExampleResult `andBegin` example }
 
+<propertyexpr> .* \n	{ strtokenNL TokPropertyExpression `andBegin` property }
+
+<property> ()           { token TokPara `andBegin` para }
+
 <string,def> {
   $special			{ strtoken $ \s -> TokSpecial (head s) }
   \<\< [^\>]* \>\>              { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }
@@ -129,6 +135,8 @@ data Token
   | TokEmphasis String
   | TokAName String
   | TokBirdTrack String
+  | TokPropertyPrompt String
+  | TokPropertyExpression String
   | TokExamplePrompt String
   | TokExampleExpression String
   | TokExampleResult String
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
index b34b14b..c8a1a55 100644
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -35,6 +35,8 @@ import Data.List  (stripPrefix)
 	'-'	{ (TokBullet,_) }
 	'(n)'	{ (TokNumber,_) }
 	'>..'	{ (TokBirdTrack $$,_) }
+	PPROMPT	{ (TokPropertyPrompt $$,_) }
+	PEXP	{ (TokPropertyExpression $$,_) }
 	PROMPT	{ (TokExamplePrompt $$,_) }
 	RESULT	{ (TokExampleResult $$,_) }
 	EXP	{ (TokExampleExpression $$,_) }
@@ -73,12 +75,16 @@ defpara :: { (Doc RdrName, Doc RdrName) }
 para    :: { Doc RdrName }
 	: seq			{ docParagraph $1 }
 	| codepara		{ DocCodeBlock $1 }
+	| property		{ DocProperty $1 }
 	| examples		{ DocExamples $1 }
 
 codepara :: { Doc RdrName }
 	: '>..' codepara	{ docAppend (DocString $1) $2 }
 	| '>..'			{ DocString $1 }
 
+property :: { String }
+	: PPROMPT PEXP		{ strip $2 }
+
 examples :: { [Example] }
 	: example examples	{ $1 : $2 }
 	| example		{ [$1] }
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index fbd05fa..05fc974 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -306,6 +306,7 @@ data Doc id
   | DocHyperlink Hyperlink
   | DocPic String
   | DocAName String
+  | DocProperty String
   | DocExamples [Example]
   deriving (Functor)
 
@@ -350,6 +351,7 @@ data DocMarkup id a = Markup
   , markupHyperlink            :: Hyperlink -> a
   , markupAName                :: String -> a
   , markupPic                  :: String -> a
+  , markupProperty             :: String -> a
   , markupExample              :: [Example] -> a
   }
 
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index b8f3258..4424ad7 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -432,6 +432,7 @@ 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 (DocProperty p)             = markupProperty m p
 markup m (DocExamples e)             = markupExample m e
 
 
@@ -459,6 +460,7 @@ idMarkup = Markup {
   markupHyperlink            = DocHyperlink,
   markupAName                = DocAName,
   markupPic                  = DocPic,
+  markupProperty             = DocProperty,
   markupExample              = DocExamples
   }
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.