diff options
Diffstat (limited to 'haddock-api/src/Haddock/GhcUtils.hs')
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 33 |
1 files changed, 17 insertions, 16 deletions
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 43112ff3..e64d298f 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -100,7 +100,10 @@ filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (FixSig (FixitySig ns ty)) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (FixSig (FixitySig filtered ty)) filterSigNames _ orig@(MinimalSig _) = Just orig filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of @@ -116,12 +119,12 @@ sigName :: LSig name -> [name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n] -sigNameNoLoc _ = [] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns +sigNameNoLoc _ = [] isTyClD :: HsDecl a -> Bool @@ -195,11 +198,6 @@ instance Traversable (GenLocated l) where instance NamedThing (TyClDecl Name) where getName = tcdName - -instance NamedThing (ConDecl Name) where - getName = unL . con_name - - ------------------------------------------------------------------------------- -- * Subordinates ------------------------------------------------------------------------------- @@ -212,13 +210,13 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map (unL . cd_fld_name) fields + RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields _ -> [] - instance Parent (TyClDecl Name) where children d - | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d + | isDataDecl d = map unL $ concatMap (con_names . unL) + $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] @@ -230,11 +228,14 @@ family :: (NamedThing a, Parent a) => a -> (Name, [Name]) family = getName &&& children +familyConDecl :: ConDecl Name -> [(Name, [Name])] +familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) + -- | 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) (dd_cons (tcdDataDefn d)) + | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] |