diff options
-rw-r--r-- | src/Haddock/Backends/Html.hs | 47 | ||||
-rw-r--r-- | src/Haddock/Interface.hs | 2 | ||||
-rw-r--r-- | src/Haddock/Interface/AttachInstances.hs | 43 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 34 | ||||
-rw-r--r-- | src/Haddock/Interface/Rename.hs | 15 | ||||
-rw-r--r-- | src/Haddock/Types.hs | 15 |
6 files changed, 110 insertions, 46 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index fead8470..93c2a491 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -809,7 +809,7 @@ declWithDoc False links loc nm (Just doc) html_decl = -- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - DocForDecl DocName -> [InstHead DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable + DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode TyClD d@(TyData {}) @@ -955,7 +955,7 @@ ppTyFam summary associated links loc mbDoc decl unicode tda [theclass "body"] << collapsed thediv instId ( spacedTable1 << ( - aboves (map (declBox . ppInstHead unicode) instances) + aboves (map (ppDocInstance unicode) instances) ) ) @@ -1150,7 +1150,7 @@ ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortC -ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Maybe (HsDoc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> HtmlTable ppClassDecl summary links instances loc mbDoc subdocs @@ -1191,12 +1191,19 @@ ppClassDecl summary links instances loc mbDoc subdocs = s8 </> instHdr instId </> tda [theclass "body"] << collapsed thediv instId ( - spacedTable1 << ( - aboves (map (declBox . ppInstHead unicode) instances) - )) + spacedTable1 << aboves (map (ppDocInstance unicode) instances) + ) ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +-- | Print a possibly commented instance. The instance header is printed inside +-- an 'argBox'. The comment is printed to the right of the box in normal comment +-- style. +ppDocInstance :: Bool -> DocInstance DocName -> HtmlTable +ppDocInstance unicode (_, instHead, maybeDoc) = + argBox (ppInstHead unicode instHead) <-> maybeRDocBox maybeDoc + + ppInstHead :: Bool -> InstHead DocName -> Html ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode @@ -1249,7 +1256,7 @@ ppShortDataDecl summary links loc dataDecl unicode cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons -ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode @@ -1303,8 +1310,7 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode = instHdr instId </> tda [theclass "body"] << collapsed thediv instId ( - spacedTable1 << ( - aboves (map (declBox . ppInstHead unicode) instances) + spacedTable1 << aboves (map (ppDocInstance unicode) instances ) ) @@ -1374,17 +1380,17 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of PrefixCon args -> argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) - <-> maybeRDocBox mbLDoc + <-> maybeRDocBox mbDoc RecCon fields -> argBox (header_ unicode +++ ppBinder False occ) <-> - maybeRDocBox mbLDoc + maybeRDocBox mbDoc </> doRecordFields fields InfixCon arg1 arg2 -> argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2]) - <-> maybeRDocBox mbLDoc + <-> maybeRDocBox mbDoc ResTyGADT resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to @@ -1401,7 +1407,7 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [ ppForAll forall ltvs (con_cxt con) unicode, ppLType unicode (foldr mkFunTy resTy args) ] - ) <-> maybeRDocBox mbLDoc + ) <-> maybeRDocBox mbDoc header_ = ppConstrHdr forall tyVars context @@ -1412,19 +1418,17 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - -- The 'fmap' and 'join' are in Maybe - mbLDoc = fmap noLoc $ join $ fmap fst $ - lookup (unLoc $ con_name con) subdocs + -- 'join' is in Maybe. + mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = argBox (ppBinder False (docNameOcc name) - <+> dcolon unicode <+> ppLType unicode ltype) <-> - maybeRDocBox mbLDoc + <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbLDoc = fmap noLoc $ join $ fmap fst $ lookup name subdocs + mbDoc = join $ fmap fst $ lookup name subdocs {- ppHsFullConstr :: HsConDecl -> Html @@ -1764,6 +1768,7 @@ htmlCleanup = idMarkup { -- ----------------------------------------------------------------------------- -- * Misc + hsep :: [Html] -> Html hsep [] = noHtml hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls @@ -1890,9 +1895,9 @@ ndocBox html = tda [theclass "ndoc"] << html rdocBox :: Html -> HtmlTable rdocBox html = tda [theclass "rdoc"] << html -maybeRDocBox :: Maybe (LHsDoc DocName) -> HtmlTable +maybeRDocBox :: Maybe (HsDoc DocName) -> HtmlTable maybeRDocBox Nothing = rdocBox (noHtml) -maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc)) +maybeRDocBox (Just doc) = rdocBox (docToHtml doc) -- a box for the buttons at the top of the page topButBox :: Html -> HtmlTable diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 6cbd4c9a..cc53efdf 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -61,7 +61,7 @@ createInterfaces verbosity modules flags extIfaces = do -- part 3, attach instances out verbosity verbose "Attaching instances..." - interfaces' <- attachInstances interfaces + interfaces' <- attachInstances interfaces instIfaceMap -- part 4, rename interfaces out verbosity verbose "Renaming interfaces..." diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index b996f278..a10cb36a 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -18,7 +18,9 @@ module Haddock.Interface.AttachInstances (attachInstances) where import Haddock.Types import Haddock.Convert +import Control.Arrow import Data.List +import qualified Data.Map as Map import GHC import Name @@ -40,22 +42,38 @@ import FastString #define FSLIT(x) (mkFastString# (x#)) -attachInstances :: [Interface] -> Ghc [Interface] -attachInstances = mapM attach +attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface] +attachInstances ifaces instIfaceMap = mapM attach ifaces where attach iface = do newItems <- mapM attachExport $ ifaceExportItems iface return $ iface { ifaceExportItems = newItems } - - attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do - mb_info <- getAllInfo (unLoc (tcdLName d)) - return $ export { expItemInstances = case mb_info of - Just (_, _, instances) -> - map synifyInstHead . sortImage instHead . map instanceHead $ instances - Nothing -> - [] - } - attachExport export = return export + where + attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do + mb_info <- getAllInfo (unLoc (tcdLName d)) + return $ export { expItemInstances = case mb_info of + Just (_, _, instances) -> + let insts = map (first synifyInstHead) $ sortImage (first instHead) + [ (instanceHead i, getName i) | i <- instances ] + in [ (name, inst, lookupInstDoc name iface instIfaceMap) + | (inst, name) <- insts ] + Nothing -> [] + } + attachExport export = return export + + +lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (HsDoc Name) +-- TODO: capture this pattern in a function (when we have streamlined the +-- handling of instances) +lookupInstDoc name iface ifaceMap = + case Map.lookup name (ifaceInstanceDocMap iface) of + Just doc -> Just doc + Nothing -> do -- in Maybe + instIface <- Map.lookup modName ifaceMap + (Just doc, _) <- Map.lookup name (instDocMap instIface) + return doc + where + modName = nameModule name -- | Like GHC's getInfo but doesn't cut things out depending on the @@ -63,6 +81,7 @@ attachInstances = mapM attach getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name + -------------------------------------------------------------------------------- -- Collecting and sorting instances -------------------------------------------------------------------------------- diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index f1023825..874037d7 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -56,13 +56,18 @@ createInterface ghcMod flags modMap instIfaceMap = do (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader gre (ghcMbDocHdr ghcMod) decls0 <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod)) - let decls = filterOutInstances decls0 + + let instances = ghcInstances ghcMod + localInsts = filter (nameIsLocalOrFrom mdl . getName) instances + declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ] + instanceDocMap = mkInstanceDocMap localInsts declDocs + + decls = filterOutInstances decls0 declMap = mkDeclMap decls exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod) localNames = ghcDefinedNames ghcMod ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod - instances = ghcInstances ghcMod liftErrMsg $ warnAboutFilteredDecls mdl decls0 @@ -93,7 +98,8 @@ createInterface ghcMod flags modMap instIfaceMap = do ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, ifaceSubMap = mkSubMap declMap exportedNames, - ifaceInstances = ghcInstances ghcMod + ifaceInstances = instances, + ifaceInstanceDocMap = instanceDocMap } @@ -128,6 +134,22 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -- Declarations -------------------------------------------------------------------------------- + +mkInstanceDocMap :: [Instance] -> [(HsDecl name, doc)] -> Map Name doc +mkInstanceDocMap instances decls = + -- We relate Instances to InstDecls using the SrcSpans buried inside them. + -- That should work for normal user-written instances (from looking at GHC + -- sources). We can assume that commented instances are user-written. + -- This lets us relate Names (from Instances) to comments (associated + -- with InstDecls). + let docMap = Map.fromList [ (loc, doc) + | (InstD (InstDecl (L loc _) _ _ _), doc) <- decls ] + + in Map.fromList [ (name, doc) | inst <- instances + , let name = getName inst + , Just doc <- [ Map.lookup (getSrcSpan name) docMap ] ] + + -- | Make a sub map from a declaration map. Make sure we only include exported -- names. mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name] @@ -137,13 +159,13 @@ mkSubMap declMap exports = 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 +-- Make a map from names to 'DeclInfo's. Exclude declarations that don't have +-- names (e.g. instances and stand-alone documentation comments). Include -- subordinate names, but map them to their parent declarations. mkDeclMap :: [DeclInfo] -> Map Name DeclInfo mkDeclMap decls = Map.fromList . concat $ [ (declName d, (parent, doc, subs)) : subDecls - | (parent@(L _ d), doc, subs) <- decls + | (parent@(L _ d), doc, subs) <- decls , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] , not (isDocD d), not (isInstD d) ] diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 5eac9e67..308c86c5 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -37,8 +37,13 @@ renameInterface renamingEnv warnings iface = let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) where fn env name = Map.insert name (ifaceMod iface) env - docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) - docs = Map.toList docMap + docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) + + -- make instance docs into 'docForDecls' + instDocs = [ (name, (Just doc, Map.empty)) + | (name, doc) <- Map.toList (ifaceInstanceDocMap iface) ] + + docs = Map.toList docMap ++ instDocs renameMapElem (k,d) = do d' <- renameDocForDecl d; return (k, d') -- rename names in the exported declarations to point to things that @@ -448,7 +453,11 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- mapM renameInstHead instances + instances' <- forM instances $ \(name, inst, idoc) -> do + name' <- rename name + inst' <- renameInstHead inst + idoc' <- mapM renameDoc idoc + return (name', inst', idoc') return (ExportDecl decl' doc' subs' instances') ExportNoDecl x subs -> do x' <- lookupRn id x diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 4c8c3656..d7d5e7bd 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -40,6 +40,8 @@ import Name type Decl = LHsDecl Name type Doc = HsDoc Name +type DocInstance name = (name, InstHead name, Maybe (HsDoc name)) + #if __GLASGOW_HASKELL__ <= 610 type HsDocString = HsDoc Name type LHsDocString = Located HsDocString @@ -98,8 +100,8 @@ data ExportItem name -- | Subordinate names, possibly with documentation expItemSubDocs :: [(name, DocForDecl name)], - -- | Instances relevant to this declaration - expItemInstances :: [InstHead name] + -- | Instances relevant to this declaration, possibly with documentation + expItemInstances :: [DocInstance name] } -- ^ An exported declaration @@ -131,7 +133,11 @@ data ExportItem name | ExportModule Module -- ^ A cross-reference to another module +-- | The head of an instance. Consists of a context, a class name and a list of +-- instance types. type InstHead name = ([HsPred name], name, [HsType name]) + + type ModuleMap = Map Module Interface type InstIfaceMap = Map Module InstalledInterface type DocMap = Map Name (HsDoc DocName) @@ -215,7 +221,10 @@ data Interface = Interface { ifaceVisibleExports :: ![Name], -- | The instances exported by this module - ifaceInstances :: ![Instance] + ifaceInstances :: ![Instance], + + -- | Docs for instances defined in this module + ifaceInstanceDocMap :: Map Name (HsDoc Name) } |