From 2cf2953dcbce2ddb91bd016f92c80c33609c33ae Mon Sep 17 00:00:00 2001 From: mac-adder Date: Thu, 12 Oct 2017 14:12:06 +0200 Subject: [PATCH 01/15] Add better support for default signatures in class definitions --- .../src/Haddock/Backends/Xhtml/Decl.hs | 46 ++++++++++++++----- .../src/Haddock/Backends/Xhtml/Layout.hs | 4 ++ haddock-api/src/Haddock/GhcUtils.hs | 13 +++++- haddock-api/src/Haddock/Interface/Create.hs | 19 +++++++- 4 files changed, 67 insertions(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c78bee2d5e..5b2d44fe90 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -29,6 +29,7 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) +import Control.Applicative (liftA2) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -63,14 +64,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 +185,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 +469,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 +517,38 @@ 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' + ] + + parseMethodName def = liftA2 setName (uniquifyClassSig def . getName) id . unLoc + + 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 (parseMethodName False) 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 (parseMethodName True) 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..9c7d6230f4 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,20 @@ isConSym :: OccName -> Bool isConSym = isLexConSym . occNameFS -getMainDeclBinder :: HsDecl name -> [name] +uniquifyClassSig :: (NamedThing name, SetName name) => Bool -> name -> name +uniquifyClassSig False = id +uniquifyClassSig _ = liftA2 setName (updateName . getName) id + where + updateName = liftA2 setNameUnique id $ + liftA2 deriveUnique id ((+1) . getKey) . nameUnique + +getMainDeclBinder :: (NamedThing name, SetName name) => HsDecl name -> [name] getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of [] -> [] (name:_) -> [name] +getMainDeclBinder (SigD d@(ClassOpSig def _ _)) = uniquifyClassSig def <$> sigNameNoLoc d getMainDeclBinder (SigD d) = sigNameNoLoc d getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 87cdb01f5f..1a376ff1ef 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -137,11 +137,13 @@ createInterface tm flags modMap instIfaceMap = do maps@(!docMap, !argMap, !subMap, !declMap, _) <- liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) + let exportedNames' = exportedNames ++ additionalExportedNames exportedNames decls + 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 +182,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 +198,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 = uniquifyClassSig True 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 From 6ab9931622f8aef34f457b76dd0ac38a9a89776b Mon Sep 17 00:00:00 2001 From: mac-adder Date: Fri, 13 Oct 2017 10:19:41 +0200 Subject: [PATCH 02/15] Clean up and comment the changes for default signatures support --- .../src/Haddock/Backends/Xhtml/Decl.hs | 6 ++---- haddock-api/src/Haddock/GhcUtils.hs | 19 +++++++++++-------- haddock-api/src/Haddock/Interface/Create.hs | 4 +++- 3 files changed, 16 insertions(+), 13 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5b2d44fe90..2a25bc5276 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -522,8 +522,6 @@ ppClassDecl summary links instances fixities loc d subdocs , n == n' ] - parseMethodName def = liftA2 setName (uniquifyClassSig def . getName) id . unLoc - ppDefaultFunSig (names', typ', doc') = ppFunSig summary links loc (keyword "default") doc' names' (hsSigType typ') [] splice unicode qual @@ -532,7 +530,7 @@ ppClassDecl summary links instances fixities loc d subdocs <+> subDefaults defaultsSigs | L _ (ClassOpSig False lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs - names = map (parseMethodName False) lnames + names = map unLoc lnames subfixs = namesFixities names nameStrs = getOccString . getName <$> names defaults = flip Map.lookup defaultMethods <$> nameStrs @@ -544,7 +542,7 @@ ppClassDecl summary links instances fixities loc d subdocs defaultMethods = Map.fromList [ (nameStr, (names, typ, doc)) | L _ (ClassOpSig True lnames typ) <- lsigs - , let names = map (parseMethodName True) lnames + , let names = map (uniquifyName . unLoc) lnames nameStr = getOccString $ getName $ head names doc = lookupAnySubdoc (head names) subdocs ] diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 9c7d6230f4..792fd77636 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -46,20 +46,15 @@ isConSym :: OccName -> Bool isConSym = isLexConSym . occNameFS -uniquifyClassSig :: (NamedThing name, SetName name) => Bool -> name -> name -uniquifyClassSig False = id -uniquifyClassSig _ = liftA2 setName (updateName . getName) id - where - updateName = liftA2 setNameUnique id $ - liftA2 deriveUnique id ((+1) . getKey) . nameUnique - getMainDeclBinder :: (NamedThing name, SetName name) => HsDecl name -> [name] getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinder (SigD d@(ClassOpSig def _ _)) = uniquifyClassSig def <$> sigNameNoLoc d +-- 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 _ _ _ _)) = [] @@ -122,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 1a376ff1ef..3f7d80ba1a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -137,6 +137,8 @@ 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 exportedNames' = exportedNames ++ additionalExportedNames exportedNames decls let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) @@ -207,7 +209,7 @@ additionalExportedNames exportedNames = foldMap go , name <- ns , let name' = unLoc name , name' `elem` exportedNames - , let defName = uniquifyClassSig True name' + , let defName = uniquifyName name' ] go _ = [] From 9029b8a96f7fc5770e0ba66abc9cbce65ab8bc0e Mon Sep 17 00:00:00 2001 From: mac-adder Date: Fri, 13 Oct 2017 10:31:41 +0200 Subject: [PATCH 03/15] Remove unnecessary import --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2a25bc5276..58be3f991c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -29,7 +29,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative (liftA2) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe From 79bf3ea6752c5fc60ac4aaa302b65e00c6ff7e89 Mon Sep 17 00:00:00 2001 From: mac-adder Date: Mon, 16 Oct 2017 14:53:05 +0200 Subject: [PATCH 04/15] Fix default signatures support for reexports --- haddock-api/src/Haddock/Interface/Create.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 3f7d80ba1a..3735fa05a0 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -139,7 +139,8 @@ createInterface tm flags modMap instIfaceMap = do -- Also export uniquified default signatures that correspond to -- exported base method signatures. - let exportedNames' = exportedNames ++ additionalExportedNames exportedNames decls + let allDecls = decls ++ concat (foldMap ifaceDeclMap modMap) + exportedNames' = exportedNames ++ additionalExportedNames exportedNames allDecls let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) From fefcf8862786cbd53ebf48c5ca226f313d26a7f0 Mon Sep 17 00:00:00 2001 From: mac-adder Date: Mon, 16 Oct 2017 15:49:50 +0200 Subject: [PATCH 05/15] Add new test for default signatures --- html-test/ref/DefaultSignatures.html | 172 +++++++++++++++++++++++++++ html-test/src/DefaultSignatures.hs | 19 +++ 2 files changed, 191 insertions(+) create mode 100644 html-test/ref/DefaultSignatures.html create mode 100644 html-test/src/DefaultSignatures.hs 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 From 50a37cc1c01c9654816ebccbc9ad5395e2f01db4 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 9 May 2018 12:46:53 -0400 Subject: [PATCH 06/15] Post-rebase sludge --- .../src/Haddock/Backends/Xhtml/Decl.hs | 21 +++-- html-test/ref/DefaultSignatures.html | 86 ++++++++----------- 2 files changed, 47 insertions(+), 60 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d408a826a2..bc0a889be4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -523,24 +523,23 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - namesFixities names = [ f | n <- names - , f@(n', _) <- fixities - , n == n' - ] + namesFixities name = [ f | f@(n', _) <- fixities + , name == n' ] ppDefaultFunSig (names', typ', doc') = ppFunSig summary links loc (keyword "default") doc' names' (hsSigType typ') [] splice unicode pkg qual - methodBit = subMethods [ ppFunSig summary links loc mempty doc names (hsSigType typ) + methodBit = subMethods [ ppFunSig summary links loc mempty doc [name] (hsSigType typ) subfixs splice unicode pkg qual - <+> subDefaults defaultsSigs + <+> subDefaults defaultSig | L _ (ClassOpSig False lnames typ) <- lsigs + , let names = map unLoc lnames + , name <- names , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames - subfixs = namesFixities names - nameStrs = getOccString . getName <$> names - defaults = flip Map.lookup defaultMethods <$> nameStrs - defaultsSigs = ppDefaultFunSig <$> catMaybes defaults + 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. diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html index fe9b49b067..0a43138e40 100644 --- a/html-test/ref/DefaultSignatures.html +++ b/html-test/ref/DefaultSignatures.html @@ -78,7 +78,7 @@ >

    Minimal complete definition

    baz

    bar :: a -> String :: a -> String #

    Documentation for bar and baz.

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

    Documentation for the default signature of bar.

    baz :: a -> String :: a -> String #

    Documentation for bar and baz.

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

    baz' :: String -> a :: String -> a #

    Documentation for baz'.

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

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

    Documentation for the default signature of baz'.

    Documentation for baz'.

    +> \ No newline at end of file From ec0a8ba29255d8deeb1f5c53dcb77f6dfb717fcf Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 9 May 2018 14:49:50 -0400 Subject: [PATCH 07/15] Cleanup --- .../src/Haddock/Backends/Xhtml/Decl.hs | 14 ++--- haddock-api/src/Haddock/GhcUtils.hs | 2 +- html-test/ref/DefaultSignatures.html | 56 ++++++++++--------- 3 files changed, 38 insertions(+), 34 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index bc0a889be4..98751f3b90 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -526,8 +526,8 @@ ppClassDecl summary links instances fixities loc d subdocs namesFixities name = [ f | f@(n', _) <- fixities , name == n' ] - ppDefaultFunSig (names', typ', doc') = ppFunSig summary links loc - (keyword "default") doc' names' (hsSigType typ') [] splice unicode pkg qual + 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 @@ -535,7 +535,7 @@ ppClassDecl summary links instances fixities loc d subdocs | L _ (ClassOpSig False lnames typ) <- lsigs , let names = map unLoc lnames , name <- names - , let doc = lookupAnySubdoc (head names) subdocs + , let doc = lookupAnySubdoc name subdocs subfixs = namesFixities name nameStr = getOccString $ getName name default_ = Map.lookup nameStr defaultMethods @@ -545,11 +545,11 @@ ppClassDecl summary links instances fixities loc d subdocs -- are expanded so that each name gets its own signature. defaultMethods = Map.fromList - [ (nameStr, (names, typ, doc)) + [ (nameStr, (name, typ, doc)) | L _ (ClassOpSig True lnames typ) <- lsigs - , let names = map (uniquifyName . unLoc) lnames - nameStr = getOccString $ getName $ head names - doc = lookupAnySubdoc (head names) subdocs + , name <- map (uniquifyName . unLoc ) lnames + , let nameStr = getOccString $ getName name + doc = lookupAnySubdoc name subdocs ] minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index a4229de874..1ac13f20b2 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -119,7 +119,7 @@ sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns sigNameNoLoc _ = [] -uniquifyName :: (NamedThing name, SetName name) => name -> name +uniquifyName :: SetName name => name -> name uniquifyName = liftA2 setName (updateName . getName) id where updateName = liftA2 setNameUnique id $ diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html index 0a43138e40..0d36dec02f 100644 --- a/html-test/ref/DefaultSignatures.html +++ b/html-test/ref/DefaultSignatures.html @@ -97,6 +97,22 @@ >

    Documentation for bar and baz.

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

    bazDocumentation for bar and baz.

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

    Documentation for bar and baz.

    baz' ::

    Documentation for baz'.

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

    Documentation for baz'.

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

    Date: Thu, 12 Oct 2017 14:12:06 +0200 Subject: [PATCH 08/15] Add better support for default signatures in class definitions --- .../src/Haddock/Backends/Xhtml/Decl.hs | 48 ++++++++++++++----- .../src/Haddock/Backends/Xhtml/Layout.hs | 4 ++ haddock-api/src/Haddock/GhcUtils.hs | 11 +++++ haddock-api/src/Haddock/Interface/Create.hs | 22 +++++++-- 4 files changed, 68 insertions(+), 17 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 1daf9ace27..4688c7230d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -29,6 +29,7 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) +import Control.Applicative (liftA2) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -64,14 +65,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,8 +189,8 @@ 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 -ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" + = ppFunSig summary links loc mempty doc [name] (hsSigType typ) fixities splice unicode pkg qual +ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now @@ -475,7 +476,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 +524,38 @@ 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 names = [ f | n <- names + , f@(n', _) <- fixities + , n == n' + ] + + parseMethodName def = liftA2 setName (uniquifyClassSig def . getName) id . unLoc + + 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 pkg qual - | L _ (ClassOpSig _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] + <+> subDefaults defaultsSigs + | L _ (ClassOpSig False lnames typ) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map (parseMethodName False) 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 (parseMethodName True) 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 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..94ab20a81c 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,20 @@ isConSym :: OccName -> Bool isConSym = isLexConSym . occNameFS +uniquifyClassSig :: (NamedThing name, SetName name) => Bool -> name -> name +uniquifyClassSig False = id +uniquifyClassSig _ = liftA2 setName (updateName . getName) id + where + updateName = liftA2 setNameUnique id $ + liftA2 deriveUnique id ((+1) . getKey) . nameUnique + getMainDeclBinder :: HsDecl name -> [IdP name] getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of [] -> [] (name:_) -> [name] +getMainDeclBinder (SigD d@(ClassOpSig def _ _)) = uniquifyClassSig def <$> sigNameNoLoc d getMainDeclBinder (SigD d) = sigNameNoLoc d getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index a35e20530f..6d561864de 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -142,13 +142,15 @@ createInterface tm flags modMap instIfaceMap = do maps@(!docMap, !argMap, !declMap, _) <- liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) + let exportedNames' = exportedNames ++ additionalExportedNames exportedNames decls + 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 - splices exports all_exports instIfaceMap dflags + exportItems <- mkExportItems is_sig modMappkgName mdl sem_mdl allWarnings gre + exportedNames' decls maps fixMap unrestrictedImportedMods splices + exports all_exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -186,7 +188,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 +202,18 @@ 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 = uniquifyClassSig True 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 From 7c8a6bb886c93f9f138ef83f5266f30e34650d2d Mon Sep 17 00:00:00 2001 From: mac-adder Date: Fri, 13 Oct 2017 10:19:41 +0200 Subject: [PATCH 09/15] Clean up and comment the changes for default signatures support --- haddock-api/src/Haddock/Backends/Xhtml.hs | 4 ++-- .../src/Haddock/Backends/Xhtml/Decl.hs | 10 ++++---- haddock-api/src/Haddock/GhcUtils.hs | 23 +++++++++++-------- haddock-api/src/Haddock/Interface/Create.hs | 8 ++++--- 4 files changed, 24 insertions(+), 21 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index c9a262a456..20b5b62486 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, NamedFieldPuns, FlexibleContexts #-} 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 4688c7230d..70e02ddcb7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -190,7 +190,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode pkg qual = ppFunSig summary links loc mempty doc [name] (hsSigType typ) fixities splice unicode pkg qual -ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" +ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now @@ -529,17 +529,15 @@ ppClassDecl summary links instances fixities loc d subdocs , n == n' ] - parseMethodName def = liftA2 setName (uniquifyClassSig def . getName) id . unLoc - ppDefaultFunSig (names', typ', doc') = ppFunSig summary links loc - (keyword "default") doc' names' (hsSigType typ') [] splice unicode qual + (keyword "default") doc' names' (hsSigType typ') [] splice unicode pkg qual methodBit = subMethods [ ppFunSig summary links loc mempty doc names (hsSigType typ) subfixs splice unicode pkg qual <+> subDefaults defaultsSigs | L _ (ClassOpSig False lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs - names = map (parseMethodName False) lnames + names = map unLoc lnames subfixs = namesFixities names nameStrs = getOccString . getName <$> names defaults = flip Map.lookup defaultMethods <$> nameStrs @@ -551,7 +549,7 @@ ppClassDecl summary links instances fixities loc d subdocs defaultMethods = Map.fromList [ (nameStr, (names, typ, doc)) | L _ (ClassOpSig True lnames typ) <- lsigs - , let names = map (parseMethodName True) lnames + , let names = map (uniquifyName . unLoc) lnames nameStr = getOccString $ getName $ head names doc = lookupAnySubdoc (head names) subdocs ] diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 94ab20a81c..67cf5417de 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 #-} ----------------------------------------------------------------------------- @@ -46,20 +46,15 @@ isConSym :: OccName -> Bool isConSym = isLexConSym . occNameFS -uniquifyClassSig :: (NamedThing name, SetName name) => Bool -> name -> name -uniquifyClassSig False = id -uniquifyClassSig _ = liftA2 setName (updateName . getName) id - where - updateName = liftA2 setNameUnique id $ - liftA2 deriveUnique id ((+1) . getKey) . nameUnique - -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] -getMainDeclBinder (SigD d@(ClassOpSig def _ _)) = uniquifyClassSig def <$> sigNameNoLoc d +-- 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 _ _ _ _)) = [] @@ -123,6 +118,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 6d561864de..eb2c685afb 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -142,13 +142,15 @@ 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 exportedNames' = exportedNames ++ additionalExportedNames exportedNames decls 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 modMappkgName mdl sem_mdl allWarnings gre + exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre exportedNames' decls maps fixMap unrestrictedImportedMods splices exports all_exports instIfaceMap dflags @@ -202,7 +204,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceTokenizedSrc = tokenizedSrc } -additionalExportedNames :: [Name] -> [LHsDecl Name] -> [Name] +additionalExportedNames :: [Name] -> [LHsDecl GhcRn] -> [Name] additionalExportedNames exportedNames = foldMap go where go (L _ (TyClD d)) | isClassDecl d = @@ -211,7 +213,7 @@ additionalExportedNames exportedNames = foldMap go , name <- ns , let name' = unLoc name , name' `elem` exportedNames - , let defName = uniquifyClassSig True name' + , let defName = uniquifyName name' ] go _ = [] From 657dc17bafc08fe67b147a2f8de6acefbc2587d0 Mon Sep 17 00:00:00 2001 From: mac-adder Date: Fri, 13 Oct 2017 10:31:41 +0200 Subject: [PATCH 10/15] Remove unnecessary import --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 70e02ddcb7..bfb939cf6d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -29,7 +29,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative (liftA2) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe From ccb8d01d38cbf1e89f7412e588087e89df395842 Mon Sep 17 00:00:00 2001 From: mac-adder Date: Mon, 16 Oct 2017 14:53:05 +0200 Subject: [PATCH 11/15] Fix default signatures support for reexports --- haddock-api/src/Haddock/Interface/Create.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index eb2c685afb..a24ff2b4a6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -144,7 +144,8 @@ createInterface tm flags modMap instIfaceMap = do -- Also export uniquified default signatures that correspond to -- exported base method signatures. - let exportedNames' = exportedNames ++ additionalExportedNames exportedNames decls + let allDecls = decls ++ concat (foldMap ifaceDeclMap modMap) + exportedNames' = exportedNames ++ additionalExportedNames exportedNames allDecls let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) From 02a0b1e535349d5b5b6c01057f07f948ad6edf57 Mon Sep 17 00:00:00 2001 From: mac-adder Date: Mon, 16 Oct 2017 15:49:50 +0200 Subject: [PATCH 12/15] Add new test for default signatures --- html-test/ref/DefaultSignatures.html | 172 +++++++++++++++++++++++++++ html-test/src/DefaultSignatures.hs | 19 +++ 2 files changed, 191 insertions(+) create mode 100644 html-test/ref/DefaultSignatures.html create mode 100644 html-test/src/DefaultSignatures.hs 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 From 76fb0925baa787b6920cb6031ba5d45b57ff53c3 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 9 May 2018 12:46:53 -0400 Subject: [PATCH 13/15] Post-rebase sludge --- .../src/Haddock/Backends/Xhtml/Decl.hs | 21 +++-- html-test/ref/DefaultSignatures.html | 86 ++++++++----------- 2 files changed, 47 insertions(+), 60 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index bfb939cf6d..899b26c535 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -523,24 +523,23 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - namesFixities names = [ f | n <- names - , f@(n', _) <- fixities - , n == n' - ] + namesFixities name = [ f | f@(n', _) <- fixities + , name == n' ] ppDefaultFunSig (names', typ', doc') = ppFunSig summary links loc (keyword "default") doc' names' (hsSigType typ') [] splice unicode pkg qual - methodBit = subMethods [ ppFunSig summary links loc mempty doc names (hsSigType typ) + methodBit = subMethods [ ppFunSig summary links loc mempty doc [name] (hsSigType typ) subfixs splice unicode pkg qual - <+> subDefaults defaultsSigs + <+> subDefaults defaultSig | L _ (ClassOpSig False lnames typ) <- lsigs + , let names = map unLoc lnames + , name <- names , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames - subfixs = namesFixities names - nameStrs = getOccString . getName <$> names - defaults = flip Map.lookup defaultMethods <$> nameStrs - defaultsSigs = ppDefaultFunSig <$> catMaybes defaults + 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. diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html index fe9b49b067..0a43138e40 100644 --- a/html-test/ref/DefaultSignatures.html +++ b/html-test/ref/DefaultSignatures.html @@ -78,7 +78,7 @@ >

      Minimal complete definition

      baz

      bar :: a -> String :: a -> String #

      Documentation for bar and baz.

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

      Documentation for the default signature of bar.

      baz :: a -> String :: a -> String #

      Documentation for bar and baz.

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

      baz' :: String -> a :: String -> a #

      Documentation for baz'.

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

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

      Documentation for the default signature of baz'.

      Documentation for baz'.

      +> \ No newline at end of file From a976c95c227dd80f509851bf3e8d8745cc6fb985 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 9 May 2018 14:49:50 -0400 Subject: [PATCH 14/15] Cleanup --- .../src/Haddock/Backends/Xhtml/Decl.hs | 14 ++--- haddock-api/src/Haddock/GhcUtils.hs | 2 +- html-test/ref/DefaultSignatures.html | 56 ++++++++++--------- 3 files changed, 38 insertions(+), 34 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 899b26c535..0df74730b4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -526,8 +526,8 @@ ppClassDecl summary links instances fixities loc d subdocs namesFixities name = [ f | f@(n', _) <- fixities , name == n' ] - ppDefaultFunSig (names', typ', doc') = ppFunSig summary links loc - (keyword "default") doc' names' (hsSigType typ') [] splice unicode pkg qual + 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 @@ -535,7 +535,7 @@ ppClassDecl summary links instances fixities loc d subdocs | L _ (ClassOpSig False lnames typ) <- lsigs , let names = map unLoc lnames , name <- names - , let doc = lookupAnySubdoc (head names) subdocs + , let doc = lookupAnySubdoc name subdocs subfixs = namesFixities name nameStr = getOccString $ getName name default_ = Map.lookup nameStr defaultMethods @@ -545,11 +545,11 @@ ppClassDecl summary links instances fixities loc d subdocs -- are expanded so that each name gets its own signature. defaultMethods = Map.fromList - [ (nameStr, (names, typ, doc)) + [ (nameStr, (name, typ, doc)) | L _ (ClassOpSig True lnames typ) <- lsigs - , let names = map (uniquifyName . unLoc) lnames - nameStr = getOccString $ getName $ head names - doc = lookupAnySubdoc (head names) subdocs + , name <- map (uniquifyName . unLoc ) lnames + , let nameStr = getOccString $ getName name + doc = lookupAnySubdoc name subdocs ] minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 67cf5417de..54f17b9f74 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -119,7 +119,7 @@ sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns sigNameNoLoc _ = [] -uniquifyName :: (NamedThing name, SetName name) => name -> name +uniquifyName :: SetName name => name -> name uniquifyName = liftA2 setName (updateName . getName) id where updateName = liftA2 setNameUnique id $ diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html index 0a43138e40..0d36dec02f 100644 --- a/html-test/ref/DefaultSignatures.html +++ b/html-test/ref/DefaultSignatures.html @@ -97,6 +97,22 @@ >

      Documentation for bar and baz.

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

      bazDocumentation for bar and baz.

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

      Documentation for bar and baz.

      baz' ::

      Documentation for baz'.

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

      Documentation for baz'.

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

      Date: Tue, 3 Jul 2018 20:03:31 -0400 Subject: [PATCH 15/15] Manually prod default-sig subdocs into ExportDecl This solves the problem of docs, which are associated with default method signatures, not finding their way into the right 'ExportDecl' and consequently not being available in 'ppClassDecl'. The crux of this issue is that since we are keying the docs for default methods under another name, we need to manually look these up and make sure they still end up in the right 'ExportDecl'. --- haddock-api/src/Haddock/Interface/Create.hs | 28 +++++++++++++++------ html-test/ref/DefaultSignatures.html | 8 ++++++ 2 files changed, 29 insertions(+), 7 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c2cab964f9..64e4d39892 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -783,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 @@ -797,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 @@ -924,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 index 7a2c73123a..fdc7d8ff01 100644 --- a/html-test/ref/DefaultSignatures.html +++ b/html-test/ref/DefaultSignatures.html @@ -126,6 +126,10 @@ > #

      Documentation for the default signature of bar.

      -> a #

      Documentation for the default signature of baz'.