diff options
| -rw-r--r-- | src/Haddock/GHC/Utils.hs | 65 | ||||
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 18 |
2 files changed, 75 insertions, 8 deletions
diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs index 40e13004..c0e73425 100644 --- 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 @@ module Haddock.GHC.Utils where import Data.Char import Data.Version import qualified Data.Map as Map +import Control.Arrow import HsSyn import SrcLoc @@ -113,3 +115,66 @@ pretty x = showSDoc (ppr x) 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/Create.hs b/src/Haddock/Interface/Create.hs index e6c216e5..140d5358 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -389,13 +389,14 @@ mkExportItems modMap this_mod exported_names decls declMap -- name out in mkVisibleNames... | t `elem` declATs (unL decl) -> return [] - -- We should not show a subordinate at the top level if its - -- parent is also exported. See note [1]. - | declName /= t, isExported declName -> + -- 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 listed separately in " ++ - "the export list of " ++ pretty this_mod ++ ", but " ++ + "the export list, but " ++ "will be documented under its parent. " ++ "Consider exporting it through the parent "++ "export item only, for code clarity." ] @@ -459,13 +460,14 @@ mkExportItems modMap this_mod exported_names decls declMap -- Note [1]: ------------ --- We should not show a subordinate at the top level if its parent is also --- exported. We should show it under the parent to indicate its special --- status as a class method or record field. Showing it again makes no sense. +-- 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 same export item for clarity. +-- 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. |