Fix fallout from wildcards refactoring

The wildcard refactoring was introduced a new type of signature,
`ClassOpSig`, which is carried by typeclasses. The original patch
adapting Haddock for this change missed a few places where this
constructor needed to be handled, resulting in no class methods
in documentation produced by Haddock.

Additionally, this moves and renames the `isVanillaLSig` helper from
GHC's HsBinds module into GhcUtils, since it is only used by Haddock.

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 0b5a3356..d54f4e16 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -412,7 +412,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
@@ -451,7 +451,7 @@ ppClassDecl summary links instances fixities loc d subdocs
                   +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
   where
     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 ab4d6c78..2fbc5f82 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -96,6 +96,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
@@ -106,13 +110,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 30b32963..7da965ac 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -396,7 +396,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
@@ -428,7 +428,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
@@ -441,7 +441,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 845cb909..091d9bff 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -441,6 +441,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