diff options
author | David Waern <david.waern@gmail.com> | 2009-11-24 20:55:49 +0000 |
---|---|---|
committer | David Waern <david.waern@gmail.com> | 2009-11-24 20:55:49 +0000 |
commit | dc3a42156eeb0fd1457a395e69f5778c0446caa5 (patch) | |
tree | 480019738b5aa5060ac43e133949f7fb1e09eab9 /src | |
parent | 53f11cbd4af38e88ef547fec54cc42f976b1d048 (diff) |
Comments on instances
Implementing this was a little trickier than I thought, since we need to match
up instances from the renamed syntax with instances represented by
InstEnv.Instance. This is due to the current design of Haddock, which matches
comments with declarations from the renamed syntax, while getting the list of
instances of a class/family directly using the GHC API.
- Works for class instances only (Haddock has no support for type family
instances yet)
- The comments are rendered to the right of the instance head in the HTML output
- No change to the .haddock file format
- Works for normal user-written instances only. No comments are added on
derived or TH-generated instances
Diffstat (limited to 'src')
-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) } |