Mon Nov 20 20:58:26 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11258,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13
Link       : http://git.haskell.org/haddock.git/commitdiff/3de72a80fff18aa71873ace86d1aeb5171b09b41

>---------------------------------------------------------------

commit 3de72a80fff18aa71873ace86d1aeb5171b09b41
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Dec 16 06:05:25 2015 -0500

    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.


>---------------------------------------------------------------

3de72a80fff18aa71873ace86d1aeb5171b09b41
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs |  4 ++--
 haddock-api/src/Haddock/GhcUtils.hs            | 18 ++++++++++++++----
 haddock-api/src/Haddock/Interface/Create.hs    |  6 +++---
 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 d27cb2b..49149b8 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 2a9fba2..4e5e008 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 d427be6..c41946f 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 859afe6..2478ce2 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

