From 640c154ab1ae1da81f16139d3c5ced7b00b710f3 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 29 Apr 2002 15:28:54 +0000
Subject: [haddock @ 2002-04-29 15:28:54 by simonmar] Allow '-- |' style
annotations on constructors and record fields.
---
src/HaddockHtml.hs | 28 +++++++++++++++++-----------
src/HsParser.ly | 26 ++++++++++++++++----------
src/Main.hs | 2 +-
3 files changed, 34 insertions(+), 22 deletions(-)
(limited to 'src')
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 7f05d42f..06ff5db2 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -17,6 +17,7 @@ import FiniteMap
import List ( sortBy )
import Char ( toUpper, toLower )
import Monad ( when )
+import IOExts
import Html
import qualified Html
@@ -461,15 +462,14 @@ keepDecl _ = False
-- -----------------------------------------------------------------------------
-- Data & newtype declarations
-ppShortDataDecl doc_map summary is_newty
+ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html
+ppShortDataDecl summary is_newty
(HsDataDecl loc ctx nm args [con] drv) =
- declBox ( -- single constructor special case
- ppHsDataHeader summary is_newty nm args
- <+> equals <+> ppShortConstr summary con
- )
-ppShortDataDecl doc_map summary is_newty
+ ppHsDataHeader summary is_newty nm args
+ <+> equals <+> ppShortConstr summary con
+ppShortDataDecl summary is_newty
(HsDataDecl loc ctx nm args cons drv) =
- declBox << vanillaTable << (
+ vanillaTable << (
aboves (
(declBox (ppHsDataHeader summary is_newty nm args) :
zipWith do_constr ('=':repeat '|') cons
@@ -488,8 +488,9 @@ ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) =
-- The rest of the cases:
ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
- | summary || (isNothing doc && all constr_has_no_doc cons)
- = ppShortDataDecl doc_map summary is_newty decl
+ | summary || no_constr_docs
+ = declWithDoc summary (lookupFM doc_map nm)
+ (ppShortDataDecl summary is_newty decl)
| otherwise
= td << vanillaTable << (header </> datadoc </> constrs)
@@ -512,10 +513,15 @@ ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
Just c = declMainBinder decl
doc = lookupFM doc_map c
+ no_constr_docs = all constr_has_no_doc cons
+
constr_has_no_doc (HsConDecl _ nm _ _)
= isNothing (lookupFM doc_map nm)
- constr_has_no_doc (HsRecDecl _ nm _ _)
- = isNothing (lookupFM doc_map nm)
+ constr_has_no_doc (HsRecDecl _ nm fields _)
+ = isNothing (lookupFM doc_map nm) && all field_has_no_doc fields
+
+ field_has_no_doc (HsFieldDecl nms _ _)
+ = trace (show nms ++ show (map (isNothing . lookupFM doc_map) nms)) $ all isNothing (map (lookupFM doc_map) nms)
ppShortConstr :: Bool -> HsConDecl -> Html
diff --git a/src/HsParser.ly b/src/HsParser.ly
index bae26ce6..fa0059b8 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.5 2002/04/26 11:18:57 simonmar Exp $
+$Id: HsParser.ly,v 1.6 2002/04/29 15:28:54 simonmar Exp $
(c) Simon Marlow, Sven Panne 1997-2000
@@ -16,6 +16,7 @@ ToDo: Differentiate between record updates and labeled construction.
> {
> module HsParser (parse) where
>
+> import Monad
> import HsSyn
> import HsParseMonad
> import HsLexer
@@ -442,17 +443,21 @@ Datatype declarations
> | constr { [$1] }
> constr :: { HsConDecl }
-> : srcloc scontype maybe_doc
-> { HsConDecl $1 (fst $2) (snd $2) $3 }
-> | srcloc sbtype conop sbtype maybe_doc
-> { HsConDecl $1 $3 [$2,$4] $5 }
-> | srcloc con '{' fielddecls '}' maybe_doc
-> { HsRecDecl $1 $2 $4 $6 }
-
-> maybe_doc :: { Maybe String }
+> : srcloc maybe_docnext scontype maybe_docprev
+> { HsConDecl $1 (fst $3) (snd $3) ($2 `mplus` $4) }
+> | srcloc maybe_docnext sbtype conop sbtype maybe_docprev
+> { HsConDecl $1 $4 [$3,$5] ($2 `mplus` $6) }
+> | srcloc maybe_docnext con '{' fielddecls '}' maybe_docprev
+> { HsRecDecl $1 $3 $5 ($2 `mplus` $7) }
+
+> maybe_docprev :: { Maybe String }
> : DOCPREV { Just $1 }
> | {- empty -} { Nothing }
+> maybe_docnext :: { Maybe String }
+> : DOCNEXT { Just $1 }
+> | {- empty -} { Nothing }
+
> scontype :: { (HsName, [HsBangType]) }
> : btype {% splitTyConApp $1 `thenP` \(c,ts) ->
> returnP (toVarHsName c,
@@ -481,7 +486,8 @@ Datatype declarations
> | {- empty -} { [] }
> fielddecl :: { HsFieldDecl }
-> : vars '::' stype { HsFieldDecl (reverse $1) $3 Nothing }
+> : maybe_docnext vars '::' stype maybe_docprev
+> { HsFieldDecl (reverse $2) $4 ($1 `mplus` $5) }
> stype :: { HsBangType }
> : ctype { HsUnBangedTy $1 }
diff --git a/src/Main.hs b/src/Main.hs
index dd7aac64..9873d2f8 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -445,7 +445,7 @@ collect name doc_so_far (decl:ds) =
Nothing -> collect name (doc_so_far ++ str) ds
Just n -> finishedDoc n doc_so_far (collect Nothing str ds)
- HsDocCommentPrev str -> collect name (doc_so_far++str) ds
+ HsDocCommentPrev str -> collect name (doc_so_far ++ str) ds
_other ->
docsFromDecl decl ++
--
cgit v1.2.3