aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/GHC/Utils.hs
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2009-02-27 21:37:20 +0000
committerDavid Waern <david.waern@gmail.com>2009-02-27 21:37:20 +0000
commitf223e6a93505fd439d42b276fa47cc49acd33704 (patch)
treef99d73266af88f3991c234adb6b90b173d878c7d /src/Haddock/GHC/Utils.hs
parent26a30e47e491c5b6a1ba21e119c0491cf4ea0732 (diff)
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.
Diffstat (limited to 'src/Haddock/GHC/Utils.hs')
-rw-r--r--src/Haddock/GHC/Utils.hs65
1 files changed, 65 insertions, 0 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 _ _ = []