aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsimonmar <unknown>2002-05-27 09:03:52 +0000
committersimonmar <unknown>2002-05-27 09:03:52 +0000
commita4e4c5f822416dbe2b8abe34301e8d3e39051bc1 (patch)
tree48743b04e3ebced1288b7ee51700f01fb4d02fa3
parent01c2ddd27ae8776b03464d091d6dce989b7ee13f (diff)
[haddock @ 2002-05-27 09:03:51 by simonmar]
Lots of changes: - instances of a class are listed with the class, and instances involving a datatype are listed with that type. Derived instances aren't included at the moment: the calculation to find the instance head for a derived instance is non-trivial. - some formatting changes; use rows with specified height rather than cellspacing in some places. - various fixes (source file links were wrong, amongst others)
-rw-r--r--src/HaddockHtml.hs257
-rw-r--r--src/HaddockRename.hs8
-rw-r--r--src/HaddockTypes.hs10
-rw-r--r--src/HaddockUtil.hs12
-rw-r--r--src/HsParseUtils.lhs11
-rw-r--r--src/HsParser.ly5
-rw-r--r--src/HsSyn.lhs4
-rw-r--r--src/Main.hs105
8 files changed, 257 insertions, 155 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 87d76d51..61113154 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -32,14 +32,19 @@ iconFile = "haskell_icon.gif"
-- -----------------------------------------------------------------------------
-- Generating HTML documentation
+type InstMaps =
+ (FiniteMap HsQName [InstHead], -- maps class names to instances
+ FiniteMap HsQName [InstHead]) -- maps type names to instances
+
ppHtml :: String
-> Maybe String
-> [(Module, Interface)]
-> FilePath -- destination directory
-> Maybe String -- CSS file
-> String -- $libdir
+ -> InstMaps
-> IO ()
-ppHtml title source_url ifaces odir maybe_css libdir = do
+ppHtml title source_url ifaces odir maybe_css libdir inst_maps = do
let
css_file = case maybe_css of
Nothing -> libdir ++ pathSeparator:cssFile
@@ -59,7 +64,7 @@ ppHtml title source_url ifaces odir maybe_css libdir = do
ppHtmlContents odir title source_url (map fst visible_ifaces)
ppHtmlIndex odir title visible_ifaces
- mapM_ (ppHtmlModule odir title source_url) visible_ifaces
+ mapM_ (ppHtmlModule odir title source_url inst_maps) visible_ifaces
moduleHtmlFile :: String -> FilePath
moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename?
@@ -131,15 +136,14 @@ pageHeader mod iface title source_url =
moduleInfo iface
| Nothing <- iface_info iface = Html.emptyTable
| Just info <- iface_info iface =
- tda [align "right"] <<
- (table ! [border 0, cellspacing 0, cellpadding 0] << (
+ tda [align "right"] << narrowTable << (
(tda [theclass "infohead"] << toHtml "Portability") <->
(tda [theclass "infoval"] << toHtml (portability info)) </>
(tda [theclass "infohead"] << toHtml "Stability") <->
(tda [theclass "infoval"] << toHtml (stability info)) </>
(tda [theclass "infohead"] << toHtml "Maintainer") <->
(tda [theclass "infoval"] << toHtml (maintainer info))
- ))
+ )
-- ---------------------------------------------------------------------------
-- Generate the module contents
@@ -292,30 +296,29 @@ idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]
-- ---------------------------------------------------------------------------
-- Generate the HTML page for a module
-ppHtmlModule :: FilePath -> String -> Maybe String
+ppHtmlModule :: FilePath -> String -> Maybe String -> InstMaps
-> (Module,Interface) -> IO ()
-ppHtmlModule odir title source_url (Module mod,iface) = do
+ppHtmlModule odir title source_url inst_maps (Module mod,iface) = do
let html =
header (thetitle (toHtml mod) +++
thelink ! [href cssFile,
rel "stylesheet", thetype "text/css"]) +++
body << vanillaTable << (
- pageHeader mod iface title source_url </>
- ifaceToHtml mod iface </>
+ pageHeader mod iface title source_url </> s15 </>
+ ifaceToHtml mod iface inst_maps </> s15 </>
footer
)
writeFile (odir ++ pathSeparator:moduleHtmlFile mod) (renderHtml html)
-ifaceToHtml :: String -> Interface -> HtmlTable
-ifaceToHtml mod iface
+ifaceToHtml :: String -> Interface -> InstMaps -> HtmlTable
+ifaceToHtml mod iface inst_maps
| null exports = Html.emptyTable
- | otherwise =
- td << table ! [width "100%", cellpadding 0, cellspacing 15] <<
- (contents </> description </> synopsis </> maybe_hr </> body)
+ | otherwise =
+ abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: body)
where
exports = numberSectionHeadings (iface_exports iface)
- has_doc (ExportDecl d) = isJust (declDoc d)
+ has_doc (ExportDecl _ d) = isJust (declDoc d)
has_doc (ExportModule _) = False
has_doc _ = True
@@ -335,16 +338,22 @@ ifaceToHtml mod iface
| no_doc_at_all = Html.emptyTable
| otherwise
= (tda [theclass "section1"] << toHtml "Synopsis") </>
- (tda [width "100%", theclass "synopsis"] <<
- table ! [width "100%", cellpadding 0, cellspacing 8, border 0] <<
- aboves (map (processExport True) exports))
-
- maybe_hr
- | not (no_doc_at_all), ExportGroup 1 _ _ <- head exports
- = td << hr
+ s15 </>
+ (tda [theclass "body"] << vanillaTable <<
+ abovesSep s8 (map (processExport True inst_maps)
+ (filter forSummary exports))
+ )
+
+ -- if the documentation doesn't begin with a section header, then
+ -- add one ("Documentation").
+ maybe_doc_hdr
+ | not (no_doc_at_all) =
+ case exports of
+ ExportGroup _ _ _ : _ -> Html.emptyTable
+ _ -> tda [ theclass "section1" ] << toHtml "Documentation"
| otherwise = Html.emptyTable
- body = aboves (map (processExport False) exports)
+ body = map (processExport False inst_maps) exports
ppModuleContents :: [ExportItem] -> HtmlTable
ppModuleContents exports
@@ -379,18 +388,20 @@ numberSectionHeadings exports = go 1 exports
go n (other:es)
= other : go n es
-processExport :: Bool -> ExportItem -> HtmlTable
-processExport summary (ExportGroup lev id doc)
- | summary = Html.emptyTable
- | otherwise = ppDocGroup lev (anchor ! [name id] << docToHtml doc)
-processExport summary (ExportDecl decl)
- = doDecl summary decl
-processExport summary (ExportDoc doc)
- | summary = Html.emptyTable
- | otherwise = docBox (docToHtml doc)
-processExport summary (ExportModule (Module mod))
+processExport :: Bool -> InstMaps -> ExportItem -> HtmlTable
+processExport summary inst_maps (ExportGroup lev id doc)
+ = ppDocGroup lev (anchor ! [name id] << docToHtml doc)
+processExport summary inst_maps (ExportDecl x decl)
+ = doDecl summary inst_maps x decl
+processExport summary inst_maps (ExportDoc doc)
+ = docBox (docToHtml doc)
+processExport summary inst_maps (ExportModule (Module mod))
= declBox (toHtml "module" <+> ppHsModule mod)
+forSummary (ExportGroup _ _ _) = False
+forSummary (ExportDoc _) = False
+forSummary _ = True
+
ppDocGroup lev doc
| lev == 1 = tda [ theclass "section1" ] << doc
| lev == 2 = tda [ theclass "section2" ] << doc
@@ -404,18 +415,16 @@ declWithDoc :: Bool -> Maybe Doc -> Html -> HtmlTable
declWithDoc True doc html_decl = declBox html_decl
declWithDoc False Nothing html_decl = declBox html_decl
declWithDoc False (Just doc) html_decl =
- tda [width "100%"] <<
- vanillaTable <<
- (declBox html_decl </> docBox (docToHtml doc))
+ declBox html_decl </> docBox (docToHtml doc)
-doDecl :: Bool -> HsDecl -> HtmlTable
-doDecl summary decl = do_decl decl
+doDecl :: Bool -> InstMaps -> HsQName -> HsDecl -> HtmlTable
+doDecl summary inst_maps x decl = do_decl decl
where
do_decl (HsTypeSig _ [nm] ty doc)
= ppFunSig summary nm ty doc
do_decl (HsForeignImport _ _ _ _ n ty doc)
- = declWithDoc summary doc (ppTypeSig summary n ty)
+ = ppFunSig summary n ty doc
do_decl (HsTypeDecl _ nm args ty doc)
= declWithDoc summary doc (
@@ -423,15 +432,15 @@ doDecl summary decl = do_decl decl
++ map ppHsName args) <+> equals <+> ppHsType ty)
do_decl (HsNewTypeDecl loc ctx nm args con drv doc)
- = ppHsDataDecl summary True{-is newtype-}
+ = ppHsDataDecl summary inst_maps True{-is newtype-} x
(HsDataDecl loc ctx nm args [con] drv doc)
-- print it as a single-constructor datatype
do_decl decl@(HsDataDecl loc ctx nm args cons drv doc)
- = ppHsDataDecl summary False{-not newtype-} decl
+ = ppHsDataDecl summary inst_maps False{-not newtype-} x decl
do_decl decl@(HsClassDecl _ _ _ _ _)
- = ppHsClassDecl summary decl
+ = ppHsClassDecl summary inst_maps x decl
do_decl (HsDocGroup loc lev str)
= if summary then Html.emptyTable
@@ -470,49 +479,56 @@ ppShortDataDecl summary is_newty
-- First, the abstract case:
-ppHsDataDecl summary is_newty (HsDataDecl loc ctx nm args [] drv doc) =
+ppHsDataDecl summary inst_maps is_newty x
+ (HsDataDecl loc ctx nm args [] drv doc) =
declWithDoc summary doc (ppHsDataHeader summary is_newty nm args)
-- The rest of the cases:
-ppHsDataDecl summary is_newty decl@(HsDataDecl loc ctx nm args cons drv doc)
- | summary || (isNothing doc && no_constr_docs)
- = declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
+ppHsDataDecl summary (_, ty_inst_map) is_newty
+ x decl@(HsDataDecl loc ctx nm args cons drv doc)
+ | summary = declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
| otherwise
- = td << vanillaTable << (
- header </>
+ = header </>
tda [theclass "body"] << vanillaTable << (
datadoc </>
constr_hdr </>
- (tda [theclass "body"] << table << constrs))
- )
+ (tda [theclass "body"] << constr_table << constrs) </>
+ instances_bit
+ )
where
header = declBox (ppHsDataHeader False is_newty nm args)
- table
- | any isRecDecl cons = spacedTable5
- | otherwise = spacedTable1
+ constr_table
+ | any isRecDecl cons = spacedTable5
+ | otherwise = spacedTable1
- datadoc
- | isJust doc = ndocBox (docToHtml (fromJust doc))
- | otherwise = Html.emptyTable
-
- constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
+ datadoc | isJust doc = ndocBox (docToHtml (fromJust doc))
+ | otherwise = Html.emptyTable
- constrs
- | null cons = Html.emptyTable
- | otherwise = aboves (map ppSideBySideConstr cons)
+ constrs | null cons = Html.emptyTable
+ | otherwise = aboves (map ppSideBySideConstr cons)
no_constr_docs = all constr_has_no_doc cons
- constr_has_no_doc (HsConDecl _ nm _ _ _ doc)
- = isNothing doc
- constr_has_no_doc (HsRecDecl _ nm _ _ fields doc)
- = isNothing doc && all field_has_no_doc fields
+ instances = lookupFM ty_inst_map x
+
+ instances_bit
+ = case instances of
+ Nothing -> Html.emptyTable
+ Just [] -> Html.emptyTable
+ Just is ->
+ inst_hdr </>
+ tda [theclass "body"] << spacedTable1 << (
+ aboves (map (declBox.ppInstHead) is)
+ )
+
+constr_has_no_doc (HsConDecl _ _ _ _ _ doc) = isNothing doc
+constr_has_no_doc (HsRecDecl _ _ _ _ fields doc)
+ = isNothing doc && all field_has_no_doc fields
- field_has_no_doc (HsFieldDecl nms _ doc)
- = isNothing doc
+field_has_no_doc (HsFieldDecl nms _ doc) = isNothing doc
isRecDecl (HsRecDecl pos nm tvs ctxt fields maybe_doc) = True
isRecDecl _ = False
@@ -523,7 +539,7 @@ ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) =
hsep (ppHsBinder summary nm : map ppHsBangType typeList)
ppShortConstr summary (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
ppHsConstrHdr tvs ctxt +++
- ppHsBinder summary nm +++
+ ppHsBinder summary nm <+>
braces (vanillaTable << aboves (map (ppShortField summary) fields))
ppHsConstrHdr tvs ctxt
@@ -534,11 +550,11 @@ ppHsConstrHdr tvs ctxt
(if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")
ppSideBySideConstr (HsConDecl pos nm tvs ctxt typeList doc) =
- narrowDeclBox (hsep ((ppHsConstrHdr tvs ctxt +++
+ declBox (hsep ((ppHsConstrHdr tvs ctxt +++
ppHsBinder False nm) : map ppHsBangType typeList)) <->
maybeRDocBox doc
ppSideBySideConstr (HsRecDecl pos nm tvs ctxt fields doc) =
- narrowDeclBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <->
+ declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) <->
maybeRDocBox doc </>
(tda [theclass "body"] << spacedTable1 <<
aboves (map ppSideBySideField fields))
@@ -606,29 +622,32 @@ ppClassHdr ty fds =
fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
hsep (map ppHsName vars2)
-ppShortClassDecl summary decl@(HsClassDecl loc ty fds decls doc) =
+ppShortClassDecl summary inst_maps decl@(HsClassDecl loc ty fds decls doc) =
if null decls
then declBox hdr
- else td << (
- vanillaTable << (
- declBox (hdr <+> keyword "where")
+ else declBox (hdr <+> keyword "where")
</>
- tda [theclass "body"] << (
- vanillaTable << (
- aboves (map (doDecl summary) (filter keepDecl decls))
- ))
- ))
+ (tda [theclass "body"] <<
+ vanillaTable <<
+ aboves [ ppFunSig summary n ty doc
+ | HsTypeSig _ [n] ty doc <- decls
+ ]
+ )
+
where
Just c = declMainBinder decl
hdr | not summary = linkTarget c +++ ppClassHdr ty fds
| otherwise = ppClassHdr ty fds
-ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc)
- | summary || (isNothing doc && all decl_has_no_doc kept_decls)
- = ppShortClassDecl summary decl
+ppHsClassDecl summary inst_maps@(cls_inst_map, _) orig_c
+ decl@(HsClassDecl loc ty fds decls doc)
+ | summary = ppShortClassDecl summary inst_maps decl
| otherwise
- = td << vanillaTable << (header </> classdoc </> body)
+ = header </>
+ tda [theclass "body"] << vanillaTable << (
+ classdoc </> methods_bit </> instances_bit
+ )
where
Just c = declMainBinder decl
@@ -639,24 +658,39 @@ ppHsClassDecl summary decl@(HsClassDecl loc ty fds decls doc)
keyword "where")
classdoc
- | Just d <- doc = docBox (docToHtml d)
+ | Just d <- doc = ndocBox (docToHtml d)
| otherwise = Html.emptyTable
- meth_hdr = tda [ theclass "section4" ] << toHtml "Methods"
-
- body
+ methods_bit
| null decls = Html.emptyTable
| otherwise =
- td << table ! [width "100%", cellpadding 0, cellspacing 8] << (
- meth_hdr </>
- aboves (map (doDecl False) kept_decls)
- )
+ meth_hdr </>
+ tda [theclass "body"] << spacedTable1 << (
+ aboves [ ppFunSig summary n ty doc
+ | HsTypeSig _ [n] ty doc <- decls
+ ]
+ )
+
+ instances_bit
+ = case instances of
+ Nothing -> Html.emptyTable
+ Just [] -> Html.emptyTable
+ Just is ->
+ inst_hdr </>
+ tda [theclass "body"] << spacedTable1 << (
+ aboves (map (declBox.ppInstHead) is)
+ )
+
+ instances = lookupFM cls_inst_map orig_c
kept_decls = filter keepDecl decls
-
decl_has_no_doc decl = isNothing (declDoc decl)
--- -----------------------------------------------------------------------------
+ppInstHead :: InstHead -> Html
+ppInstHead ([],asst) = ppHsAsst asst
+ppInstHead (ctxt,asst) = ppHsContext ctxt <+> toHtml "=>" <+> ppHsAsst asst
+
+-- ----------------------------------------------------------------------------
-- Type signatures
ppFunSig summary nm ty doc
@@ -664,7 +698,6 @@ ppFunSig summary nm ty doc
declWithDoc summary doc (ppTypeSig summary nm ty)
| otherwise =
- td << vanillaTable << (
declBox (ppHsBinder False nm) </>
(tda [theclass "body"] << vanillaTable << (
(if (isJust doc)
@@ -672,7 +705,6 @@ ppFunSig summary nm ty doc
else Html.emptyTable) </>
do_args True ty
))
- )
where
no_arg_docs (HsForAllType _ _ ty) = no_arg_docs ty
no_arg_docs (HsTyFun (HsTyDoc _ _) _) = False
@@ -682,18 +714,19 @@ ppFunSig summary nm ty doc
do_args :: Bool -> HsType -> HtmlTable
do_args first (HsForAllType maybe_tvs ctxt ty)
- = narrowDeclBox (leader first <+> ppHsForAll maybe_tvs ctxt) </>
+ = (declBox (leader first <+> ppHsForAll maybe_tvs ctxt)
+ <-> rdocBox noHtml) </>
do_args False ty
do_args first (HsTyFun (HsTyDoc ty doc) r)
- = (narrowDeclBox (leader first <+> ppHsBType ty) <->
+ = (declBox (leader first <+> ppHsBType ty) <->
rdocBox (docToHtml doc)) </>
do_args False r
do_args first (HsTyFun ty r)
- = (narrowDeclBox (leader first <+> ppHsBType ty) <->
+ = (declBox (leader first <+> ppHsBType ty) <->
rdocBox noHtml) </>
do_args False r
do_args first (HsTyDoc ty doc)
- = (narrowDeclBox (leader first <+> ppHsBType ty) <->
+ = (declBox (leader first <+> ppHsBType ty) <->
rdocBox (docToHtml doc))
do_args first ty = declBox (leader first <+> ppHsBType ty) <->
rdocBox (noHtml)
@@ -704,10 +737,12 @@ ppFunSig summary nm ty doc
-- -----------------------------------------------------------------------------
-- Types and contexts
-ppHsContext :: HsContext -> Html
-ppHsContext [] = empty
-ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
- hsep (map ppHsAType b)) context)
+ppHsAsst :: (HsQName,[HsType]) -> Html
+ppHsAsst (c,args) = ppHsQName c <+> hsep (map ppHsAType args)
+
+ppHsContext :: HsContext -> Html
+ppHsContext [] = empty
+ppHsContext context = parenList (map ppHsAsst context)
ppHsForAll Nothing context =
hsep [ ppHsContext context, toHtml "=>" ]
@@ -721,9 +756,9 @@ ppHsType :: HsType -> Html
ppHsType (HsForAllType maybe_tvs context htype) =
ppHsForAll maybe_tvs context <+> ppHsType htype
ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b]
-ppHsType (HsTyDoc ty doc) = ppHsBType ty
ppHsType t = ppHsBType t
+ppHsBType (HsTyDoc ty doc) = ppHsBType ty
ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b
@@ -837,6 +872,13 @@ punctuate p (d:ds) = go d ds
go d [] = [d]
go d (e:es) = (d +++ p) : go e es
+abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable
+abovesSep p [] = Html.emptyTable
+abovesSep p (d:ds) = go d ds
+ where
+ go d [] = d
+ go d (e:es) = d </> p </> go e es
+
parenList :: [Html] -> Html
parenList = parens . hsep . punctuate comma
@@ -883,3 +925,10 @@ narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0]
spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0]
spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0]
+constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
+meth_hdr = tda [ theclass "section4" ] << toHtml "Methods"
+inst_hdr = tda [ theclass "section4" ] << toHtml "Instances"
+
+s8, s15 :: HtmlTable
+s8 = tda [ theclass "s8" ] << noHtml
+s15 = tda [ theclass "s15" ] << noHtml
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index 02085e2e..d1bc5efa 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -105,6 +105,10 @@ renameDecl decl
ty <- renameType ty
doc <- renameMaybeDoc doc
return (HsForeignImport loc cc safe ent n ty doc)
+ HsInstDecl loc ctxt asst decls -> do
+ ctxt <- mapM renamePred ctxt
+ asst <- renamePred asst
+ return (HsInstDecl loc ctxt asst decls)
_ ->
return decl
@@ -217,9 +221,9 @@ renameExportItems items = mapM rn items
rn (ExportGroup lev id doc)
= do doc <- renameDoc doc
return (ExportGroup lev id doc)
- rn (ExportDecl decl)
+ rn (ExportDecl x decl) -- x is an original name, don't rename it
= do decl <- renameDecl decl
- return (ExportDecl decl)
+ return (ExportDecl x decl)
rn (ExportDoc doc)
= do doc <- renameDoc doc
return (ExportDoc doc)
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 9c957dd5..5554bddc 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -7,8 +7,9 @@
module HaddockTypes (
-- * Module interfaces
NameEnv, Interface(..), ExportItem(..), ModuleMap,
- DocOption(..),
+ -- * Misc types
+ DocOption(..), InstHead,
) where
import FiniteMap
@@ -39,6 +40,9 @@ data Interface
-- restricted to only those bits exported.
-- the map key is the "main name" of the decl.
+ iface_insts :: [HsDecl],
+ -- ^ instances from this module
+
iface_info :: Maybe ModuleInfo,
-- ^ information from the module header
@@ -52,10 +56,9 @@ data Interface
data DocOption = OptHide | OptPrune | OptIgnoreExports
deriving (Eq)
-type DocString = String
-
data ExportItem
= ExportDecl
+ HsQName -- the original name
HsDecl -- a declaration (with doc annotations)
| ExportGroup -- a section heading
@@ -71,3 +74,4 @@ data ExportItem
type ModuleMap = FiniteMap Module Interface
+type InstHead = (HsContext,HsAsst)
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 58033edc..27595f33 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,
+ restrictTo, declDoc, parseModuleHeader, freeTyCons,
-- * Filename utilities
basename, dirname, splitFilename3,
@@ -76,6 +76,16 @@ splitTyConApp t = split t []
split (HsTyCon t) ts = (t,ts)
split _ _ = error "splitTyConApp"
+freeTyCons :: HsType -> [HsQName]
+freeTyCons ty = go ty []
+ where go (HsForAllType _ _ t) r = go t r
+ go (HsTyApp t u) r = go t (go u r)
+ go (HsTyCon c) r = c : r
+ go (HsTyFun f a) r = go f (go a r)
+ go (HsTyTuple b ts) r = foldr go r ts
+ go (HsTyVar v) r = r
+ go (HsTyDoc t _) r = go t r
+
-- ---------------------------------------------------------------------------
-- Making abstract declarations
diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs
index 3d795837..148fff07 100644
--- a/src/HsParseUtils.lhs
+++ b/src/HsParseUtils.lhs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: HsParseUtils.lhs,v 1.2 2002/04/10 16:10:26 simonmar Exp $
+-- $Id: HsParseUtils.lhs,v 1.3 2002/05/27 09:03:52 simonmar Exp $
--
-- (c) The GHC Team 1997-2000
--
@@ -17,6 +17,7 @@ module HsParseUtils (
, checkPrec -- String -> P String
, checkContext -- HsType -> P HsContext
, checkAssertion -- HsType -> P HsAsst
+ , checkInstHeader -- HsType -> P (HsContext, HsAsst)
, checkDataHeader -- HsType -> P (HsContext,HsName,[HsName])
, checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
, checkPattern -- HsExp -> P HsPat
@@ -73,6 +74,14 @@ checkAssertion = checkAssertion' []
checkAssertion' _ _ = parseError "Illegal class assertion"
+checkInstHeader :: HsType -> P (HsContext, HsAsst)
+checkInstHeader (HsForAllType Nothing ctxt ty) =
+ checkAssertion ty `thenP` \asst ->
+ returnP (ctxt, asst)
+checkInstHeader ty =
+ checkAssertion ty `thenP` \asst ->
+ returnP ([], asst)
+
checkDataHeader :: HsType -> P (HsContext,HsName,[HsName])
checkDataHeader (HsForAllType Nothing cs t) =
checkSimple t [] `thenP` \(c,ts) ->
diff --git a/src/HsParser.ly b/src/HsParser.ly
index 9b47f117..4c12adc7 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
-$Id: HsParser.ly,v 1.11 2002/05/15 13:03:02 simonmar Exp $
+$Id: HsParser.ly,v 1.12 2002/05/27 09:03:52 simonmar Exp $
(c) Simon Marlow, Sven Panne 1997-2002
@@ -306,7 +306,8 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
> | 'class' srcloc ctype fds optcbody
> { HsClassDecl $2 $3 $4 $5 Nothing}
> | 'instance' srcloc ctype optvaldefs
-> { HsInstDecl $2 $3 $4 }
+> {% checkInstHeader $3 `thenP` \(ctxt,asst) ->
+> returnP (HsInstDecl $2 ctxt asst $4) }
> | 'default' srcloc '(' typelist ')'
> { HsDefaultDecl $2 $4 }
> | 'foreign' fdecl { $2 }
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
index ecd2b0ce..8f3ef31d 100644
--- a/src/HsSyn.lhs
+++ b/src/HsSyn.lhs
@@ -1,5 +1,5 @@
% -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.9 2002/05/15 13:03:02 simonmar Exp $
+% $Id: HsSyn.lhs,v 1.10 2002/05/27 09:03:52 simonmar Exp $
%
% (c) The GHC Team, 1997-2002
%
@@ -144,7 +144,7 @@ data HsDecl
| HsClassDecl SrcLoc HsType [HsFunDep] [HsDecl] (Maybe Doc)
- | HsInstDecl SrcLoc HsType [HsDecl]
+ | HsInstDecl SrcLoc HsContext HsAsst [HsDecl]
| HsDefaultDecl SrcLoc [HsType]
diff --git a/src/Main.hs b/src/Main.hs
index 96425a46..288d1632 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -107,28 +107,29 @@ run flags files = do
writeIORef saved_flags flags
parsed_mods <- sequence (map parse_file files)
- sorted_mods <- sortModules parsed_mods
+ sorted_mod_files <- sortModules (zip parsed_mods files)
-- emits an error message if there are recursive modules
-- process the modules in sorted order, building up a mapping from
-- modules to interfaces.
let
- loop ifaces [] _ = return ifaces
- loop ifaces (hsmod:hsmods) (file:files) = do
+ loop ifaces [] = return ifaces
+ loop ifaces ((hsmod,file):mods) = do
let ((mod,iface),msgs) = runWriter (mkInterface ifaces file hsmod)
new_ifaces = addToFM ifaces mod iface
mapM (hPutStrLn stderr) msgs
- loop new_ifaces hsmods files
+ loop new_ifaces mods
- module_map <- loop emptyFM sorted_mods files
+ module_map <- loop emptyFM sorted_mod_files
let mod_ifaces = fmToList module_map
-- when (Flag_DocBook `elem` flags) $
-- putStr (ppDocBook odir mod_ifaces)
- when (Flag_Html `elem` flags) $
- ppHtml title source_url mod_ifaces odir css_file libdir
+ let inst_maps = collectInstances mod_ifaces
+ when (Flag_Html `elem` flags) $
+ ppHtml title source_url mod_ifaces odir css_file libdir inst_maps
parse_file file = do
bracket
@@ -201,9 +202,11 @@ mkInterface mod_map filename
decl_map :: FiniteMap HsName HsDecl
decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ]
+ instances = [ d | d@HsInstDecl{} <- final_decls ]
+
-- make the "export items", which will be converted into docs later
- orig_export_list <- mkExportItems mod_map mod orig_env
- decl_map final_decls options orig_exports
+ orig_export_list <- mkExportItems mod_map mod decl_map
+ final_decls options orig_exports
let
-- prune the export list to just those declarations that have
@@ -236,6 +239,7 @@ mkInterface mod_map filename
iface_env = name_env,
iface_exports = renamed_export_list,
iface_orig_exports = pruned_export_list,
+ iface_insts = instances,
iface_decls = decl_map,
iface_info = maybe_info,
iface_doc = maybe_doc,
@@ -245,17 +249,19 @@ mkInterface mod_map filename
-- -----------------------------------------------------------------------------
-- Build the list of items that will become the documentation, from the
--- export list. At the same time we rename *original* names in the declarations
--- to *imported* names.
+-- export list. At this point, the list of ExportItems is in terms of
+-- original names.
-mkExportItems :: ModuleMap -> Module
- -> FiniteMap HsQName HsQName -- maps orig to imported names
+mkExportItems
+ :: ModuleMap
+ -> Module -- this module
-> FiniteMap HsName HsDecl -- maps local names to declarations
-> [HsDecl] -- decls in the current module
-> [DocOption]
-> Maybe [HsExportSpec]
-> ErrMsgM [ExportItem]
-mkExportItems mod_map mod env decl_map decls options maybe_exps
+
+mkExportItems mod_map mod decl_map decls options maybe_exps
| Nothing <- maybe_exps = everything_local_exported
| OptIgnoreExports `elem` options = everything_local_exported
| Just specs <- maybe_exps = do
@@ -264,26 +270,21 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
where
everything_local_exported =
- fullContentsOfThisModule mod decls env -- everything exported
+ return (fullContentsOfThisModule mod decl_map) -- everything exported
lookupExport (HsEVar x)
| Just decl <- findDecl x
- = let decl' | HsTypeSig loc ns ty doc <- decl
- = HsTypeSig loc [nameOfQName x] ty doc
- | otherwise
- = decl
- in
- return [ ExportDecl decl' ]
+ = return [ ExportDecl x decl ]
-- ToDo: cope with record selectors here
lookupExport (HsEAbs t)
| Just decl <- findDecl t
- = return [ ExportDecl (restrictTo [] decl) ]
+ = return [ ExportDecl t (restrictTo [] decl) ]
lookupExport (HsEThingAll t)
| Just decl <- findDecl t
- = return [ ExportDecl decl ]
+ = return [ ExportDecl t decl ]
lookupExport (HsEThingWith t cs)
| Just decl <- findDecl t
- = return [ ExportDecl (restrictTo (map nameOfQName cs) decl) ]
+ = return [ ExportDecl t (restrictTo (map nameOfQName cs) decl) ]
lookupExport (HsEModuleContents m) = fullContentsOf m
lookupExport (HsEGroup lev doc)
= return [ ExportGroup lev "" doc ]
@@ -298,7 +299,7 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
lookupExport _ = return [] -- didn't find it?
fullContentsOf m
- | m == mod = fullContentsOfThisModule mod decls env
+ | m == mod = return (fullContentsOfThisModule mod decl_map)
| otherwise =
case lookupFM mod_map m of
Just iface
@@ -318,12 +319,10 @@ mkExportItems mod_map mod env decl_map decls options maybe_exps
Just iface -> lookupFM (iface_decls iface) n
Nothing -> Nothing
-fullContentsOfThisModule mod decls env =
- mapM mkExportItem (filter keepDecl decls)
- where mkExportItem (HsDocGroup loc lev doc) =
- return (ExportGroup lev "" doc)
- mkExportItem decl =
- return (ExportDecl decl)
+fullContentsOfThisModule mod decl_map =
+ map mkExportItem (filter (keepDecl.snd) (fmToList decl_map))
+ where mkExportItem (x,HsDocGroup loc lev doc) = ExportGroup lev "" doc
+ mkExportItem (x,decl) = ExportDecl (Qual mod x) decl
keepDecl HsTypeSig{} = True
keepDecl HsTypeDecl{} = True
@@ -338,7 +337,7 @@ keepDecl _ = False
pruneExportItems :: [ExportItem] -> [ExportItem]
pruneExportItems items = filter has_doc items
- where has_doc (ExportDecl d) = isJust (declDoc d)
+ where has_doc (ExportDecl x d) = isJust (declDoc d)
has_doc _ = True
-- -----------------------------------------------------------------------------
@@ -510,22 +509,48 @@ parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing
-- -----------------------------------------------------------------------------
-- Topologically sort the modules
-sortModules :: [HsModule] -> IO [HsModule]
-sortModules hsmodules = mapM for_each_scc sccs
+sortModules :: [(HsModule,FilePath)] -> IO [(HsModule,FilePath)]
+sortModules mods = mapM for_each_scc sccs
where
sccs = stronglyConnComp edges
- edges :: [(HsModule, Module, [Module])]
- edges = [ (hsmod, mod, [ imp | HsImportDecl _ imp _ _ _ <- impdecls ])
- | hsmod@(HsModule mod _ impdecls _ _ _ _) <- hsmodules
+ edges :: [((HsModule,FilePath), Module, [Module])]
+ edges = [ ((hsmod,file), mod, get_imps impdecls)
+ | (hsmod@(HsModule mod _ impdecls _ _ _ _), file) <- mods
]
+ get_imps impdecls = [ imp | HsImportDecl _ imp _ _ _ <- impdecls ]
+
+ get_mods hsmodules = [ mod | HsModule mod _ _ _ _ _ _ <- hsmodules ]
+
for_each_scc (AcyclicSCC hsmodule) = return hsmodule
for_each_scc (CyclicSCC hsmodules) =
- dieMsg ("modules are recursive: " ++
- unwords (map show [ mod | HsModule mod _ _ _ _ _ _
- <- hsmodules ]))
+ dieMsg ("modules are recursive: " ++
+ unwords (map show (get_mods (map fst hsmodules))))
+
+-- -----------------------------------------------------------------------------
+-- Collect instances
+collectInstances
+ :: [(Module,Interface)]
+ -> (FiniteMap HsQName [InstHead], -- maps class names to instances
+ FiniteMap HsQName [InstHead]) -- maps type names to instances
+
+collectInstances mod_ifaces
+ = (addListToFM_C (++) emptyFM class_inst_pairs,
+ addListToFM_C (++) emptyFM ty_inst_pairs)
+ where
+ all_instances = concat (map (iface_insts.snd) mod_ifaces)
+
+ class_inst_pairs = [ (cls, [(ctxt,(cls,args))])
+ | HsInstDecl _ ctxt (cls,args) _ <- all_instances ]
+
+ ty_inst_pairs = [ (nm, [(ctxt,(cls,args))])
+ | HsInstDecl _ ctxt (cls,args) _ <- all_instances,
+ arg <- args,
+ nm <- freeTyCons arg
+ ]
+
-- -----------------------------------------------------------------------------
-- A monad which collects error messages