[haddock @ 2002-05-08 14:48:39 by simonmar]

Add support for existential quantifiers on constructors.

7 files changed, 58 insertions, 35 deletions

diff --git a/src/HaddockDB.hs b/src/HaddockDB.hs
index 80bc1b7c..a2a4a8e7 100644
--- a/src/HaddockDB.hs
+++ b/src/HaddockDB.hs
@@ -76,10 +76,10 @@ ppIfaces mods
 	= empty
 
 ppHsConstr :: HsConDecl -> Doc
-ppHsConstr (HsRecDecl pos name fieldList maybe_doc) =
+ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
 	 ppHsName name
 	 <> (braces . hsep . punctuate comma . map ppField $ fieldList)
-ppHsConstr (HsConDecl pos name typeList maybe_doc) = 
+ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = 
 	 hsep (ppHsName name : map ppHsBangType typeList)
 
 ppField (HsFieldDecl ns ty doc)
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 7d7700a4..92e16e72 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -519,9 +519,9 @@ ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
 
 	no_constr_docs = all constr_has_no_doc cons
 
-	constr_has_no_doc (HsConDecl _ nm _ _) 
+	constr_has_no_doc (HsConDecl _ nm _ _ _ _) 
 	   = isNothing (lookupFM doc_map nm)
-	constr_has_no_doc (HsRecDecl _ nm fields _)
+	constr_has_no_doc (HsRecDecl _ nm _ _ fields _)
 	   = isNothing (lookupFM doc_map nm) && all field_has_no_doc fields
 
  	field_has_no_doc (HsFieldDecl nms _ _)
@@ -529,26 +529,36 @@ ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
 
 
 ppShortConstr :: Bool -> HsConDecl -> Html
-ppShortConstr summary (HsConDecl pos nm typeList _maybe_doc) = 
-   hsep (ppHsBinder summary nm : map ppHsBangType typeList)
-ppShortConstr summary (HsRecDecl pos nm fields maybe_doc) =
+ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) = 
+   ppHsConstrHdr tvs ctxt +++
+	hsep (ppHsBinder summary nm : map ppHsBangType typeList)
+ppShortConstr summary (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
+   ppHsConstrHdr tvs ctxt +++
    ppHsBinder summary nm +++
    braces (vanillaTable << aboves (map (ppShortField summary) fields))
 
-ppHsFullConstr doc_map (HsConDecl pos nm typeList _maybe_doc) = 
+ppHsConstrHdr tvs ctxt
+ = (if null tvs then noHtml else keyword "forall" <+> 
+				 hsep (map ppHsName tvs) <+> 
+				 toHtml ". ")
+   +++
+   (if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")
+
+ppHsFullConstr doc_map (HsConDecl pos nm tvs ctxt typeList _maybe_doc) = 
      declWithDoc False doc (
-	hsep (ppHsBinder False nm : map ppHsBangType typeList)
+	hsep ((ppHsConstrHdr tvs ctxt +++ 
+		ppHsBinder False nm) : map ppHsBangType typeList)
       )
    where
      doc = lookupFM doc_map nm
-ppHsFullConstr doc_map (HsRecDecl pos nm fields maybe_doc) =
+ppHsFullConstr doc_map (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
    td << vanillaTable << (
      case doc of
        Nothing  -> aboves [hdr, fields_html]
        Just doc -> aboves [hdr, constr_doc, fields_html]
    )
 
-  where hdr = declBox (ppHsBinder False nm)
+  where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
 	constr_doc = docBox (markup htmlMarkup (fromJust doc))
 	fields_html = 
 	   td << 
@@ -757,7 +767,7 @@ equals = char '='
 comma  = char ','
 
 char c = toHtml [c]
-empty  = toHtml ""
+empty  = noHtml
 
 parens p        = char '(' +++ p +++ char ')'
 brackets p      = char '[' +++ p +++ char ']'
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index f897c600..59d71bd5 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -104,12 +104,12 @@ renameClassHead (HsForAllType tvs ctx ty) = do
 renameClassHead ty = do
   return ty
 
-renameConDecl (HsConDecl loc nm tys maybe_doc) = do
+renameConDecl (HsConDecl loc nm tvs ctxt tys maybe_doc) = do
   tys <- mapM renameBangTy tys
-  return (HsConDecl loc nm tys maybe_doc)
-renameConDecl (HsRecDecl loc nm fields maybe_doc) = do
+  return (HsConDecl loc nm tvs ctxt tys maybe_doc)
+renameConDecl (HsRecDecl loc nm tvs ctxt fields maybe_doc) = do
   fields <- mapM renameField fields
-  return (HsRecDecl loc nm fields maybe_doc)
+  return (HsRecDecl loc nm tvs ctxt fields maybe_doc)
 
 renameField (HsFieldDecl ns ty doc) = do 
   ty <- renameBangTy ty
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index be4b2d88..ef209f98 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -58,8 +58,9 @@ declBinders d =
      HsForeignImport _ _ _ _ n _ -> [n]
      _                           -> []
 
-conDeclBinders (HsConDecl _ n _ _) = [n]
-conDeclBinders (HsRecDecl _ n fields _) = n : concat (map fieldDeclBinders fields)
+conDeclBinders (HsConDecl _ n _ _ _ _) = [n]
+conDeclBinders (HsRecDecl _ n _ _ fields _) = 
+  n : concat (map fieldDeclBinders fields)
 
 fieldDeclBinders (HsFieldDecl ns _ _) = ns
 
@@ -89,8 +90,8 @@ restrictTo names decl = case decl of
    
 restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
 restrictCons names decls = filter keep decls
-  where keep (HsConDecl _ n _ _) = n `elem` names
-	keep (HsRecDecl _ n _ _) = n `elem` names
+  where keep (HsConDecl _ n _ _ _ _) = n `elem` names
+	keep (HsRecDecl _ n _ _ _ _) = n `elem` names
 	-- ToDo: records not right
 
 restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 2ca9c88f..cc92b4e7 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.8 2002/05/08 11:21:56 simonmar Exp $
+$Id: HsParser.ly,v 1.9 2002/05/08 14:48:41 simonmar Exp $
 
 (c) Simon Marlow, Sven Panne 1997-2000
 
@@ -426,10 +426,12 @@ C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!
 
 > ctype :: { HsType }
 >	: 'forall' tyvars '.' ctype	{ mkHsForAllType (Just $2) [] $4 }
->	| btype '=>' type		{% checkContext $1 `thenP` \c ->
->					   returnP (mkHsForAllType Nothing c $3) }
+>	| context '=>' type		{ mkHsForAllType Nothing $1 $3 }
 >	| type				{ $1 }
 
+> context :: { HsContext }
+> 	: btype				{% checkContext $1 }
+
 > types	:: { [HsType] }
 >	: type ',' types		{ $1 : $3 }
 >	| type  ',' type		{ [$1,$3] }
@@ -453,12 +455,22 @@ Datatype declarations
 >	| constr			{ [$1] }
 
 > constr :: { HsConDecl }
->	: 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) }
+>	: srcloc maybe_docnext forall_stuff constr_stuff maybe_docprev
+>		{ HsConDecl $1 (fst $4) $3 [] (snd $4) ($2 `mplus` $5) }
+>	| srcloc maybe_docnext forall_stuff context '=>' constr_stuff maybe_docprev
+>		{ HsConDecl $1 (fst $6) $3 $4 (snd $6) ($2 `mplus` $7) }
+> 	| srcloc maybe_docnext forall_stuff con '{' fielddecls '}' maybe_docprev
+> 		{ HsRecDecl $1 $4 $3 [] $6 ($2 `mplus` $8) }
+> 	| srcloc maybe_docnext forall_stuff context '=>' con '{' fielddecls '}' maybe_docprev
+> 		{ HsRecDecl $1 $6 $3 $4 $8 ($2 `mplus` $10) }
+
+> forall_stuff :: { [HsName] }
+> 	: 'forall' tyvars '.'		 	{ $2 }
+> 	| {- empty -}				{ [] }
+
+> constr_stuff :: { (HsName, [HsBangType]) }
+> 	: scontype 				{ $1 }
+>	| sbtype conop sbtype			{ ($2, [$1,$3]) }
 
 > maybe_docprev :: { Maybe String }
 > 	: DOCPREV			{ Just $1 }
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index 5054a8df..ab274ee0 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.6 2002/05/08 11:21:56 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.7 2002/05/08 14:48:41 simonmar Exp $
 %
 % (c) The GHC Team, 1997-2002
 %
@@ -140,8 +140,8 @@ data HsMatch
   deriving (Eq,Show)
 
 data HsConDecl
-	 = HsConDecl SrcLoc HsName [HsBangType] (Maybe String)
-	 | HsRecDecl SrcLoc HsName [HsFieldDecl] (Maybe String)
+     = HsConDecl SrcLoc HsName [HsName] HsContext [HsBangType] (Maybe String)
+     | HsRecDecl SrcLoc HsName [HsName] HsContext [HsFieldDecl] (Maybe String)
   deriving (Eq,Show)
 
 data HsFieldDecl
diff --git a/src/Main.hs b/src/Main.hs
index c5d39844..f868210f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -525,11 +525,11 @@ docsFromDecl _
   = []
 
 docsFromConDecl :: HsConDecl -> [(HsName, DocString)]
-docsFromConDecl (HsConDecl loc nm tys (Just doc))
+docsFromConDecl (HsConDecl loc nm tvs ctxt tys (Just doc))
   = finishedDoc nm doc []
-docsFromConDecl (HsRecDecl loc nm fields (Just doc))
+docsFromConDecl (HsRecDecl loc nm tvs ctxt fields (Just doc))
   = finishedDoc nm doc (foldr docsFromField [] fields)
-docsFromConDecl (HsRecDecl loc nm fields Nothing)
+docsFromConDecl (HsRecDecl loc nm tvs ctxt fields Nothing)
   = foldr docsFromField [] fields
 docsFromConDecl _ 
   = []