aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/HaddockHtml.hs41
-rw-r--r--src/HaddockRename.hs12
-rw-r--r--src/HaddockUtil.hs15
-rw-r--r--src/HsParseUtils.lhs36
-rw-r--r--src/HsParser.ly5
-rw-r--r--src/HsSyn.lhs4
-rw-r--r--src/Main.hs54
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 08:18:11 +0000