aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/GHC')
-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 _ _ = []