diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index c9a262a456..1131d1c2c6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -11,7 +11,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE CPP, FlexibleContexts, NamedFieldPuns #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, @@ -390,7 +390,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs exportSubs _ = [] - exportName :: ExportItem name -> [IdP name] + exportName :: SetName (IdP name) => ExportItem name -> [IdP name] exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 1daf9ace27..0df74730b4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -64,14 +64,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities + ppFunSig summary links loc mempty doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ @@ -188,7 +188,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc mempty doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -475,7 +475,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc mempty doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -523,17 +523,35 @@ 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 [name] (hsSigType typ) + namesFixities name = [ f | f@(n', _) <- fixities + , name == n' ] + + ppDefaultFunSig (name', typ', doc') = ppFunSig summary links loc + (keyword "default") doc' [name'] (hsSigType typ') [] splice unicode pkg qual + + methodBit = subMethods [ ppFunSig summary links loc mempty doc [name] (hsSigType typ) subfixs splice unicode pkg qual - | L _ (ClassOpSig _ lnames typ) <- lsigs - , name <- map unLoc lnames + <+> subDefaults defaultSig + | L _ (ClassOpSig False lnames typ) <- lsigs + , let names = map unLoc lnames + , name <- names , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] + subfixs = namesFixities name + nameStr = getOccString $ getName name + default_ = Map.lookup nameStr defaultMethods + defaultSig = ppDefaultFunSig <$> maybeToList default_ ] -- 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, (name, typ, doc)) + | L _ (ClassOpSig True lnames typ) <- lsigs + , name <- map (uniquifyName . unLoc ) lnames + , let nameStr = getOccString $ getName name + doc = lookupAnySubdoc name 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 501caa4b32..e6c18a612a 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, @@ -255,6 +256,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 a1009c1f0c..54f17b9f74 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleInstances, FlexibleContexts, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -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 -> [IdP name] +getMainDeclBinder :: SetName (IdP name) => HsDecl name -> [IdP 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 _ _ _ _)) = [] @@ -112,6 +118,14 @@ sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns sigNameNoLoc _ = [] + +uniquifyName :: 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 a35e20530f..64e4d39892 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -142,12 +142,17 @@ createInterface tm flags modMap instIfaceMap = do maps@(!docMap, !argMap, !declMap, _) <- liftErrMsg (mkMaps dflags pkgName 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 pkgName mdl sem_mdl allWarnings gre - exportedNames decls maps fixMap unrestrictedImportedMods + exportedNames' decls maps fixMap unrestrictedImportedMods splices exports all_exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -186,7 +191,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceRnArgMap = M.empty , ifaceExportItems = prunedExportItems , ifaceRnExportItems = [] - , ifaceExports = exportedNames + , ifaceExports = exportedNames' , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap , ifaceFixMap = fixMap @@ -200,6 +205,18 @@ createInterface tm flags modMap instIfaceMap = do , ifaceTokenizedSrc = tokenizedSrc } +additionalExportedNames :: [Name] -> [LHsDecl GhcRn] -> [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 @@ -766,6 +783,16 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames bundledPatSyns <- findBundledPatterns avail let + + -- default method signature docs only need to be collected if the + -- class itself is exported. + defMethodSubs = + [ (defName, lookupDocForDecl defName warnings docMap argMap) + | TyClD ClassDecl{ tcdSigs = sigs } <- [unLoc decl] + , L _ defSig@(ClassOpSig True _ _) <- sigs + , defName <- map uniquifyName (sigNameNoLoc defSig) + ] + patSynNames = concatMap (getMainDeclBinder . fst) bundledPatSyns @@ -780,7 +807,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames (extractDecl declMap (availName avail) decl) , expItemPats = bundledPatSyns , expItemMbDoc = doc - , expItemSubDocs = subs + , expItemSubDocs = subs ++ defMethodSubs , expItemInstances = [] , expItemFixities = fixities , expItemSpliced = False @@ -907,21 +934,25 @@ hiValExportItem dflags name nLoc doc splice fixity = do Just f -> [(name, f)] Nothing -> [] +-- | Lookup docs associated with a given name +lookupDocForDecl :: Name -- ^ key + -> WarningMap -> DocMap Name -> ArgMap Name -- ^ maps + -> DocForDecl Name +lookupDocForDecl n warnings docMap argMap = (lookupDoc n, lookupArgDoc n) + where + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) + lookupArgDoc x = M.findWithDefault M.empty x argMap -- | Lookup docs for a declaration from maps. lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) lookupDocs avail warnings docMap argMap = let n = availName avail in - let lookupArgDoc x = M.findWithDefault M.empty x argMap in - let doc = (lookupDoc n, lookupArgDoc n) in - let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) + let doc = lookupDocForDecl n warnings docMap argMap in + let subDocs = [ (s, lookupDocForDecl s warnings docMap argMap) | s <- availSubordinates avail ] in (doc, subDocs) - where - lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) - -- | Export the given module as `ExportModule`. We are not concerned with the -- single export items of the given module. diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html new file mode 100644 index 0000000000..fdc7d8ff01 --- /dev/null +++ b/html-test/ref/DefaultSignatures.html @@ -0,0 +1,186 @@ +DefaultSignatures

Safe HaskellSafe

DefaultSignatures

Synopsis

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'.

\ No newline at end of file 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