[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).

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