diff options
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 18 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 6 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 4 |
4 files changed, 23 insertions, 9 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d27cb2bc..49149b8c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -451,7 +451,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats + if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False @@ -492,7 +492,7 @@ ppClassDecl summary links instances fixities loc d subdocs sigs = map unLoc lsigs classheader - | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 2a9fba2e..4e5e008b 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -95,6 +95,10 @@ filterSigNames p (TypeSig ns ty) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (TypeSig filtered ty) +filterSigNames p (ClassOpSig is_default ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (ClassOpSig is_default filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -105,13 +109,19 @@ 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 (TypeSig ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ 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 _ = [] +-- | Was this signature given by the user? +isUserLSig :: LSig name -> Bool +isUserLSig (L _(TypeSig {})) = True +isUserLSig (L _(ClassOpSig {})) = True +isUserLSig _ = False isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d427be6c..c41946f5 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -402,7 +402,7 @@ ungroup group_ = mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where - typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds @@ -434,7 +434,7 @@ filterDecls = filter (isHandled . unL . fst) isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True - isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True @@ -447,7 +447,7 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 859afe6e..2478ce23 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -459,6 +459,10 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype return (TypeSig lnames' ltype') + ClassOpSig is_default lnames sig_ty -> do + lnames' <- mapM renameL lnames + ltype' <- renameLSigType sig_ty + return (ClassOpSig is_default lnames' ltype') PatSynSig lname sig_ty -> do lname' <- renameL lname sig_ty' <- renameLSigType sig_ty |