(this causes -- ugly extra whitespace with some browsers). @@ -1806,8 +1818,16 @@ s8 = tda [ theclass "s8" ] << noHtml s15 = tda [ theclass "s15" ] << noHtml + +-- | Generate a named anchor +-- +-- This actually generates two anchor tags, one with the name unescaped, and one +-- with the name URI-escaped. This is needed because Opera 9.52 (and later +-- versions) needs the name to be unescaped, while IE 7 needs it to be escaped. +-- namedAnchor :: String -> Html -> Html -namedAnchor n = anchor ! [name (escapeStr n)] +namedAnchor n = (anchor ! [name n]) . (anchor ! [name (escapeStr n)]) + -- -- A section of HTML which is collapsible via a +/- button. diff --git a/src/Haddock/DocName.hs b/src/Haddock/DocName.hs --- a/src/Haddock/DocName.hs +++ b/src/Haddock/DocName.hs @@ -19,10 +19,19 @@ deriving Eq +-- TODO: remove docNameOrig in favour of the NamedThing instance + +instance NamedThing DocName where + getName (Documented name _) = name + getName (Undocumented name) = name + + +-- | The 'OccName' belonging to this name docNameOcc :: DocName -> OccName docNameOcc = nameOccName . docNameOrig +-- | The original definition site of this name docNameOrig :: DocName -> Name docNameOrig (Documented name _) = name docNameOrig (Undocumented name) = name diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs --- a/src/Haddock/GHC.hs +++ b/src/Haddock/GHC.hs @@ -47,17 +47,18 @@ #endif let dynflags' = dopt_set dynflags Opt_Haddock let dynflags'' = dynflags' { - hscTarget = HscAsm, + hscTarget = HscNothing, ghcMode = CompManager, ghcLink = NoLink } dynflags''' <- parseGhcFlags dynflags'' restFlags flags -#if __GLASGOW_HASKELL__ >= 609 - setSessionDynFlags dynflags''' - ghcActs dynflags''' + defaultCleanupHandler dynflags''' $ do +#if __GLASGOW_HASKELL__ >= 609 + setSessionDynFlags dynflags''' + ghcActs dynflags''' #else - setSessionDynFlags session dynflags''' - return (session, dynflags''') + setSessionDynFlags session dynflags''' + return (session, dynflags''') #endif diff --git a/src/Haddock/GHC/Typecheck.hs b/src/Haddock/GHC/Typecheck.hs --- a/src/Haddock/GHC/Typecheck.hs +++ b/src/Haddock/GHC/Typecheck.hs @@ -10,16 +10,10 @@ ) where -import Haddock.Exception import Haddock.Types -import Haddock.GHC.Utils import Data.Maybe -import Control.Monad import GHC -import HscTypes ( msHsFilePath ) -import Digraph -import BasicTypes import SrcLoc import Data.List @@ -36,13 +30,13 @@ -- | Dig out what we want from the typechecker output mkGhcModule :: CheckedMod -> DynFlags -> GhcModule -mkGhcModule (mod, file, checkedMod) dynflags = GhcModule { - ghcModule = mod, +mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule { + ghcModule = mdl, ghcFilename = file, ghcMbDocOpts = mbOpts, ghcHaddockModInfo = info, ghcMbDoc = mbDoc, - ghcGroup = group, + ghcGroup = group_, ghcMbExports = mbExports, ghcExportedNames = modInfoExports modInfo, ghcDefinedNames = map getName $ modInfoTyThings modInfo, @@ -55,5 +49,5 @@ #else mbOpts = haddockOptions dynflags #endif - (group, _, mbExports, mbDoc, info) = renamed + (group_, _, mbExports, mbDoc, info) = renamed (parsed, renamed, _, modInfo) = checkedMod diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs --- a/src/Haddock/GHC/Utils.hs +++ b/src/Haddock/GHC/Utils.hs @@ -5,6 +5,7 @@ -- +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} @@ -15,6 +16,7 @@ import Data.Char import Data.Version import qualified Data.Map as Map +import Control.Arrow import HsSyn import SrcLoc @@ -113,3 +115,66 @@ trace_ppr :: Outputable a => a -> b -> b trace_ppr x y = trace (pretty x) y + + +------------------------------------------------------------------------------- +-- NamedThing instances +------------------------------------------------------------------------------- + + +instance NamedThing (TyClDecl Name) where + getName = tcdName + + +instance NamedThing (ConDecl Name) where + getName = unL . con_name + + +------------------------------------------------------------------------------- +-- Subordinates +------------------------------------------------------------------------------- + + +class Parent a where + children :: a -> [Name] + + +instance Parent (ConDecl Name) where + children con = + case con_details con of + RecCon fields -> map (unL . cd_fld_name) fields + _ -> [] + + +instance Parent (TyClDecl Name) where + children d + | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d + | isClassDecl d = + map (tcdName . unL) (tcdATs d) ++ + [ unL n | L _ (TypeSig n _) <- tcdSigs d ] + | otherwise = [] + + +-- | A parent and its children +family :: (NamedThing a, Parent a) => a -> (Name, [Name]) +family = getName &&& children + + +-- | A mapping from the parent (main-binder) to its children and from each +-- child to its grand-children, recursively. +families :: TyClDecl Name -> [(Name, [Name])] +families d + | isDataDecl d = family d : map (family . unL) (tcdCons d) + | isClassDecl d = family d : concatMap (families . unL) (tcdATs d) + | otherwise = [] + + +-- | A mapping from child to parent +parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] + + +-- | The parents of a subordinate in a declaration +parents :: Name -> HsDecl Name -> [Name] +parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents _ _ = [] diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -24,6 +24,7 @@ import Haddock.GHC.Typecheck import Haddock.Exception import Haddock.Utils +import Haddock.InterfaceFile import qualified Data.Map as Map import Data.Map (Map) @@ -37,24 +38,34 @@ import Digraph import BasicTypes import SrcLoc +import HscTypes -- | Turn a topologically sorted list of module names/filenames into interfaces. Also -- return the home link environment created in the process. #if __GLASGOW_HASKELL__ >= 609 -createInterfaces :: [String] -> LinkEnv -> [Flag] -> Ghc ([Interface], LinkEnv) -createInterfaces modules externalLinks flags = do +createInterfaces :: [String] -> [Flag] -> [InterfaceFile] + -> Ghc ([Interface], LinkEnv) +createInterfaces modules flags extIfaces = do -- part 1, create interfaces - interfaces <- createInterfaces' modules flags + let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces + , iface <- ifInstalledIfaces ext ] + interfaces <- createInterfaces' modules flags instIfaceMap #else -createInterfaces :: Session -> [String] -> LinkEnv -> [Flag] -> IO ([Interface], LinkEnv) -createInterfaces session modules externalLinks flags = do +createInterfaces :: Session -> [String] -> [Flag] + -> [InterfaceFile] -> IO ([Interface], LinkEnv) +createInterfaces session modules flags extIfaces = do -- part 1, create interfaces - interfaces <- createInterfaces' session modules flags + let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces + , iface <- ifInstalledIfaces ext ] + interfaces <- createInterfaces' session modules flags instIfaceMap #endif -- part 2, build link environment - let homeLinks = buildHomeLinks interfaces - links = homeLinks `Map.union` externalLinks + -- combine the link envs of the external packages into one + let extLinks = Map.unions (map ifLinkEnv extIfaces) + homeLinks = buildHomeLinks interfaces -- build the environment for the home + -- package + links = homeLinks `Map.union` extLinks allNames = Map.keys links -- part 3, attach instances @@ -70,28 +81,51 @@ #if __GLASGOW_HASKELL__ >= 609 -createInterfaces' :: [String] -> [Flag] -> Ghc [Interface] -createInterfaces' modules flags = do +createInterfaces' :: [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] +createInterfaces' modules flags instIfaceMap = do targets <- mapM (\f -> guessTarget f Nothing) modules setTargets targets modgraph <- depanal [] False - let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing + +#if (__GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ >= 2) || __GLASGOW_HASKELL__ >= 611 + -- If template haskell is used by the package, we can not use + -- HscNothing as target since we might need to run code generated from + -- one or more of the modules during typechecking. +#if __GLASGOW_HASKELL__ < 611 + let needsTemplateHaskell = any (dopt Opt_TemplateHaskell . ms_hspp_opts) +#endif + modgraph' <- if needsTemplateHaskell modgraph + then do + dflags <- getSessionDynFlags + setSessionDynFlags dflags { hscTarget = HscC } + -- we need to set HscC on all the ModSummaries as well + let addHscC m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscC } } + return (map addHscC modgraph) + else return modgraph +#else + let modgraph' = modgraph +#endif + + let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do - interface <- processModule modsum flags modMap + x <- processModule modsum flags modMap instIfaceMap #else -createInterfaces' :: Session -> [String] -> [Flag] -> IO [Interface] -createInterfaces' session modules flags = do +createInterfaces' :: Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface] +createInterfaces' session modules flags instIfaceMap = do targets <- mapM (\f -> guessTarget f Nothing) modules setTargets session targets mbGraph <- depanal session [] False modgraph <- case mbGraph of Just graph -> return graph - Nothing -> throwE "Failed to create dependecy graph" + Nothing -> throwE "Failed to create dependency graph" let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do - interface <- processModule session modsum flags modMap + x <- processModule session modsum flags modMap instIfaceMap #endif - return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap) + case x of + Just interface -> + return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap) + Nothing -> return (ifaces, modMap) ) ([], Map.empty) orderedMods return (reverse ifaces) @@ -128,41 +162,43 @@ -} #if __GLASGOW_HASKELL__ >= 609 -processModule :: ModSummary -> [Flag] -> ModuleMap -> Ghc Interface -processModule modsum flags modMap = - - let handleSrcErrors action = flip handleSourceError action $ \err -> do - printExceptionAndWarnings err - throwE ("Failed to check module: " ++ moduleString (ms_mod modsum)) - - in handleSrcErrors $ do - let filename = msHsFilePath modsum - let dynflags = ms_hspp_opts modsum - tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum - let Just renamed_src = renamedSource tc_mod - let ghcMod = mkGhcModule (ms_mod modsum, - filename, - (parsedSource tc_mod, - renamed_src, - typecheckedSource tc_mod, - moduleInfo tc_mod)) - dynflags - let (interface, msg) = runWriter $ createInterface ghcMod flags modMap - liftIO $ mapM_ putStrLn msg - liftIO $ evaluate interface - return interface +processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface) +processModule modsum flags modMap instIfaceMap = do + tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum + if not $ isBootSummary modsum + then do + let filename = msHsFilePath modsum + let dynflags = ms_hspp_opts modsum + let Just renamed_src = renamedSource tc_mod + let ghcMod = mkGhcModule (ms_mod modsum, + filename, + (parsedSource tc_mod, + renamed_src, + typecheckedSource tc_mod, + moduleInfo tc_mod)) + dynflags + let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap + liftIO $ mapM_ putStrLn msg + liftIO $ evaluate interface + return (Just interface) + else + return Nothing #else -processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> IO Interface -processModule session modsum flags modMap = do +processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface) +processModule session modsum flags modMap instIfaceMap = do let filename = msHsFilePath modsum mbMod <- checkAndLoadModule session modsum False - ghcMod <- case mbMod of - Just (CheckedModule a (Just b) (Just c) (Just d) _) - -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum) - _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum)) - let (interface, msg) = runWriter $ createInterface ghcMod flags modMap - mapM_ putStrLn msg - return interface + if not $ isBootSummary modsum + then do + ghcMod <- case mbMod of + Just (CheckedModule a (Just b) (Just c) (Just d) _) + -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum) + _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum)) + let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap + mapM_ putStrLn msg + return (Just interface) + else + return Nothing #endif -- | Build a mapping which for each original name, points to the "best" diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -23,7 +23,13 @@ import SrcLoc import InstEnv import Class + +#if __GLASGOW_HASKELL__ >= 610 && __GHC_PATCHLEVEL__ >= 2 +import TypeRep hiding (funTyConName) +#else import TypeRep +#endif + import Var hiding (varName) import TyCon import PrelNames diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -40,8 +40,9 @@ -- | Process the data in the GhcModule to produce an interface. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the module map. -createInterface :: GhcModule -> [Flag] -> ModuleMap -> ErrMsgM Interface -createInterface ghcMod flags modMap = do +createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap + -> ErrMsgM Interface +createInterface ghcMod flags modMap instIfaceMap = do let mod = ghcModule ghcMod @@ -62,13 +63,11 @@ warnAboutFilteredDecls mod decls0 - visibleNames <- mkVisibleNames mod modMap localNames - (ghcNamesInScope ghcMod) - exports opts declMap - exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap - opts exports ignoreExps instances + opts exports ignoreExps instances instIfaceMap + let visibleNames = mkVisibleNames exportItems opts + -- prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. let @@ -90,6 +89,7 @@ ifaceExports = exportedNames, ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, + ifaceSubMap = mkSubMap declMap exportedNames, ifaceInstances = ghcInstances ghcMod } @@ -125,7 +125,15 @@ -- Declarations -------------------------------------------------------------------------------- +-- | Make a sub map from a declaration map. Make sure we only include exported +-- names. +mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name] +mkSubMap declMap exports = + Map.filterWithKey (\k _ -> k `elem` exports) (Map.map filterSubs declMap) + where + filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ] + -- Make a map from names to 'DeclInfo's. Exclude declarations that don't -- have names (instances and stand-alone documentation comments). Include -- subordinate names, but map them to their parent declarations. @@ -190,18 +198,19 @@ filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d)) --- | Take all declarations in an 'HsGroup' and convert them into a list of --- 'Decl's +-- | Take all declarations except pragmas, infix decls, rules and value +-- bindings from an 'HsGroup'. declsFromGroup :: HsGroup Name -> [Decl] --- TODO: actually take all declarations declsFromGroup group = - decls hs_tyclds TyClD group ++ - decls hs_fords ForD group ++ - decls hs_docs DocD group ++ - decls hs_instds InstD group ++ - decls (sigs . hs_valds) SigD group + decls hs_tyclds TyClD group ++ + decls hs_derivds DerivD group ++ + decls hs_defds DefD group ++ + decls hs_fords ForD group ++ + decls hs_docs DocD group ++ + decls hs_instds InstD group ++ + decls (typesigs . hs_valds) SigD group where - sigs (ValBindsOut _ x) = x + typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs -- | Take a field of declarations from a data structure and create HsDecls @@ -231,9 +240,8 @@ when (not $ null instances) $ tell $ nub $ [ - "Warning: " ++ modStr ++ ": Rendering of associated types for instances has " - ++ "not yet been implemented. Associated types will not be shown for the " - ++ "following instances:\n" ++ (concat $ intersperse ", " instances) ] + "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " + ++ "These instances are affected:\n" ++ (concat $ intersperse ", " instances) ] -------------------------------------------------------------------------------- @@ -274,11 +282,10 @@ -------------------------------------------------------------------------------- --- | Collect the docs and attach them to the right declaration +-- | Collect the docs and attach them to the right declaration. collectDocs :: [Decl] -> [(Decl, (Maybe Doc))] collectDocs decls = collect Nothing DocEmpty decls - collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))] collect d doc_so_far [] = case d of @@ -296,9 +303,7 @@ _ -> case d of Nothing -> collect (Just e) doc_so_far es - Just d0 - | sameDecl d0 e -> collect d doc_so_far es - | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es) + Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es) finishedDoc :: Decl -> Doc -> [(Decl, (Maybe Doc))] -> [(Decl, (Maybe Doc))] @@ -310,9 +315,6 @@ finishedDoc _ _ rest = rest -sameDecl d1 d2 = getLoc d1 == getLoc d2 - - {- attachATs :: [IE Name] -> ([IE Name], [Name]) attachATs exports = @@ -324,6 +326,9 @@ -- | Build the list of items that will become the documentation, from the -- export list. At this point, the list of ExportItems is in terms of -- original names. +-- +-- We create the export items even if the module is hidden, since they +-- might be useful when creating the export items for other modules. mkExportItems :: ModuleMap -> Module -- this module @@ -334,10 +339,11 @@ -> Maybe [IE Name] -> Bool -- --ignore-all-exports flag -> [Instance] + -> InstIfaceMap -> ErrMsgM [ExportItem Name] mkExportItems modMap this_mod exported_names decls declMap - opts maybe_exps ignore_all_exports instances + opts maybe_exps ignore_all_exports instances instIfaceMap | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs @@ -347,7 +353,6 @@ everything_local_exported = -- everything exported return (fullContentsOfThisModule this_mod decls) - packageId = modulePackageId this_mod lookupExport (IEVar x) = declWith x lookupExport (IEThingAbs t) = declWith t @@ -359,7 +364,7 @@ lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t cs) = declWith t - lookupExport (IEModuleContents m) = fullContentsOf (mkModule packageId m) + lookupExport (IEModuleContents m) = fullContentsOf m lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ] lookupExport (IEDoc doc) = return [ ExportDoc doc ] lookupExport (IEDocNamed str) = do @@ -369,25 +374,57 @@ Just found -> return [ ExportDoc found ] declWith :: Name -> ErrMsgM [ ExportItem Name ] - declWith t - -- temp hack: we filter out separately declared ATs, since we haven't decided how - -- to handle them yet. We should really give an warning message also, and filter the - -- name out in mkVisibleNames... - | Just x@(decl,_,_) <- findDecl t, - t `notElem` declATs (unL decl) = return [ mkExportDecl t x ] - | otherwise = return [] + declWith t = + case findDecl t of + Just x@(decl,_,_) -> + let declName = + case getMainDeclBinder (unL decl) of + Just declName -> declName + Nothing -> error "declWith: should not happen" + in case () of + _ + -- temp hack: we filter out separately exported ATs, since we haven't decided how + -- to handle them yet. We should really give an warning message also, and filter the + -- name out in mkVisibleNames... + | t `elem` declATs (unL decl) -> return [] + -- We should not show a subordinate by itself if any of its + -- parents is also exported. See note [1]. + | t /= declName, + Just p <- find isExported (parents t $ unL decl) -> + do tell [ + "Warning: " ++ moduleString this_mod ++ ": " ++ + pretty (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty (nameOccName p) ++ + ". Consider exporting it together with its parent(s)" ++ + " for code clarity." ] + return [] + -- normal case + | otherwise -> return [ mkExportDecl t x ] + Nothing -> + -- If we can't find the declaration, it must belong to another package. + -- We return just the name of the declaration and try to get the subs + -- from the installed interface of that package. + case Map.lookup (nameModule t) instIfaceMap of + Nothing -> return [ ExportNoDecl t [] ] + Just iface -> + let subs = case Map.lookup t (instSubMap iface) of + Nothing -> [] + Just x -> x + in return [ ExportNoDecl t subs ] + mkExportDecl :: Name -> DeclInfo -> ExportItem Name mkExportDecl n (decl, doc, subs) = decl' where - decl' = ExportDecl (restrictTo subs' (extractDecl n mdl decl)) doc subdocs [] + decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' [] mdl = nameModule n - subs' = filter (`elem` exported_names) $ map fst subs - subdocs = [ (n, doc) | (n, Just doc) <- subs ] + subs' = filter ((`elem` exported_names) . fst) subs + sub_names = map fst subs' + isExported n = n `elem` exported_names - fullContentsOf m + fullContentsOf modname | m == this_mod = return (fullContentsOfThisModule this_mod decls) | otherwise = case Map.lookup m modMap of @@ -395,8 +432,20 @@ | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) | otherwise -> return [ ExportModule m ] - Nothing -> return [] -- already emitted a warning in visibleNames + + Nothing -> -- we have to try to find it in the installed interfaces + -- (external packages) + case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of + Just iface -> return [ ExportModule (instMod iface) ] + Nothing -> do + tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty modname] + return [] + where + m = mkModule packageId modname + packageId = modulePackageId this_mod + findDecl :: Name -> Maybe DeclInfo findDecl n | m == this_mod = Map.lookup n declMap @@ -407,13 +456,29 @@ m = nameModule n +-- Note [1]: +------------ +-- It is unnecessary to document a subordinate by itself at the top level if +-- any of its parents is also documented. Furthermore, if the subordinate is a +-- record field or a class method, documenting it under its parent +-- indicates its special status. +-- +-- A user might expect that it should show up separately, so we issue a +-- warning. It's a fine opportunity to also tell the user she might want to +-- export the subordinate through the parent export item for clarity. +-- +-- The code removes top-level subordinates also when the parent is exported +-- through a 'module' export. I think that is fine. +-- +-- (For more information, see Trac #69) + + fullContentsOfThisModule :: Module -> [DeclInfo] -> [ExportItem Name] fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls) where mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _) = Just $ ExportDoc doc - mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subdocs [] - where subdocs = [ (n, doc) | (n, Just doc) <- subs ] + mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subs [] -- mkExportItem _ = Nothing -- TODO: see if this is really needed @@ -486,53 +551,21 @@ hasDoc _ = True --- | Gather a list of original names exported from this module -mkVisibleNames :: Module - -> ModuleMap - -> [Name] - -> [Name] - -> Maybe [IE Name] - -> [DocOption] - -> Map Name DeclInfo - -> ErrMsgM [Name] - -mkVisibleNames mdl modMap localNames scope maybeExps opts declMap - -- if no export list, just return all local names - | Nothing <- maybeExps = return (filter hasDecl localNames) - | OptIgnoreExports `elem` opts = return localNames - | Just expspecs <- maybeExps = do - visibleNames <- mapM extract expspecs - return $ filter isNotPackageName (concat visibleNames) - where - hasDecl name = isJust (Map.lookup name declMap) - isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap) - where nameMod = nameModule name - - extract e = - case e of - IEVar x -> return [x] - IEThingAbs t -> return [t] - IEThingAll t -> return (t : all_subs) - where - all_subs | nameModule t == mdl = subsOfName t declMap - | otherwise = allSubsOfName modMap t - - IEThingWith t cs -> return (t : cs) - - IEModuleContents m - | mkModule (modulePackageId mdl) m == mdl -> return localNames - | otherwise -> let m' = mkModule (modulePackageId mdl) m in - case Map.lookup m' modMap of - Just mod - | OptHide `elem` ifaceOptions mod -> - return (filter (`elem` scope) (ifaceExports mod)) - | otherwise -> return [] - Nothing - -> tell (exportModuleMissingErr mdl m') >> return [] - - _ -> return [] - +mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name] +mkVisibleNames exports opts + | OptHide `elem` opts = [] + | otherwise = concatMap exportName exports + where + exportName e@ExportDecl {} = + case getMainDeclBinder $ unL $ expItemDecl e of + Just n -> n : subs + Nothing -> subs + where subs = map fst (expItemSubDocs e) + exportName e@ExportNoDecl {} = [] -- we don't count these as visible, since + -- we don't want links to go to them. + exportName _ = [] + exportModuleMissingErr this mdl = ["Warning: in export list of " ++ show (moduleString this) ++ ": module not found: " ++ show (moduleString mdl)] diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -68,7 +68,7 @@ -- report things that we couldn't link to. Only do this for non-hidden -- modules. unless (OptHide `elem` ifaceOptions mod || null strings || not warnings) $ - tell ["Warning: " ++ show (ppr (ifaceMod mod) defaultUserStyle) ++ + tell ["Warning: " ++ moduleString (ifaceMod mod) ++ ": could not find link destinations for:\n"++ " " ++ concat (map (' ':) strings) ] @@ -405,10 +405,10 @@ subs' <- mapM renameSub subs instances' <- mapM renameInstHead instances return (ExportDecl decl' doc' subs' instances') - ExportNoDecl x y subs -> do - y' <- lookupRn id y + ExportNoDecl x subs -> do + x' <- lookupRn id x subs' <- mapM (lookupRn id) subs - return (ExportNoDecl x y' subs') + return (ExportNoDecl x' subs') ExportDoc doc -> do doc' <- renameDoc doc return (ExportDoc doc') @@ -416,5 +416,5 @@ renameSub (n,doc) = do n' <- rename n - doc' <- renameDoc doc + doc' <- mapM renameDoc doc return (n', doc') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -37,9 +37,10 @@ import HscTypes import FastMutInt import HsDoc +#if __GLASGOW_HASKELL__ >= 609 import FastString import Unique - +#endif data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, @@ -55,18 +56,24 @@ -- and because we store GHC datatypes in our interface files, -- we need to make sure we version our interface files accordingly. -- --- Instead of adding one, we add three to all version numbers +-- Instead of adding one, we add five to all version numbers -- when one of our own (stored) datatypes is changed. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2 -binaryInterfaceVersion = 2 +binaryInterfaceVersion = 9 #endif #if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 3 -binaryInterfaceVersion = 3 +binaryInterfaceVersion = 10 #endif -#if __GLASGOW_HASKELL__ >= 609 -binaryInterfaceVersion = 4 +#if __GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ == 1 +binaryInterfaceVersion = 11 #endif +#if __GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ == 2 +binaryInterfaceVersion = 12 +#endif +#if __GLASGOW_HASKELL__ == 611 +binaryInterfaceVersion = 13 +#endif initBinMemSize :: Int @@ -110,7 +117,7 @@ bh <- return $ setUserData bh0 ud put_ bh iface - -- write the symtab pointer at the fornt of the file + -- write the symtab pointer at the front of the file symtab_p <- tellBin bh putAt bh symtab_p_p symtab_p seekBin bh symtab_p @@ -352,12 +359,14 @@ instance Binary InstalledInterface where - put_ bh (InstalledInterface modu info docMap exps visExps) = do + put_ bh (InstalledInterface modu info docMap exps visExps opts subMap) = do put_ bh modu put_ bh info put_ bh (Map.toList docMap) put_ bh exps put_ bh visExps + put_ bh opts + put_ bh (Map.toList subMap) get bh = do modu <- get bh @@ -365,7 +374,11 @@ docMap <- get bh exps <- get bh visExps <- get bh - return (InstalledInterface modu info (Map.fromList docMap) exps visExps) + opts <- get bh + subMap <- get bh + + return (InstalledInterface modu info (Map.fromList docMap) + exps visExps opts (Map.fromList subMap)) instance Binary DocOption where diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -6,7 +6,6 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where -import Haddock.DocName import GHC ( HsDoc, Name ) import Module ( Module, moduleNameString, moduleName, modulePackageId ) #if __GLASGOW_HASKELL__ >= 609 @@ -19,14 +18,14 @@ mkModuleTree :: Bool -> [(Module, Maybe (HsDoc Name))] -> [ModuleTree] mkModuleTree showPkgs mods = - foldr fn [] [ (splitModule mod, modPkg mod, short) | (mod, short) <- mods ] + foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod | showPkgs = Just (packageIdString (modulePackageId mod)) - | otherwise = Nothing - fn (mod,pkg,short) trees = addToTrees mod pkg short trees + modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_)) + | otherwise = Nothing + fn (mod_,pkg,short) trees = addToTrees mod_ pkg short trees addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] pkg short ts = ts +addToTrees [] _ _ ts = ts addToTrees ss pkg short [] = mkSubTree ss pkg short addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) | s1 > s2 = t : addToTrees (s1:ss) pkg short ts @@ -37,12 +36,12 @@ this_short = if null ss then short else node_short mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -mkSubTree [] pkg short = [] +mkSubTree [] _ _ = [] mkSubTree [s] pkg short = [Node s True pkg short []] mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] splitModule :: Module -> [String] -splitModule mod = split (moduleNameString (moduleName mod)) +splitModule mdl = split (moduleNameString (moduleName mdl)) where split mod0 = case break (== '.') mod0 of (s1, '.':s2) -> s1 : split s2 (s1, _) -> [s1] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -29,8 +29,8 @@ parseHaddockOpts :: [String] -> IO ([Flag], [String]) -parseHaddockOpts words = - case getOpt Permute (options True) words of +parseHaddockOpts params = + case getOpt Permute (options True) params of (flags, args, []) -> return (flags, args) (_, _, errors) -> do usage <- getUsage diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -47,8 +47,8 @@ -- | Maybe a doc comment expItemMbDoc :: Maybe (HsDoc name), - -- | Documentation for subordinate declarations - expItemSubDocs :: [(name, HsDoc name)], + -- | Subordinate names, possibly with documentation + expItemSubDocs :: [(name, Maybe (HsDoc name))], -- | Instances relevant to this declaration expItemInstances :: [InstHead name] @@ -56,11 +56,7 @@ } -- ^ An exported declaration | ExportNoDecl { - -- | The original name - expItemName :: Name, - - -- | Where to link to - expItemLinkTarget :: name, + expItemName :: name, -- | Subordinate names expItemSubs :: [name] @@ -89,6 +85,7 @@ type InstHead name = ([HsPred name], name, [HsType name]) type ModuleMap = Map Module Interface +type InstIfaceMap = Map Module InstalledInterface type DocMap = Map Name (HsDoc DocName) type LinkEnv = Map Name Module @@ -136,6 +133,7 @@ ifaceDeclMap :: Map Name DeclInfo, ifaceRnDocMap :: Map Name (HsDoc DocName), + ifaceSubMap :: Map Name [Name], ifaceExportItems :: ![ExportItem Name], ifaceRnExportItems :: [ExportItem DocName], @@ -167,7 +165,9 @@ instInfo :: HaddockModInfo Name, instDocMap :: Map Name (HsDoc DocName), instExports :: [Name], - instVisibleExports :: [Name] + instVisibleExports :: [Name], + instOptions :: [DocOption], + instSubMap :: Map Name [Name] } @@ -178,7 +178,9 @@ instInfo = ifaceInfo interface, instDocMap = ifaceRnDocMap interface, instExports = ifaceExports interface, - instVisibleExports = ifaceVisibleExports interface + instVisibleExports = ifaceVisibleExports interface, + instOptions = ifaceOptions interface, + instSubMap = ifaceSubMap interface } diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs --- a/src/Haddock/Version.hs +++ b/src/Haddock/Version.hs @@ -15,4 +15,5 @@ projectName = "Haddock" projectUrl = "http://www.haskell.org/haddock/" +projectVersion :: String projectVersion = showVersion version diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -160,26 +160,29 @@ #endif #if __GLASGOW_HASKELL__ >= 609 + -- We have one global error handler for all GHC source errors. Other kinds + -- of exceptions will be propagated to the top-level error handler. + let handleSrcErrors action = flip handleSourceError action $ \err -> do + printExceptionAndWarnings err + liftIO exitFailure + -- initialize GHC - startGhc libDir (ghcFlags flags) $ \dynflags -> do + startGhc libDir (ghcFlags flags) $ \dynflags -> handleSrcErrors $ do -- get packages supplied with --read-interface packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags) - -- combine the link envs of the external packages into one - let extLinks = Map.unions (map (ifLinkEnv . fst) packages) -- create the interfaces -- this is the core part of Haddock - (interfaces, homeLinks) <- createInterfaces fileArgs extLinks flags + (interfaces, homeLinks) <- createInterfaces fileArgs flags + (map fst packages) - let visibleIfaces = [ i | i <- interfaces, OptHide `notElem` ifaceOptions i ] - liftIO $ do -- render the interfaces - renderStep packages visibleIfaces + renderStep packages interfaces -- last but not least, dump the interface file - dumpInterfaceFile (map toInstalledIface visibleIfaces) homeLinks flags + dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags #else -- initialize GHC (session, dynflags) <- startGhc libDir (ghcFlags flags) @@ -187,19 +190,15 @@ -- get packages supplied with --read-interface packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags) - -- combine the link envs of the external packages into one - let extLinks = Map.unions (map (ifLinkEnv . fst) packages) - -- create the interfaces -- this is the core part of Haddock - (interfaces, homeLinks) <- createInterfaces session fileArgs extLinks flags - - let visibleIfaces = [ i | i <- interfaces, OptHide `notElem` ifaceOptions i ] + (interfaces, homeLinks) <- createInterfaces session fileArgs flags + (map fst packages) -- render the interfaces - renderStep packages visibleIfaces + renderStep packages interfaces -- last but not least, dump the interface file - dumpInterfaceFile (map toInstalledIface visibleIfaces) homeLinks flags + dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags #endif else do -- get packages supplied with --read-interface @@ -216,7 +215,7 @@ -- | Render the interfaces with whatever backend is specified in the flags render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO () -render flags visibleIfaces installedIfaces = do +render flags ifaces installedIfaces = do let title = case [str | Flag_Heading str <- flags] of [] -> "" @@ -271,11 +270,13 @@ prologue <- getPrologue flags let + visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] + -- *all* visible interfaces including external package modules - allVisibleIfaces = map toInstalledIface visibleIfaces - ++ installedIfaces - - packageMod = ifaceMod (head visibleIfaces) + allIfaces = map toInstalledIface ifaces ++ installedIfaces + allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] + + packageMod = ifaceMod (head ifaces) packageStr = Just (modulePackageString packageMod) (pkgName,pkgVer) = modulePackageInfo packageMod @@ -303,7 +304,9 @@ copyHtmlBits odir libdir css_file when (Flag_Hoogle `elem` flags) $ do - ppHoogle pkgName pkgVer title prologue visibleIfaces odir + let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName + ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir + ------------------------------------------------------------------------------- -- Reading and dumping interface files