Add better support for default signatures in class definitions

haddock-api/src/Haddock/Backends/Xhtml/Decl.hs

@@ -63,14 +63,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
              [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
              Splice -> Unicode -> Qualification -> Html
 ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
-  ppFunSig summary links loc doc (map unLoc lnames) lty fixities
+  ppFunSig summary links loc mempty doc (map unLoc lnames) lty fixities
            splice unicode qual
 
-ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
             [DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
             Splice -> Unicode -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
-  ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
+ppFunSig summary links loc leader doc docnames typ fixities splice unicode qual =
+  ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ)
             splice unicode qual HideEmptyContexts
   where
     pp_typ = ppLType unicode qual HideEmptyContexts typ
@@ -184,7 +184,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
       -> Splice -> Unicode -> Qualification -> Html
 ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
       splice unicode qual
-  = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual
+  = ppFunSig summary links loc mempty doc [name] (hsSigType typ) fixities splice unicode qual
 ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
 
 
@@ -468,7 +468,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
 
                 -- ToDo: add associated type defaults
 
-            [ ppFunSig summary links loc doc names (hsSigWcType typ)
+            [ ppFunSig summary links loc mempty doc names (hsSigWcType typ)
                        [] splice unicode qual
               | L _ (TypeSig lnames typ) <- sigs
               , let doc = lookupAnySubdoc (head names) subdocs
@@ -516,17 +516,36 @@ ppClassDecl summary links instances fixities loc d subdocs
                             doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
                             subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
 
-    methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)
+    namesFixities names = [ f | n <- names
+                          , f@(n', _) <- fixities
+                          , n == n'
+                          ]
+
+    ppDefaultFunSig (names', typ', doc') = ppFunSig summary links loc
+        (keyword "default") doc' names' (hsSigType typ') [] splice unicode qual
+
+    methodBit = subMethods [ ppFunSig summary links loc mempty doc names (hsSigType typ)
                                       subfixs splice unicode qual
-                           | L _ (ClassOpSig _ lnames typ) <- lsigs
+                                  <+> subDefaults defaultsSigs
+                           | L _ (ClassOpSig False lnames typ) <- lsigs
                            , let doc = lookupAnySubdoc (head names) subdocs
-                                 subfixs = [ f | n <- names
-                                               , f@(n',_) <- fixities
-                                               , n == n' ]
-                                 names = map unLoc lnames ]
+                                 names = map unLoc lnames
+                                 subfixs = namesFixities names
+                                 nameStrs = getOccString . getName <$> names
+                                 defaults = flip Map.lookup defaultMethods <$> nameStrs
+                                 defaultsSigs = ppDefaultFunSig <$> catMaybes defaults
+                           ]
                            -- N.B. taking just the first name is ok. Signatures with multiple names
                            -- are expanded so that each name gets its own signature.
 
+    defaultMethods = Map.fromList
+        [ (nameStr, (names, typ, doc))
+        | L _ (ClassOpSig True lnames typ) <- lsigs
+        , let names   = map (uniquifyName . unLoc) lnames
+              nameStr = getOccString $ getName $ head names
+              doc     = lookupAnySubdoc (head names) subdocs
+        ]
+
     minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
       -- Miminal complete definition = every shown method
       And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==

haddock-api/src/Haddock/Backends/Xhtml/Layout.hs

@@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout (
   subInstances, subOrphanInstances,
   subInstHead, subInstDetails, subFamInstDetails,
   subMethods,
+  subDefaults,
   subMinimal,
 
   topDeclElem, declElem,
@@ -252,6 +253,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid
 subMethods :: [Html] -> Html
 subMethods = divSubDecls "methods" "Methods" . subBlock
 
+subDefaults :: [Html] -> Html
+subDefaults = divSubDecls "default" "" . subBlock
+
 subMinimal :: Html -> Html
 subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
 

haddock-api/src/Haddock/GhcUtils.hs

@@ -16,6 +16,7 @@
 module Haddock.GhcUtils where
 
 
+import Control.Applicative (liftA2)
 import Control.Arrow
 
 import Exception
@@ -27,7 +28,9 @@ import Module
 import HscTypes
 import GHC
 import Class
+import Unique (deriveUnique, getKey)
 
+import Haddock.Types (SetName(..))
 
 moduleString :: Module -> String
 moduleString = moduleNameString . moduleName
@@ -43,12 +46,15 @@ isConSym :: OccName -> Bool
 isConSym = isLexConSym . occNameFS
 
 
-getMainDeclBinder :: HsDecl name -> [name]
+getMainDeclBinder :: (NamedThing name, SetName name) => HsDecl name -> [name]
 getMainDeclBinder (TyClD d) = [tcdName d]
 getMainDeclBinder (ValD d) =
   case collectHsBindBinders d of
     []       -> []
     (name:_) -> [name]
+-- Uniquify default method signatures to make sure that their doc comments
+-- will be preserved and mapped accurately.
+getMainDeclBinder (SigD d@(ClassOpSig True _ _)) = uniquifyName <$> sigNameNoLoc d
 getMainDeclBinder (SigD d) = sigNameNoLoc d
 getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
 getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
@@ -111,6 +117,14 @@ sigNameNoLoc (InlineSig    n _)        = [unLoc n]
 sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
 sigNameNoLoc _                         = []
 
+
+uniquifyName :: (NamedThing name, SetName name) => name -> name
+uniquifyName = liftA2 setName (updateName . getName) id
+  where
+    updateName = liftA2 setNameUnique id $
+        liftA2 deriveUnique id ((+1) . getKey) . nameUnique
+
+
 -- | Was this signature given by the user?
 isUserLSig :: LSig name -> Bool
 isUserLSig (L _(TypeSig {}))    = True

haddock-api/src/Haddock/Interface/Create.hs

@@ -137,11 +137,16 @@ createInterface tm flags modMap instIfaceMap = do
   maps@(!docMap, !argMap, !subMap, !declMap, _) <-
     liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
 
+  -- Also export uniquified default signatures that correspond to
+  -- exported base method signatures.
+  let allDecls = decls ++ concat (foldMap ifaceDeclMap modMap)
+      exportedNames' = exportedNames ++ additionalExportedNames exportedNames allDecls
+
   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
 
   -- The MAIN functionality: compute the export items which will
   -- each be the actual documentation of this module.
-  exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
+  exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames' decls
                    maps localBundledPatSyns fixMap splices exports instIfaceMap dflags
 
   let !visibleNames = mkVisibleNames maps exportItems opts
@@ -180,7 +185,7 @@ createInterface tm flags modMap instIfaceMap = do
   , ifaceRnArgMap          = M.empty
   , ifaceExportItems       = prunedExportItems
   , ifaceRnExportItems     = []
-  , ifaceExports           = exportedNames
+  , ifaceExports           = exportedNames'
   , ifaceVisibleExports    = visibleNames
   , ifaceDeclMap           = declMap
   , ifaceBundledPatSynMap  = localBundledPatSyns
@@ -196,6 +201,19 @@ createInterface tm flags modMap instIfaceMap = do
   , ifaceTokenizedSrc      = tokenizedSrc
   }
 
+additionalExportedNames :: [Name] -> [LHsDecl Name] -> [Name]
+additionalExportedNames exportedNames = foldMap go
+  where
+    go (L _ (TyClD d)) | isClassDecl d =
+        [ defName
+        | (L _ (SigD (ClassOpSig True ns _)), _) <- classDecls d
+        , name <- ns
+        , let name' = unLoc name
+        , name' `elem` exportedNames
+        , let defName  = uniquifyName name'
+        ]
+    go _ = []
+
 -- | Given all of the @import M as N@ declarations in a package,
 -- create a mapping from the module identity of M, to an alias N
 -- (if there are multiple aliases, we pick the last one.)  This

html-test/ref/DefaultSignatures.html

@@ -0,0 +1,172 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><title
+    >DefaultSignatures</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+    ></script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ><p class="caption empty"
+      ></p
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>DefaultSignatures</p
+	></div
+      ><div id="synopsis"
+      ><details id="syn"
+	><summary
+	  >Synopsis</summary
+	  ><ul class="details-toggle" data-details-id="syn"
+	  ><li class="src short"
+	    ><span class="keyword"
+	      >class</span
+	      > <a href="#"
+	      >Foo</a
+	      > a <span class="keyword"
+	      >where</span
+	      ><ul class="subs"
+	      ></ul
+	      ></li
+	    ></ul
+	  ></details
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><span class="keyword"
+	    >class</span
+	    > <a id="t:Foo" class="def"
+	    >Foo</a
+	    > a <span class="keyword"
+	    >where</span
+	    > <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Documentation for Foo.</p
+	    ></div
+	  ><div class="subs minimal"
+	  ><p class="caption"
+	    >Minimal complete definition</p
+	    ><p class="src"
+	    ><a href="#"
+	      >baz</a
+	      ></p
+	    ></div
+	  ><div class="subs methods"
+	  ><p class="caption"
+	    >Methods</p
+	    ><p class="src"
+	    ><a id="v:bar" class="def"
+	      >bar</a
+	      > :: a -&gt; <a href="#"
+          >String</a
+          > <a href="#" class="selflink"
+	      >#</a
+	      ></p
+	    ><div class="doc"
+	    ><p
+	      >Documentation for bar and baz.</p
+	      ></div
+	    > <div class="subs default"
+	    ><p class="caption"
+	      ></p
+	      ><p class="src"
+	      ><span class="keyword"
+		>default</span
+		> <a id="v:bar" class="def"
+		>bar</a
+		> :: <a href="#"
+        >Show</a
+        > a =&gt; a -&gt; <a href="#"
+        >String</a
+        > <a href="#" class="selflink"
+		>#</a
+		></p
+	      ><div class="doc"
+	      ><p
+		>Documentation for the default signature of bar.</p
+		></div
+	      ></div
+	    ><p class="src"
+	    ><a id="v:baz" class="def"
+	      >baz</a
+	      > :: a -&gt; <a href="#"
+          >String</a
+          > <a href="#" class="selflink"
+	      >#</a
+	      ></p
+	    ><div class="doc"
+	    ><p
+	      >Documentation for bar and baz.</p
+	      ></div
+	    ><p class="src"
+	    ><a id="v:baz-39-" class="def"
+	      >baz'</a
+	      > :: <a href="#"
+          >String</a
+          > -&gt; a <a href="#" class="selflink"
+	      >#</a
+	      ></p
+	    ><div class="doc"
+	    ><p
+	      >Documentation for baz'.</p
+	      ></div
+	    > <div class="subs default"
+	    ><p class="caption"
+	      ></p
+	      ><p class="src"
+	      ><span class="keyword"
+		>default</span
+		> <a id="v:baz-39-" class="def"
+		>baz'</a
+		> :: <a href="#"
+        >Read</a
+        > a =&gt; <a href="#"
+        >String</a
+        > -&gt; a <a href="#" class="selflink"
+		>#</a
+		></p
+	      ><div class="doc"
+	      ><p
+		>Documentation for the default signature of baz'.</p
+		></div
+	      ></div
+	    ></div
+	  ></div
+	></div
+      ></div
+    ><div id="footer"
+    ></div
+    ></body
+  ></html
+>

html-test/src/DefaultSignatures.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+module DefaultSignatures where
+
+-- | Documentation for Foo.
+class Foo a where
+  -- | Documentation for bar and baz.
+  bar, baz :: a -> String
+
+  -- | Documentation for the default signature of bar.
+  default bar :: Show a => a -> String
+  bar = show
+
+  -- | Documentation for baz'.
+  baz' :: String -> a
+
+  -- | Documentation for the default signature of baz'.
+  default baz' :: Read a => String -> a
+  baz' = read