From 5bc5016a14bc872a8315cddc629f8171a9ccd62e Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Tue, 21 Apr 2020 10:53:28 -0400
Subject: Fallback to `hiDecl` when `extractDecl` fails
Sometimes, the declaration being exported is a subdecl (for instance, a
record accessor getting exported at the top-level). For these cases,
Haddock has to find a way to produce some synthetic sensible top-level
declaration. This is done with `extractDecl`.
As is shown by #1067, this is sometimes impossible to do just at a
syntactic level (for instance when the subdecl is re-exported). In these
cases, the only sensible thing to do is to try to reify a declaration
based on a GHC `TyThing` via `hiDecl`.
---
haddock-api/src/Haddock/Interface/Create.hs | 114 +++++++++++++++++-----------
html-test/ref/Bug1067A.html | 114 ++++++++++++++++++++++++++++
html-test/ref/Bug1067B.html | 84 ++++++++++++++++++++
html-test/src/Bug1067A.hs | 9 +++
html-test/src/Bug1067B.hs | 4 +
5 files changed, 280 insertions(+), 45 deletions(-)
create mode 100644 html-test/ref/Bug1067A.html
create mode 100644 html-test/ref/Bug1067B.html
create mode 100644 html-test/src/Bug1067A.hs
create mode 100644 html-test/src/Bug1067B.hs
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 0f24afaa..5a58e1ac 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -793,11 +793,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> return []
+ -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
+ availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)
+ availDecl declName parentDecl =
+ case extractDecl declMap declName parentDecl of
+ Right d -> pure d
+ Left err -> do
+ synifiedDeclOpt <- hiDecl dflags declName
+ case synifiedDeclOpt of
+ Just synifiedDecl -> pure synifiedDecl
+ Nothing -> O.pprPanic "availExportItem" (O.text err)
+
availExportDecl :: AvailInfo -> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> ErrMsgGhc [ ExportItem GhcRn ]
availExportDecl avail decl (doc, subs)
| availExportsDecl avail = do
+ extractedDecl <- availDecl (availName avail) decl
+
-- bundled pattern synonyms only make sense if the declaration is
-- exported (otherwise there would be nothing to bundle to)
bundledPatSyns <- findBundledPatterns avail
@@ -813,8 +826,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
]
return [ ExportDecl {
- expItemDecl = restrictTo (fmap fst subs)
- (extractDecl declMap (availName avail) decl)
+ expItemDecl = restrictTo (fmap fst subs) extractedDecl
, expItemPats = bundledPatSyns
, expItemMbDoc = doc
, expItemSubDocs = subs
@@ -824,18 +836,18 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
}
]
- | otherwise =
- return [ ExportDecl {
- expItemDecl = extractDecl declMap sub decl
+ | otherwise = for subs $ \(sub, sub_doc) -> do
+ extractedDecl <- availDecl sub decl
+
+ return ( ExportDecl {
+ expItemDecl = extractedDecl
, expItemPats = []
, expItemMbDoc = sub_doc
, expItemSubDocs = []
, expItemInstances = []
, expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]
, expItemSpliced = False
- }
- | (sub, sub_doc) <- subs
- ]
+ } )
exportedNameSet = mkNameSet exportedNames
isExported n = elemNameSet n exportedNameSet
@@ -910,6 +922,7 @@ semToIdMod this_uid m
| Module.isHoleModule m = mkModule this_uid (moduleName m)
| otherwise = m
+-- | Reify a declaration from the GHC internal 'TyThing' representation.
hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
hiDecl dflags t = do
mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
@@ -1053,20 +1066,30 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
isSigD (L _ SigD{}) = True
isSigD _ = False
+
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn
+--
+-- This function looks through the declarations in this module to try to find
+-- the one with the right name.
+extractDecl
+ :: DeclMap -- ^ all declarations in the file
+ -> Name -- ^ name of the declaration to extract
+ -> LHsDecl GhcRn -- ^ parent declaration
+ -> Either ErrMsg (LHsDecl GhcRn)
extractDecl declMap name decl
- | name `elem` getMainDeclBinder (unLoc decl) = decl
+ | name `elem` getMainDeclBinder (unLoc decl) = pure decl
| otherwise =
case unLoc decl of
- TyClD _ d@ClassDecl {} ->
+ TyClD _ d@ClassDecl { tcdLName = L _ clsNm
+ , tcdSigs = clsSigs
+ , tcdATs = clsATs } ->
let
matchesMethod =
[ lsig
- | lsig <- tcdSigs d
+ | lsig <- clsSigs
, ClassOpSig _ False _ _ <- pure $ unLoc lsig
-- Note: exclude `default` declarations (see #505)
, name `elem` sigName lsig
@@ -1074,51 +1097,54 @@ extractDecl declMap name decl
matchesAssociatedType =
[ lfam_decl
- | lfam_decl <- tcdATs d
+ | lfam_decl <- clsATs
, name == unLoc (fdLName (unLoc lfam_decl))
]
-- TODO: document fixity
in case (matchesMethod, matchesAssociatedType) of
- ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
- L pos sig = addClassContext n tyvar_names s0
- in L pos (SigD noExtField sig)
- (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl))
+ ([s0], _) -> let tyvar_names = tyClDeclTyVars d
+ L pos sig = addClassContext clsNm tyvar_names s0
+ in pure (L pos (SigD noExtField sig))
+ (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
([], [])
| Just (famInstDecl:_) <- M.lookup name declMap
-> extractDecl declMap name famInstDecl
- _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
- O.$$ O.nest 4 (O.ppr d)
- O.$$ O.text "Matches:"
- O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
- TyClD _ d@DataDecl {} ->
- let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in if isDataConName name
- then SigD noExtField <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
- else SigD noExtField <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))
+ _ -> Left (concat [ "Ambiguous decl for ", getOccString name
+ , " in class ", getOccString clsNm ])
+
+ TyClD _ d@DataDecl { tcdLName = L _ dataNm
+ , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do
+ let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d))
+ lsig <- if isDataConName name
+ then extractPatternSyn name dataNm ty_args dataCons
+ else extractRecSel name dataNm ty_args dataCons
+ pure (SigD noExtField <$> lsig)
+
TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
- FamEqn { feqn_tycon = L _ n
- , feqn_pats = tys
- , feqn_rhs = defn }}))) ->
- if isDataConName name
- then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn)
- else SigD noExtField <$> extractRecSel name n tys (dd_cons defn)
+ FamEqn { feqn_tycon = L _ famName
+ , feqn_pats = ty_args
+ , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do
+ lsig <- if isDataConName name
+ then extractPatternSyn name famName ty_args dataCons
+ else extractRecSel name famName ty_args dataCons
+ pure (SigD noExtField <$> lsig)
InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })
| isDataConName name ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =
- FamEqn { feqn_rhs = dd
+ FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons }
}
})) <- insts
- , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))
+ , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons)
]
in case matches of
[d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))
- _ -> error "internal: extractDecl (ClsInstD)"
+ _ -> Left "internal: extractDecl (ClsInstD)"
| otherwise ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
<- insts
@@ -1130,16 +1156,14 @@ extractDecl declMap name decl
]
in case matches of
[d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)
- _ -> error "internal: extractDecl (ClsInstD)"
- _ -> O.pprPanic "extractDecl" $
- O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"
- O.$$ O.nest 4 (O.ppr decl)
+ _ -> Left "internal: extractDecl (ClsInstD)"
+ _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)
-extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
+extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)
extractPatternSyn nm t tvs cons =
case filter matches cons of
- [] -> error "extractPatternSyn: constructor pattern not found"
- con:_ -> extract <$> con
+ [] -> Left "extractPatternSyn: constructor pattern not found"
+ con:_ -> pure (extract <$> con)
where
matches :: LConDecl GhcRn -> Bool
matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
@@ -1170,13 +1194,13 @@ extractPatternSyn nm t tvs cons =
mkAppTyArg f (HsArgPar _) = HsParTy noExtField f
extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
- -> LSig GhcRn
-extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
+ -> Either ErrMsg (LSig GhcRn)
+extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getConArgs con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty)))))
+ pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/html-test/ref/Bug1067A.html b/html-test/ref/Bug1067A.html
new file mode 100644
index 00000000..96b8d495
--- /dev/null
+++ b/html-test/ref/Bug1067A.html
@@ -0,0 +1,114 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >Bug1067A</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe-Inferred</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >Bug1067A</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"
+ >data</span
+ > <a href="#"
+ >Foo</a
+ > <span class="keyword"
+ >where</span
+ ><ul class="subs"
+ ><li
+ ><span class="keyword"
+ >pattern</span
+ > <a href="#"
+ >P</a
+ > :: <a href="#" title="Bug1067A"
+ >Foo</a
+ ></li
+ ></ul
+ ></li
+ ></ul
+ ></details
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:Foo" class="def"
+ >Foo</a
+ > <span class="keyword"
+ >where</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A foo</p
+ ></div
+ ><div class="subs bundled-patterns"
+ ><p class="caption"
+ >Bundled Patterns</p
+ ><table
+ ><tr
+ ><td class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P" class="def"
+ >P</a
+ > :: <a href="#" title="Bug1067A"
+ >Foo</a
+ ></td
+ ><td class="doc"
+ ><p
+ >A pattern</p
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
diff --git a/html-test/ref/Bug1067B.html b/html-test/ref/Bug1067B.html
new file mode 100644
index 00000000..f3bf821a
--- /dev/null
+++ b/html-test/ref/Bug1067B.html
@@ -0,0 +1,84 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >Bug1067B</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe-Inferred</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >Bug1067B</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"
+ >pattern</span
+ > <a href="#"
+ >P</a
+ > :: <a href="#" title="Bug1067A"
+ >Foo</a
+ ></li
+ ></ul
+ ></details
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P" class="def"
+ >P</a
+ > :: <a href="#" title="Bug1067A"
+ >Foo</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A pattern</p
+ ></div
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
diff --git a/html-test/src/Bug1067A.hs b/html-test/src/Bug1067A.hs
new file mode 100644
index 00000000..57ab60b0
--- /dev/null
+++ b/html-test/src/Bug1067A.hs
@@ -0,0 +1,9 @@
+{-# language PatternSynonyms #-}
+module Bug1067A ( Foo(P) ) where
+
+-- | A foo
+data Foo = Foo
+
+-- | A pattern
+pattern P :: Foo
+pattern P = Foo
diff --git a/html-test/src/Bug1067B.hs b/html-test/src/Bug1067B.hs
new file mode 100644
index 00000000..f1a814df
--- /dev/null
+++ b/html-test/src/Bug1067B.hs
@@ -0,0 +1,4 @@
+{-# language PatternSynonyms #-}
+module Bug1067B ( pattern P ) where
+
+import Bug1067A
--
cgit v1.2.3