aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/GHC/Utils.hs65
-rw-r--r--src/Haddock/Interface/Create.hs18
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.