From 02e633a6f9b7ccb53a92a838c1b717ef9f3737fc Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 27 Sep 2015 20:50:15 +0300 Subject: Generate docs for orphan instances --- .../src/Haddock/Interface/AttachInstances.hs | 31 ++++++++++++++++------ haddock-api/src/Haddock/Interface/Create.hs | 2 ++ haddock-api/src/Haddock/Interface/Rename.hs | 25 ++++++++++------- 3 files changed, 41 insertions(+), 17 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index e2fd24ee..c3e1275e 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -61,7 +61,28 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces attach iface = do newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) (ifaceExportItems iface) - return $ iface { ifaceExportItems = newItems } + let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) + return $ iface { ifaceExportItems = newItems + , ifaceOrphanInstances = orphanInstances + } + +spanName :: NamedThing a => a -> InstHead e -> GenLocated SrcSpan e -> GenLocated SrcSpan e +spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = + let s1 = getSrcSpan s + sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL + then instn + else clsn + in L (getSrcSpan s) sn + +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] +attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = + [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L noSrcSpan n)) + | let is = [ (instanceHead' i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] + , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is + , not $ isInstanceHidden expInfo cls tys + ] + where + -- spanName: attach the location to the name that is the same file as the instance location attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap @@ -107,13 +128,7 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = ] } attachFixities e = e - -- spanName: attach the location to the name that is the same file as the instance location - spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = - let s1 = getSrcSpan s - sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL - then instn - else clsn - in L (getSrcSpan s) sn + -- spanName on Either spanNameE s (Left e) _ = L (getSrcSpan s) (Left e) spanNameE s (Right ok) linst = diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 0599151e..e158fb21 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -148,6 +148,8 @@ createInterface tm flags modMap instIfaceMap = do , ifaceModuleAliases = aliases , ifaceInstances = instances , ifaceFamInstances = fam_instances + , ifaceOrphanInstances = [] -- Filled in `attachInstances` + , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap , ifaceTokenizedSrc = tokenizedSrc diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 146a7c0b..dde8128d 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -47,13 +47,16 @@ renameInterface dflags renamingEnv warnings iface = (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) - (finalModuleDoc, missingNames4) + (renamedOrphanInstances, missingNames4) + = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface)) + + (finalModuleDoc, missingNames5) = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would - -- otherwise allways be missing. + -- otherwise always be missing. missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much - (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) + (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5) -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API. @@ -72,7 +75,8 @@ renameInterface dflags renamingEnv warnings iface = return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, ifaceRnArgMap = rnArgMap, - ifaceRnExportItems = renamedExportItems } + ifaceRnExportItems = renamedExportItems, + ifaceRnOrphanInstances = renamedOrphanInstances} -------------------------------------------------------------------------------- @@ -504,6 +508,13 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, = HsWB pats' PlaceHolder PlaceHolder PlaceHolder , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName) +renameDocInstance (inst, idoc, L l n) = do + inst' <- renameInstHead inst + n' <- rename n + idoc' <- mapM renameDoc idoc + return (inst', idoc',L l n') + renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) @@ -514,11 +525,7 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(inst, idoc, L l n) -> do - inst' <- renameInstHead inst - n' <- rename n - idoc' <- mapM renameDoc idoc - return (inst', idoc',L l n') + instances' <- forM instances renameDocInstance fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) -- cgit v1.2.3 From dee8ef2b918917a1469f35b24d7bd9f7caa59d62 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 28 Sep 2015 07:21:11 +0300 Subject: Have source links for orphan instances --- haddock-api/src/Haddock/Interface.hs | 2 +- haddock-api/src/Haddock/Interface/AttachInstances.hs | 20 ++++++++------------ 2 files changed, 9 insertions(+), 13 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 1bb04ed3..8b04d76b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -228,7 +228,7 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) foldl' keep_old old_env exported_names | otherwise = foldl' keep_new old_env exported_names where - exported_names = ifaceVisibleExports iface + exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index c3e1275e..5adee457 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -66,23 +66,13 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces , ifaceOrphanInstances = orphanInstances } -spanName :: NamedThing a => a -> InstHead e -> GenLocated SrcSpan e -> GenLocated SrcSpan e -spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = - let s1 = getSrcSpan s - sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL - then instn - else clsn - in L (getSrcSpan s) sn - attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = - [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L noSrcSpan n)) + [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) | let is = [ (instanceHead' i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] - where - -- spanName: attach the location to the name that is the same file as the instance location attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap @@ -128,7 +118,13 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = ] } attachFixities e = e - + -- spanName: attach the location to the name that is the same file as the instance location + spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = + let s1 = getSrcSpan s + sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL + then instn + else clsn + in L (getSrcSpan s) sn -- spanName on Either spanNameE s (Left e) _ = L (getSrcSpan s) (Left e) spanNameE s (Right ok) linst = -- cgit v1.2.3