aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs4
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs18
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs4
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