diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c78bee2d5e..58be3f991c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/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] == diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index e020b90991..9e7b82c3ff 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/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 diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 028678339e..792fd77636 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/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 diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 87cdb01f5f..3735fa05a0 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/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 diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html new file mode 100644 index 0000000000..fe9b49b067 --- /dev/null +++ b/html-test/ref/DefaultSignatures.html @@ -0,0 +1,172 @@ +DefaultSignatures

Safe HaskellSafe

DefaultSignatures

Synopsis
  • class Foo a where

    Documentation

    class Foo a where #

    Documentation for Foo.

    Minimal complete definition

    baz

    Methods

    bar :: a -> String #

    Documentation for bar and baz.

    default bar :: Show a => a -> String #

    Documentation for the default signature of bar.

    baz :: a -> String #

    Documentation for bar and baz.

    baz' :: String -> a #

    Documentation for baz'.

    default baz' :: Read a => String -> a #

    Documentation for the default signature of baz'.

    diff --git a/html-test/src/DefaultSignatures.hs b/html-test/src/DefaultSignatures.hs new file mode 100644 index 0000000000..52d68a9609 --- /dev/null +++ b/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