Skip to content
This repository was archived by the owner on Aug 3, 2024. It is now read-only.

Add better support for default signatures in class definitions #822

Closed
wants to merge 17 commits into from
Closed
Show file tree
Hide file tree
Changes from 16 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 2 additions & 2 deletions haddock-api/src/Haddock/Backends/Xhtml.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
{-# LANGUAGE CPP, NamedFieldPuns #-}
{-# LANGUAGE CPP, FlexibleContexts, NamedFieldPuns #-}
module Haddock.Backends.Xhtml (
ppHtml, copyHtmlBits,
ppHtmlIndex, ppHtmlContents,
Expand Down Expand Up @@ -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 _ = []
Expand Down
40 changes: 29 additions & 11 deletions haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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"


Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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] ==
Expand Down
4 changes: 4 additions & 0 deletions haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout (
subInstances, subOrphanInstances,
subInstHead, subInstDetails, subFamInstDetails,
subMethods,
subDefaults,
subMinimal,

topDeclElem, declElem,
Expand Down Expand Up @@ -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

Expand Down
18 changes: 16 additions & 2 deletions haddock-api/src/Haddock/GhcUtils.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE BangPatterns, FlexibleInstances, FlexibleContexts, ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
Expand All @@ -16,6 +16,7 @@
module Haddock.GhcUtils where


import Control.Applicative (liftA2)
import Control.Arrow

import Exception
Expand All @@ -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
Expand All @@ -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 _ _ _ _)) = []
Expand Down Expand Up @@ -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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is a bit suspicious. That said, I think the smell is coming more from the fact that deriveUnique exists... and I don't see another easy workaround.



-- | Was this signature given by the user?
isUserLSig :: LSig name -> Bool
isUserLSig (L _(TypeSig {})) = True
Expand Down
21 changes: 19 additions & 2 deletions haddock-api/src/Haddock/Interface/Create.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
178 changes: 178 additions & 0 deletions html-test/ref/DefaultSignatures.html
Original file line number Diff line number Diff line change
@@ -0,0 +1,178 @@
<html xmlns="http://www.w3.org/1999/xhtml"
><head
><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
/><title
>DefaultSignatures</title
><link href="#" rel="stylesheet" type="text/css" title="Ocean"
/><link rel="stylesheet" type="text/css" href="#"
/><script src="haddock-bundle.min.js" async="async" type="text/javascript"
></script
><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
></script
></head
><body
><div id="package-header"
><ul class="links" id="page-menu"
><li
><a href="#"
>Contents</a
></li
><li
><a href="#"
>Index</a
></li
></ul
><p class="caption empty"
></p
></div
><div id="content"
><div id="module-header"
><table class="info"
><tr
><th
>Safe Haskell</th
><td
>Safe</td
></tr
></table
><p class="caption"
>DefaultSignatures</p
></div
><div id="synopsis"
><details id="syn"
><summary
>Synopsis</summary
><ul class="details-toggle" data-details-id="syn"
><li class="src short"
><span class="keyword"
>class</span
> <a href="#"
>Foo</a
> a <span class="keyword"
>where</span
><ul class="subs"
><li
><a href="#"
>bar</a
>, <a href="#"
>baz</a
> :: a -&gt; <a href="#" title="Data.String"
>String</a
></li
><li
><a href="#"
>baz'</a
> :: <a href="#" title="Data.String"
>String</a
> -&gt; a</li
></ul
></li
></ul
></details
></div
><div id="interface"
><h1
>Documentation</h1
><div class="top"
><p class="src"
><span class="keyword"
>class</span
> <a id="t:Foo" class="def"
>Foo</a
> a <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
></p
><div class="doc"
><p
>Documentation for Foo.</p
></div
><div class="subs minimal"
><p class="caption"
>Minimal complete definition</p
><p class="src"
><a href="#" title="DefaultSignatures"
>baz</a
></p
></div
><div class="subs methods"
><p class="caption"
>Methods</p
><p class="src"
><a id="v:bar" class="def"
>bar</a
> :: a -&gt; <a href="#" title="Data.String"
>String</a
> <a href="#" class="selflink"
>#</a
></p
><div class="doc"
><p
>Documentation for bar and baz.</p
></div
> <div class="subs default"
><p class="caption"
></p
><p class="src"
><span class="keyword"
>default</span
> <a id="v:bar" class="def"
>bar</a
> :: <a href="#" title="Text.Show"
>Show</a
> a =&gt; a -&gt; <a href="#" title="Data.String"
>String</a
> <a href="#" class="selflink"
>#</a
></p
></div
><p class="src"
><a id="v:baz" class="def"
>baz</a
> :: a -&gt; <a href="#" title="Data.String"
>String</a
> <a href="#" class="selflink"
>#</a
></p
><div class="doc"
><p
>Documentation for bar and baz.</p
></div
><p class="src"
><a id="v:baz-39-" class="def"
>baz'</a
> :: <a href="#" title="Data.String"
>String</a
> -&gt; a <a href="#" class="selflink"
>#</a
></p
><div class="doc"
><p
>Documentation for baz'.</p
></div
> <div class="subs default"
><p class="caption"
></p
><p class="src"
><span class="keyword"
>default</span
> <a id="v:baz-39-" class="def"
>baz'</a
> :: <a href="#" title="Text.Read"
>Read</a
> a =&gt; <a href="#" title="Data.String"
>String</a
> -&gt; a <a href="#" class="selflink"
>#</a
></p
></div
></div
></div
></div
></div
><div id="footer"
></div
></body
></html
>
Loading