From 2cf2953dcbce2ddb91bd016f92c80c33609c33ae Mon Sep 17 00:00:00 2001 From: mac-adder Date: Thu, 12 Oct 2017 14:12:06 +0200 Subject: [PATCH 1/5] 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 2/5] 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 3/5] 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 4/5] 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 5/5] 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