diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/HaddockHtml.hs | 257 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 8 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 10 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 12 | ||||
| -rw-r--r-- | src/HsParseUtils.lhs | 11 | ||||
| -rw-r--r-- | src/HsParser.ly | 5 | ||||
| -rw-r--r-- | src/HsSyn.lhs | 4 | ||||
| -rw-r--r-- | src/Main.hs | 105 |
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 |