diff options
Diffstat (limited to 'src/Haddock/GHC')
-rw-r--r-- | src/Haddock/GHC/Utils.hs | 65 |
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 _ _ = [] |