From db23f65e1d2a82ac7d86c055cac66b35a3f68940 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 8 May 2002 14:48:41 +0000 Subject: [haddock @ 2002-05-08 14:48:39 by simonmar] Add support for existential quantifiers on constructors. --- src/HaddockDB.hs | 4 ++-- src/HaddockHtml.hs | 30 ++++++++++++++++++++---------- src/HaddockRename.hs | 8 ++++---- src/HaddockUtil.hs | 9 +++++---- src/HsParser.ly | 30 +++++++++++++++++++++--------- src/HsSyn.lhs | 6 +++--- src/Main.hs | 6 +++--- 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 _ = [] -- cgit v1.2.3