aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/HaddockDB.hs4
-rw-r--r--src/HaddockHtml.hs30
-rw-r--r--src/HaddockRename.hs8
-rw-r--r--src/HaddockUtil.hs9
-rw-r--r--src/HsParser.ly30
-rw-r--r--src/HsSyn.lhs6
-rw-r--r--src/Main.hs6
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 _
= []
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 16:36:29 +0000