From f223e6a93505fd439d42b276fa47cc49acd33704 Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Fri, 27 Feb 2009 21:37:20 +0000
Subject: Bug fix We tried to filter out subordinates that were already
 exported through their parent.

This didn't work properly since we were in some cases looking at the
grand-parent and not the parent.  We now properly compute all the parent-child
relations of a declaration, and use this information to get the parent of a
subordinate.

We also didn't consider record fields with multiple parents. This is now
handled correctly.

We don't currently support separately exported associated types. But when we
do, they should be handled correctly by this process too.

Also slightly improved the warning message that we give when filtering out
subordinates.
---
 src/Haddock/GHC/Utils.hs | 65 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 65 insertions(+)

(limited to 'src/Haddock/GHC')

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 _ _ = []
-- 
cgit v1.2.3