Add markup support for properties

10 files changed, 29 insertions, 0 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 4949daa1..28d35aca 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 68cf715a..bf1e6ac3 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 e75cfaba..aa4ba377 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 3ad9719e..ced12d8d 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 0f702683..55c9a5da 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 8fa8ce95..59b83c70 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 b9ebe688..35e6dd8a 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 b34b14b9..c8a1a558 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 fbd05fae..05fc9747 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 b8f32589..4424ad73 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
   }