From 613f21e3e09e2f9c9b6c24490b192811b6392b21 Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 3 Jun 2002 13:05:58 +0000 Subject: [haddock @ 2002-06-03 13:05:57 by simonmar] Allow exporting of individual class methods and record selectors. For these we have to invent the correct type signature, which we do in the simplest possible way (i.e. no context reduction nonsense in the class case). --- src/HaddockHtml.hs | 41 ++++++++++++++++++++++----------------- src/HaddockRename.hs | 12 +++--------- src/HaddockUtil.hs | 15 +++++++++------ src/HsParseUtils.lhs | 36 +++++++++++++++++++++-------------- src/HsParser.ly | 5 +++-- src/HsSyn.lhs | 4 ++-- src/Main.hs | 54 +++++++++++++++++++++++++++++++++++++++++++++------- 7 files changed, 110 insertions(+), 57 deletions(-) diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 29023524..f6f4aa3e 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -438,7 +438,7 @@ doDecl summary inst_maps x decl = do_decl decl do_decl decl@(HsDataDecl loc ctx nm args cons drv doc) = ppHsDataDecl summary inst_maps False{-not newtype-} x decl - do_decl decl@(HsClassDecl _ _ _ _ _) + do_decl decl@(HsClassDecl{}) = ppHsClassDecl summary inst_maps x decl do_decl (HsDocGroup loc lev str) @@ -611,15 +611,21 @@ ppHsBangType (HsUnBangedTy ty) = ppHsAType ty -- ----------------------------------------------------------------------------- -- Class declarations -ppClassHdr ty fds = - keyword "class" <+> ppHsType ty <+> +ppClassHdr [] n tvs fds = + keyword "class" <+> ppHsAsst (UnQual n, map HsTyVar tvs) <+> ppFds fds +ppClassHdr ctxt n tvs fds = + keyword "class" <+> ppHsContext ctxt <+> darrow <+> + ppHsAsst (UnQual n, map HsTyVar tvs) <+> ppFds fds + +ppFds fds = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map fundep fds)) where fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+> hsep (map ppHsName vars2) -ppShortClassDecl summary inst_maps decl@(HsClassDecl loc ty fds decls doc) = +ppShortClassDecl summary inst_maps + decl@(HsClassDecl loc ctxt nm tvs fds decls doc) = if null decls then declBox hdr else declBox (hdr <+> keyword "where") @@ -633,11 +639,11 @@ ppShortClassDecl summary inst_maps decl@(HsClassDecl loc ty fds decls doc) = where Just c = declMainBinder decl - hdr | not summary = linkTarget c +++ ppClassHdr ty fds - | otherwise = ppClassHdr ty fds + hdr | not summary = linkTarget c +++ ppClassHdr ctxt nm tvs fds + | otherwise = ppClassHdr ctxt nm tvs fds ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c - decl@(HsClassDecl loc ty fds decls doc) + decl@(HsClassDecl loc ctxt nm tvs fds decls doc) | summary = ppShortClassDecl summary inst_maps decl | otherwise @@ -650,9 +656,10 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c Just c = declMainBinder decl header - | null decls = declBox (linkTarget c +++ ppClassHdr ty fds) - | otherwise = declBox (linkTarget c +++ ppClassHdr ty fds <+> - keyword "where") + | null decls = declBox (linkTarget c +++ ppClassHdr ctxt nm tvs fds) + | otherwise = declBox (linkTarget c +++ + ppClassHdr ctxt nm tvs fds <+> + keyword "where") classdoc | Just d <- doc = ndocBox (docToHtml d) @@ -685,7 +692,7 @@ ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c ppInstHead :: InstHead -> Html ppInstHead ([],asst) = ppHsAsst asst -ppInstHead (ctxt,asst) = ppHsContext ctxt <+> toHtml "=>" <+> ppHsAsst asst +ppInstHead (ctxt,asst) = ppHsContext ctxt <+> darrow <+> ppHsAsst asst -- ---------------------------------------------------------------------------- -- Type signatures @@ -732,10 +739,6 @@ ppFunSig summary nm ty doc do_args leader ty = declBox (leader <+> ppHsBType ty) <-> rdocBox (noHtml) - dcolon = toHtml "::" - arrow = toHtml "->" - darrow = toHtml "=>" - -- ----------------------------------------------------------------------------- -- Types and contexts @@ -747,12 +750,12 @@ ppHsContext [] = empty ppHsContext context = parenList (map ppHsAsst context) ppHsForAll Nothing context = - hsep [ ppHsContext context, toHtml "=>" ] + hsep [ ppHsContext context, darrow ] ppHsForAll (Just tvs) [] = hsep (keyword "forall" : map ppHsName tvs ++ [toHtml "."]) ppHsForAll (Just tvs) context = hsep (keyword "forall" : map ppHsName tvs ++ - [toHtml ".", ppHsContext context, toHtml "=>"]) + [toHtml ".", ppHsContext context, darrow]) ppHsType :: HsType -> Html ppHsType (HsForAllType maybe_tvs context htype) = @@ -931,6 +934,10 @@ constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors" meth_hdr = tda [ theclass "section4" ] << toHtml "Methods" inst_hdr = tda [ theclass "section4" ] << toHtml "Instances" +dcolon = toHtml "::" +arrow = toHtml "->" +darrow = toHtml "=>" + s8, s15 :: HtmlTable s8 = tda [ theclass "s8" ] << noHtml s15 = tda [ theclass "s15" ] << noHtml diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index 71407cb9..c773131e 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -92,11 +92,11 @@ renameDecl decl con <- renameConDecl con doc <- renameMaybeDoc doc return (HsNewTypeDecl loc ctx t args con drv doc) - HsClassDecl loc qt fds decls doc -> do - qt <- renameClassHead qt + HsClassDecl loc ctxt nm tvs fds decls doc -> do + ctxt <- mapM renamePred ctxt decls <- mapM renameDecl decls doc <- renameMaybeDoc doc - return (HsClassDecl loc qt fds decls doc) + return (HsClassDecl loc ctxt nm tvs fds decls doc) HsTypeSig loc fs qt doc -> do qt <- renameType qt doc <- renameMaybeDoc doc @@ -115,12 +115,6 @@ renameDecl decl _ -> return decl -renameClassHead (HsForAllType tvs ctx ty) = do - ctx <- mapM renamePred ctx - return (HsForAllType tvs ctx ty) -renameClassHead ty = do - return ty - renameConDecl (HsConDecl loc nm tvs ctxt tys doc) = do tys <- mapM renameBangTy tys doc <- renameMaybeDoc doc diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 27595f33..b0ad3544 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -9,7 +9,7 @@ module HaddockUtil ( -- * Misc utilities nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp, - restrictTo, declDoc, parseModuleHeader, freeTyCons, + restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang, -- * Filename utilities basename, dirname, splitFilename3, @@ -36,13 +36,16 @@ nameOfQName (UnQual n) = n collectNames :: [HsDecl] -> [HsName] collectNames ds = concat (map declBinders ds) +unbang (HsUnBangedTy ty) = ty +unbang (HsBangedTy ty) = ty + declMainBinder :: HsDecl -> Maybe HsName declMainBinder d = case d of HsTypeDecl _ n _ _ _ -> Just n HsDataDecl _ _ n _ cons _ _ -> Just n HsNewTypeDecl _ _ n _ _ _ _ -> Just n - HsClassDecl _ qt _ decls _ -> Just (exQtNm qt) + HsClassDecl _ _ n _ _ decls _ -> Just n HsTypeSig _ [n] _ _ -> Just n HsTypeSig _ ns _ _ -> error "declMainBinder" HsForeignImport _ _ _ _ n _ _ -> Just n @@ -54,7 +57,7 @@ declBinders d = HsTypeDecl _ n _ _ _ -> [n] HsDataDecl _ _ n _ cons _ _ -> n : concat (map conDeclBinders cons) HsNewTypeDecl _ _ n _ con _ _ -> n : conDeclBinders con - HsClassDecl _ qt _ decls _ -> exQtNm qt : collectNames decls + HsClassDecl _ _ n _ _ decls _ -> n : collectNames decls HsTypeSig _ ns _ _ -> ns HsForeignImport _ _ _ _ n _ _ -> [n] _ -> [] @@ -95,8 +98,8 @@ restrictTo names decl = case decl of HsDataDecl loc ctxt n xs (restrictCons names cons) drv doc HsNewTypeDecl loc ctxt n xs con drv doc -> HsDataDecl loc ctxt n xs (restrictCons names [con]) drv doc - HsClassDecl loc qt fds decls doc -> - HsClassDecl loc qt fds (restrictDecls names decls) doc + HsClassDecl loc ctxt n tys fds decls doc -> + HsClassDecl loc ctxt n tys fds (restrictDecls names decls) doc _ -> decl restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl] @@ -116,7 +119,7 @@ restrictDecls names decls = filter keep decls declDoc (HsTypeDecl _ _ _ _ d) = d declDoc (HsDataDecl _ _ _ _ _ _ d) = d declDoc (HsNewTypeDecl _ _ _ _ _ _ d) = d -declDoc (HsClassDecl _ _ _ _ d) = d +declDoc (HsClassDecl _ _ _ _ _ _ d) = d declDoc (HsTypeSig _ _ _ d) = d declDoc (HsForeignImport _ _ _ _ _ _ d) = d declDoc _ = Nothing diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs index 148fff07..a287cb9d 100644 --- a/src/HsParseUtils.lhs +++ b/src/HsParseUtils.lhs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: HsParseUtils.lhs,v 1.3 2002/05/27 09:03:52 simonmar Exp $ +-- $Id: HsParseUtils.lhs,v 1.4 2002/06/03 13:05:58 simonmar Exp $ -- -- (c) The GHC Team 1997-2000 -- @@ -18,8 +18,8 @@ module HsParseUtils ( , checkContext -- HsType -> P HsContext , checkAssertion -- HsType -> P HsAsst , checkInstHeader -- HsType -> P (HsContext, HsAsst) + , checkClassHeader -- HsType -> P (HsContext, HsName, [HsType]) , checkDataHeader -- HsType -> P (HsContext,HsName,[HsName]) - , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) , checkPattern -- HsExp -> P HsPat , checkPatterns -- [HsExp] -> P [HsPat] , checkExpr -- HsExp -> P HsExp @@ -73,7 +73,6 @@ checkAssertion = checkAssertion' [] checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a checkAssertion' _ _ = parseError "Illegal class assertion" - checkInstHeader :: HsType -> P (HsContext, HsAsst) checkInstHeader (HsForAllType Nothing ctxt ty) = checkAssertion ty `thenP` \asst -> @@ -84,17 +83,26 @@ checkInstHeader ty = checkDataHeader :: HsType -> P (HsContext,HsName,[HsName]) checkDataHeader (HsForAllType Nothing cs t) = - checkSimple t [] `thenP` \(c,ts) -> - returnP (cs,c,ts) -checkDataHeader t = - checkSimple t [] `thenP` \(c,ts) -> - returnP ([],c,ts) - -checkSimple :: HsType -> [HsName] -> P ((HsName,[HsName])) -checkSimple (HsTyApp l (HsTyVar a)) xs = checkSimple l (a:xs) -checkSimple (HsTyCon (UnQual t)) xs = returnP (t,xs) -checkSimple (HsTyCon (Qual m t)) xs = returnP (t,xs) -checkSimple _ _ = parseError "Illegal data/newtype declaration" + checkSimple "data/newtype" t [] `thenP` \(c,ts) -> + returnP (cs,c,ts) +checkDataHeader ty = + checkSimple "data/newtype" ty [] `thenP` \(c,ts) -> + returnP ([],c,ts) + +checkClassHeader :: HsType -> P (HsContext,HsName,[HsName]) +checkClassHeader (HsForAllType Nothing cs t) = + checkSimple "class" t [] `thenP` \(c,ts) -> + returnP (cs,c,ts) +checkClassHeader ty = + checkSimple "class" ty [] `thenP` \(c,ts) -> + returnP ([],c,ts) + +checkSimple :: String -> HsType -> [HsName] -> P ((HsName,[HsName])) +checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs) +checkSimple _kw (HsTyCon (UnQual t)) xs = returnP (t,xs) +checkSimple kw (HsTyCon (Qual m t)) xs + | m == prelude_mod = returnP (t,xs) -- for "special" declarations +checkSimple kw _ _ = failP ("Illegal " ++ kw ++ " declaration") ----------------------------------------------------------------------------- -- Checking Patterns. diff --git a/src/HsParser.ly b/src/HsParser.ly index 4c12adc7..0fae07e4 100644 --- a/src/HsParser.ly +++ b/src/HsParser.ly @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- -$Id: HsParser.ly,v 1.12 2002/05/27 09:03:52 simonmar Exp $ +$Id: HsParser.ly,v 1.13 2002/06/03 13:05:58 simonmar Exp $ (c) Simon Marlow, Sven Panne 1997-2002 @@ -304,7 +304,8 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux. > {% checkDataHeader $2 `thenP` \(cs,c,t) -> > returnP (HsNewTypeDecl $3 cs c t $5 $6 Nothing) } > | 'class' srcloc ctype fds optcbody -> { HsClassDecl $2 $3 $4 $5 Nothing} +> {% checkClassHeader $3 `thenP` \(ctxt,n,tys) -> +> returnP (HsClassDecl $2 ctxt n tys $4 $5 Nothing) } > | 'instance' srcloc ctype optvaldefs > {% checkInstHeader $3 `thenP` \(ctxt,asst) -> > returnP (HsInstDecl $2 ctxt asst $4) } diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs index 8f3ef31d..4d858524 100644 --- a/src/HsSyn.lhs +++ b/src/HsSyn.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: HsSyn.lhs,v 1.10 2002/05/27 09:03:52 simonmar Exp $ +% $Id: HsSyn.lhs,v 1.11 2002/06/03 13:05:58 simonmar Exp $ % % (c) The GHC Team, 1997-2002 % @@ -142,7 +142,7 @@ data HsDecl | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName] (Maybe Doc) - | HsClassDecl SrcLoc HsType [HsFunDep] [HsDecl] (Maybe Doc) + | HsClassDecl SrcLoc HsContext HsName [HsName] [HsFunDep] [HsDecl] (Maybe Doc) | HsInstDecl SrcLoc HsContext HsAsst [HsDecl] diff --git a/src/Main.hs b/src/Main.hs index 4d26bd3b..f26c473e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -284,7 +284,8 @@ mkExportItems mod_map mod decl_map decls options maybe_exps lookupExport (HsEVar x) | Just decl <- findDecl x - = return [ ExportDecl x decl ] + = return [ ExportDecl x (extractDecl (nameOfQName x) x_mod decl) ] + where x_mod | Qual m _ <- x = m -- ToDo: cope with record selectors here lookupExport (HsEAbs t) | Just decl <- findDecl t @@ -342,6 +343,45 @@ keepDecl HsClassDecl{} = True keepDecl HsDocGroup{} = True keepDecl _ = False +-- Sometimes the declaration we want to export is not the "main" declaration: +-- it might be an individual record selector or a class method. In these +-- cases we have to extract the required declaration (and somehow cobble +-- together a type signature for it...) + +extractDecl :: HsName -> Module -> HsDecl -> HsDecl +extractDecl name mod decl + | Just n <- declMainBinder decl, n == name = decl + | otherwise = + case decl of + HsClassDecl loc ctxt n tvs fds decls mb_doc -> + case [ d | d@HsTypeSig{} <- decls, + declMainBinder d == Just name ] of + [decl] -> extractClassDecl n mod tvs decl + _ -> error "internal: extractDecl" + + HsDataDecl loc ctxt t tvs cons drvs mb_doc -> + extractRecSel name mod t tvs cons + +extractClassDecl c mod tvs (HsTypeSig loc [n] ty doc) + = case ty of + HsForAllType tvs ctxt' ty' -> + HsTypeSig loc [n] (HsForAllType tvs (ctxt ++ ctxt') ty') doc + ty -> + HsTypeSig loc [n] (HsForAllType Nothing ctxt ty) doc + where + ctxt = [(Qual mod c, map HsTyVar tvs)] + +extractRecSel nm mod t tvs [] = error "extractRecSel: selector not found" +extractRecSel nm mod t tvs (HsRecDecl loc c _tvs ctxt fields _mb_doc : rest) + | (HsFieldDecl ns ty mb_doc : _) <- matching_fields + = HsTypeSig loc [nm] (HsTyFun data_ty (unbang ty)) mb_doc + | otherwise = extractRecSel nm mod t tvs rest + where + matching_fields = [ f | f@(HsFieldDecl ns ty mb_doc) <- fields, + nm `elem` ns ] + + data_ty = foldl HsTyApp (HsTyCon (Qual mod t)) (map HsTyVar tvs) + -- ----------------------------------------------------------------------------- -- Pruning @@ -455,8 +495,8 @@ buildImportEnv mod_map this_mod exported_names imp_decls expandDecl :: HsDecl -> [HsDecl] expandDecl (HsTypeSig loc fs qt doc) = [ HsTypeSig loc [f] qt doc | f <- fs ] -expandDecl (HsClassDecl loc ty fds decls doc) - = [ HsClassDecl loc ty fds (concat (map expandDecl decls)) doc ] +expandDecl (HsClassDecl loc ctxt n tvs fds decls doc) + = [ HsClassDecl loc ctxt n tvs fds (concat (map expandDecl decls)) doc ] expandDecl d = [ d ] ----------------------------------------------------------------------------- @@ -495,16 +535,16 @@ finishedDoc d doc rest = d' : rest HsDataDecl loc ctxt n ns cons drv (Just doc) HsNewTypeDecl loc ctxt n ns con drv _ -> HsNewTypeDecl loc ctxt n ns con drv (Just doc) - HsClassDecl loc ty fds meths _ -> - HsClassDecl loc ty fds meths (Just doc) + HsClassDecl loc ctxt n tvs fds meths _ -> + HsClassDecl loc ctxt n tvs fds meths (Just doc) HsTypeSig loc ns ty _ -> HsTypeSig loc ns ty (Just doc) HsForeignImport loc cc sf str n ty _ -> HsForeignImport loc cc sf str n ty (Just doc) _other -> d -collectInDecl (HsClassDecl loc ty fds meths doc) - = HsClassDecl loc ty fds (collect Nothing DocEmpty meths) doc +collectInDecl (HsClassDecl loc ctxt n tvs fds meths doc) + = HsClassDecl loc ctxt n tvs fds (collect Nothing DocEmpty meths) doc collectInDecl decl = decl -- cgit v1.2.3