aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2021-01-05 15:54:42 -0500
committerBen Gamari <ben@smart-cactus.org>2021-01-05 16:14:31 -0500
commit1e56f63c3197e7ca1c1e506e083c2bad25d08793 (patch)
tree7152e5a53fe1c18e6fd5044d5aa3168ab99c3cc6 /haddock-api/src/Haddock/Interface
parent1d657cf377b5f147b08aafb3ab3a5d11be538331 (diff)
parent665226f384ee9b0a66a98638ede9eff845f6c45b (diff)
Merge remote-tracking branch 'origin/ghc-8.10' into ghc-9.0
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs180
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs166
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs103
-rw-r--r--haddock-api/src/Haddock/Interface/ParseModuleHeader.hs229
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs38
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs19
7 files changed, 516 insertions, 224 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 0840bd77..6ef0ed19 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE MagicHash, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
@@ -17,11 +19,10 @@ module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import Haddock.Convert
-import Haddock.GhcUtils
import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
-import Data.List
+import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map as Map
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index dd9419eb..7fb71d4b 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -31,12 +31,13 @@ import Haddock.Interface.LexParseRn
import Data.Bifunctor
import Data.Bitraversable
import qualified Data.Map as M
+import qualified Data.Set as S
import Data.Map (Map)
-import Data.List
+import Data.List (find, foldl')
import Data.Maybe
-import Control.Applicative
import Control.Monad
import Data.Traversable
+import GHC.Stack (HasCallStack)
import GHC.Types.Avail hiding (avail)
import qualified GHC.Types.Avail as Avail
@@ -49,7 +50,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Unit.State
-import GHC.Data.Bag
import GHC.Types.Name.Reader
import GHC.Tc.Types
import GHC.Data.FastString ( unpackFS, bytesFS )
@@ -58,16 +58,21 @@ import qualified GHC.Utils.Outputable as O
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+mkExceptionContext :: TypecheckedModule -> String
+mkExceptionContext =
+ ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule
+createInterface :: HasCallStack
+ => TypecheckedModule
-> [Flag] -- Boolean flags
-> IfaceMap -- Locally processed modules
-> InstIfaceMap -- External, already installed interfaces
-> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
+createInterface tm flags modMap instIfaceMap =
+ withExceptionContext (mkExceptionContext tm) $ do
let ms = pm_mod_summary . tm_parsed_module $ tm
mi = moduleInfo tm
@@ -85,8 +90,9 @@ createInterface tm flags modMap instIfaceMap = do
(TcGblEnv { tcg_rdr_env = gre
, tcg_warns = warnings
- , tcg_exports = all_exports
+ , tcg_exports = all_exports0
}, md) = tm_internals_ tm
+ all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre
-- The 'pkgName' is necessary to decide what package to mention in "@since"
-- annotations. Not having it is not fatal though.
@@ -113,9 +119,9 @@ createInterface tm flags modMap instIfaceMap = do
let declsWithDocs = topDecls group_
exports0 = fmap (map (first unLoc)) mayExports
- exports
- | OptIgnoreExports `elem` opts = Nothing
- | otherwise = exports0
+ (all_exports, exports)
+ | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)
+ | otherwise = (all_exports0, exports0)
unrestrictedImportedMods
-- module re-exports are only possible with
@@ -127,8 +133,8 @@ createInterface tm flags modMap instIfaceMap = do
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom sem_mdl)
- $ map getName instances
- ++ map getName fam_instances
+ $ map getName fam_instances
+ ++ map getName instances
-- Locations of all TH splices
splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
@@ -165,6 +171,18 @@ createInterface tm flags modMap instIfaceMap = do
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
+ -- Prune the docstring 'Map's to keep only docstrings that are not private.
+ --
+ -- Besides all the names that GHC has told us this module exports, we also
+ -- keep the docs for locally defined class instances. This is more names than
+ -- we need, but figuring out which instances are fully private is tricky.
+ --
+ -- We do this pruning to avoid having to rename, emit warnings, and save
+ -- docstrings which will anyways never be rendered.
+ let !localVisibleNames = S.fromList (localInsts ++ exportedNames)
+ !prunedDocMap = M.restrictKeys docMap localVisibleNames
+ !prunedArgMap = M.restrictKeys argMap localVisibleNames
+
return $! Interface {
ifaceMod = mdl
, ifaceIsSig = is_sig
@@ -173,12 +191,12 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceDoc = Documentation mbDoc modWarn
, ifaceRnDoc = Documentation Nothing Nothing
, ifaceOptions = opts
- , ifaceDocMap = docMap
- , ifaceArgMap = argMap
- , ifaceRnDocMap = M.empty
- , ifaceRnArgMap = M.empty
+ , ifaceDocMap = prunedDocMap
+ , ifaceArgMap = prunedArgMap
+ , ifaceRnDocMap = M.empty -- Filled in `renameInterface`
+ , ifaceRnArgMap = M.empty -- Filled in `renameInterface`
, ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = []
+ , ifaceRnExportItems = [] -- Filled in `renameInterface`
, ifaceExports = exportedNames
, ifaceVisibleExports = visibleNames
, ifaceDeclMap = declMap
@@ -452,7 +470,8 @@ mkFixMap group_ =
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: Bool -- is it a signature
+ :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Maybe Package -- this package
-> Module -- this module
@@ -490,7 +509,7 @@ mkExportItems
return [ExportDoc doc]
lookupExport (IEDocNamed _ str, _) = liftErrMsg $
- findNamedDoc str [ unL d | d <- decls ] >>= \case
+ findNamedDoc str [ unLoc d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags pkgName gre docStr
@@ -511,7 +530,8 @@ mkExportItems
availExportItem is_sig modMap thisMod semMod warnings exportedNames
maps fixMap splices instIfaceMap dflags avail
-availExportItem :: Bool -- is it a signature
+availExportItem :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Module -- this module
-> Module -- semantic module
@@ -538,13 +558,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unL decl)
+ let declNames = getMainDeclBinder (unLoc decl)
in case () of
_
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
| t `notElem` declNames,
- Just p <- find isExported (parents t $ unL decl) ->
+ Just p <- find isExported (parents t $ unLoc decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
pretty dflags (nameOccName t) ++ " is exported separately but " ++
@@ -593,11 +613,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> return []
- availExportDecl :: AvailInfo -> LHsDecl GhcRn
+ -- 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 :: HasCallStack => 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
@@ -613,8 +646,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
@@ -624,18 +656,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
@@ -710,6 +742,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
@@ -852,20 +885,31 @@ 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
+ :: HasCallStack
+ => 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
@@ -873,51 +917,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 tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD noExtField <$> extractRecSel name n 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
@@ -929,16 +976,15 @@ 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 :: HasCallStack => 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 . O.showSDocUnsafe $
+ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t
+ con:_ -> pure (extract <$> con)
where
matches :: LConDecl GhcRn -> Bool
matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
@@ -969,13 +1015,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 (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))
+ pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 043a1530..4e271602 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -13,7 +13,6 @@ import GHC.Utils.Outputable
import Control.Arrow
import Data.Map (Map)
-import Data.Bifunctor
import qualified Data.Map as Map
import Haddock.Types
@@ -58,11 +57,172 @@ jsonMap f g = jsonObject . map (f *** g) . Map.toList
jsonMDoc :: MDoc Name -> JsonDoc
jsonMDoc MetaDoc{..} =
jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])
- , ("doc", jsonDoc _doc)
+ , ("document", jsonDoc _doc)
]
+showModName :: Wrap (ModuleName, OccName) -> String
+showModName = showWrapped (moduleNameString . fst)
+
+showName :: Wrap Name -> String
+showName = showWrapped nameStableString
+
+
jsonDoc :: Doc Name -> JsonDoc
-jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+
+jsonDoc DocEmpty = jsonObject
+ [ ("tag", jsonString "DocEmpty") ]
+
+jsonDoc (DocAppend x y) = jsonObject
+ [ ("tag", jsonString "DocAppend")
+ , ("first", jsonDoc x)
+ , ("second", jsonDoc y)
+ ]
+
+jsonDoc (DocString s) = jsonObject
+ [ ("tag", jsonString "DocString")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocParagraph x) = jsonObject
+ [ ("tag", jsonString "DocParagraph")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocIdentifier name) = jsonObject
+ [ ("tag", jsonString "DocIdentifier")
+ , ("name", jsonString (showName name))
+ ]
+
+jsonDoc (DocIdentifierUnchecked modName) = jsonObject
+ [ ("tag", jsonString "DocIdentifierUnchecked")
+ , ("modName", jsonString (showModName modName))
+ ]
+
+jsonDoc (DocModule s) = jsonObject
+ [ ("tag", jsonString "DocModule")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocWarning x) = jsonObject
+ [ ("tag", jsonString "DocWarning")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocEmphasis x) = jsonObject
+ [ ("tag", jsonString "DocEmphasis")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocMonospaced x) = jsonObject
+ [ ("tag", jsonString "DocMonospaced")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocBold x) = jsonObject
+ [ ("tag", jsonString "DocBold")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocUnorderedList xs) = jsonObject
+ [ ("tag", jsonString "DocUnorderedList")
+ , ("documents", jsonArray (fmap jsonDoc xs))
+ ]
+
+jsonDoc (DocOrderedList xs) = jsonObject
+ [ ("tag", jsonString "DocOrderedList")
+ , ("documents", jsonArray (fmap jsonDoc xs))
+ ]
+
+jsonDoc (DocDefList xys) = jsonObject
+ [ ("tag", jsonString "DocDefList")
+ , ("definitions", jsonArray (fmap jsonDef xys))
+ ]
+ where
+ jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)]
+
+jsonDoc (DocCodeBlock x) = jsonObject
+ [ ("tag", jsonString "DocCodeBlock")
+ , ("document", jsonDoc x)
+ ]
+
+jsonDoc (DocHyperlink hyperlink) = jsonObject
+ [ ("tag", jsonString "DocHyperlink")
+ , ("hyperlink", jsonHyperlink hyperlink)
+ ]
+ where
+ jsonHyperlink Hyperlink{..} = jsonObject
+ [ ("hyperlinkUrl", jsonString hyperlinkUrl)
+ , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel)
+ ]
+
+jsonDoc (DocPic picture) = jsonObject
+ [ ("tag", jsonString "DocPic")
+ , ("picture", jsonPicture picture)
+ ]
+ where
+ jsonPicture Picture{..} = jsonObject
+ [ ("pictureUrl", jsonString pictureUri)
+ , ("pictureLabel", jsonMaybe jsonString pictureTitle)
+ ]
+
+jsonDoc (DocMathInline s) = jsonObject
+ [ ("tag", jsonString "DocMathInline")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocMathDisplay s) = jsonObject
+ [ ("tag", jsonString "DocMathDisplay")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocAName s) = jsonObject
+ [ ("tag", jsonString "DocAName")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocProperty s) = jsonObject
+ [ ("tag", jsonString "DocProperty")
+ , ("string", jsonString s)
+ ]
+
+jsonDoc (DocExamples examples) = jsonObject
+ [ ("tag", jsonString "DocExamples")
+ , ("examples", jsonArray (fmap jsonExample examples))
+ ]
+ where
+ jsonExample Example{..} = jsonObject
+ [ ("exampleExpression", jsonString exampleExpression)
+ , ("exampleResult", jsonArray (fmap jsonString exampleResult))
+ ]
+
+jsonDoc (DocHeader header) = jsonObject
+ [ ("tag", jsonString "DocHeader")
+ , ("header", jsonHeader header)
+ ]
+ where
+ jsonHeader Header{..} = jsonObject
+ [ ("headerLevel", jsonInt headerLevel)
+ , ("headerTitle", jsonDoc headerTitle)
+ ]
+
+jsonDoc (DocTable table) = jsonObject
+ [ ("tag", jsonString "DocTable")
+ , ("table", jsonTable table)
+ ]
+ where
+ jsonTable Table{..} = jsonObject
+ [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows))
+ , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows))
+ ]
+
+ jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells)
+
+ jsonTableCell TableCell{..} = jsonObject
+ [ ("tableCellColspan", jsonInt tableCellColspan)
+ , ("tableCellRowspan", jsonInt tableCellRowspan)
+ , ("tableCellContents", jsonDoc tableCellContents)
+ ]
+
jsonModule :: Module -> JsonDoc
jsonModule = JSString . moduleStableString
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 2b03ecfa..d1d6bb31 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -19,10 +19,10 @@ module Haddock.Interface.LexParseRn
, processModuleHeader
) where
-import GHC.Types.Avail
import Control.Arrow
import Control.Monad
-import Data.List
+import Data.Functor (($>))
+import Data.List (maximumBy, (\\))
import Data.Ord
import Documentation.Haddock.Doc (metaDocConcat)
import GHC.Driver.Session (languageExtensions)
@@ -32,10 +32,10 @@ import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
import GHC.Types.Name
+import GHC.Parser.PostProcess
import GHC.Utils.Outputable ( showPpr, showSDoc )
import GHC.Types.Name.Reader
import GHC.Data.EnumSet as EnumSet
-import GHC.Rename.Env (dataTcOccs)
processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
@@ -89,24 +89,38 @@ processModuleHeader dflags pkgName gre safety mayStr = do
-- fallbacks in case we can't locate the identifiers.
--
-- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
+rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name)
rename dflags gre = rn
where
rn d = case d of
DocAppend a b -> DocAppend <$> rn a <*> rn b
DocParagraph doc -> DocParagraph <$> rn doc
- DocIdentifier x -> do
+ DocIdentifier i -> do
+ let NsRdrName ns x = unwrap i
+ occ = rdrNameOcc x
+ isValueName = isDataOcc occ || isVarOcc occ
+
+ let valueNsChoices | isValueName = [x]
+ | otherwise = [] -- is this ever possible?
+ typeNsChoices | isValueName = [setRdrNameSpace x tcName]
+ | otherwise = [x]
+
-- Generate the choices for the possible kind of thing this
- -- is.
- let choices = dataTcOccs x
+ -- is. We narrow down the possibilities with the namespace (if
+ -- there is one).
+ let choices = case ns of
+ Value -> valueNsChoices
+ Type -> typeNsChoices
+ None -> valueNsChoices ++ typeNsChoices
-- Lookup any GlobalRdrElts that match the choices.
case concatMap (\c -> lookupGRE_RdrName c gre) choices of
-- We found no names in the env so we start guessing.
[] ->
case choices of
- -- This shouldn't happen as 'dataTcOccs' always returns at least its input.
- [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
+ -- The only way this can happen is if a value namespace was
+ -- specified on something that cannot be a value.
+ [] -> invalidValue dflags i
-- There was nothing in the environment so we need to
-- pick some default from what's available to us. We
@@ -116,14 +130,14 @@ rename dflags gre = rn
-- type constructor names (such as in #253). So now we
-- only get type constructor links if they are actually
-- in scope.
- a:_ -> outOfScope dflags a
+ a:_ -> outOfScope dflags ns (i $> a)
-- There is only one name in the environment that matches so
-- use it.
- [a] -> pure (DocIdentifier (gre_name a))
+ [a] -> pure (DocIdentifier (i $> gre_name a))
-- There are multiple names available.
- gres -> ambiguous dflags x gres
+ gres -> ambiguous dflags i gres
DocWarning doc -> DocWarning <$> rn doc
DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -155,19 +169,25 @@ rename dflags gre = rn
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
-outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a)
-outOfScope dflags x =
- case x of
- Unqual occ -> warnAndMonospace occ
- Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))
- Orig _ occ -> warnAndMonospace occ
- Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope
+outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a)
+outOfScope dflags ns x =
+ case unwrap x of
+ Unqual occ -> warnAndMonospace (x $> occ)
+ Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
+ Orig _ occ -> warnAndMonospace (x $> occ)
+ Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope
where
+ prefix = case ns of
+ Value -> "the value "
+ Type -> "the type "
+ None -> ""
+
warnAndMonospace a = do
- tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++
+ let a' = showWrapped (showPpr dflags) a
+ tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
" If you qualify the identifier, haddock can try to link it anyway."]
- pure (monospaced a)
- monospaced a = DocMonospaced (DocString (showPpr dflags a))
+ pure (monospaced a')
+ monospaced = DocMonospaced . DocString
-- | Handle ambiguous identifiers.
--
@@ -175,26 +195,39 @@ outOfScope dflags x =
--
-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
ambiguous :: DynFlags
- -> RdrName
+ -> Wrap NsRdrName
-> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
-> ErrMsgM (Doc Name)
ambiguous dflags x gres = do
- let noChildren = map availName (gresToAvailInfo gres)
- dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
- msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
- concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
+ let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres
+ msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++
" You may be able to disambiguate the identifier by qualifying it or\n" ++
- " by hiding some imports.\n" ++
- " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+ " by specifying the type/value namespace explicitly.\n" ++
+ " Defaulting to the one defined " ++ defnLoc dflt
-- TODO: Once we have a syntax for namespace qualification (#667) we may also
-- want to emit a warning when an identifier is a data constructor for a type
-- of the same name, but not the only constructor.
-- For example, for @data D = C | D@, someone may want to reference the @D@
-- constructor.
- when (length noChildren > 1) $ tell [msg]
- pure (DocIdentifier dflt)
+ when (length (gresToAvailInfo gres) > 1) $ tell [msg]
+ pure (DocIdentifier (x $> gre_name dflt))
+ where
+ defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name
+
+-- | Handle value-namespaced names that cannot be for values.
+--
+-- Emits a warning that the value-namespace is invalid on a non-value identifier.
+invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a)
+invalidValue dflags x = do
+ tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++
+ " namespaced as such. Did you mean to specify a type namespace\n" ++
+ " instead?"]
+ pure (DocMonospaced (DocString (showNsRdrName dflags x)))
+
+-- | Printable representation of a wrapped and namespaced name
+showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
+showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
where
- isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
- isLocalName _ = False
- x_str = '\'' : showPpr dflags x ++ "'"
- defnLoc = showSDoc dflags . pprNameDefnLoc
+ ident = showWrapped (showPpr dflags . rdrName)
+ prefix = renderNs . namespace . unwrap
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
index 611d8b6f..3e464fbc 100644
--- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,4 +1,6 @@
{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE DeriveFunctor #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.ParseModuleHeader
@@ -11,12 +13,12 @@
-----------------------------------------------------------------------------
module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
-import Control.Monad (mplus)
+import Control.Applicative (Alternative (..))
+import Control.Monad (ap)
import Data.Char
import GHC.Driver.Session
import Haddock.Parser
import Haddock.Types
-import GHC.Types.Name.Reader
-- -----------------------------------------------------------------------------
-- Parsing module headers
@@ -24,37 +26,47 @@ import GHC.Types.Name.Reader
-- NB. The headers must be given in the order Module, Description,
-- Copyright, License, Maintainer, Stability, Portability, except that
-- any or all may be omitted.
-parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName)
+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)
parseModuleHeader dflags pkgName str0 =
let
- getKey :: String -> String -> (Maybe String,String)
- getKey key str = case parseKey key str of
- Nothing -> (Nothing,str)
- Just (value,rest) -> (Just value,rest)
-
- (_moduleOpt,str1) = getKey "Module" str0
- (descriptionOpt,str2) = getKey "Description" str1
- (copyrightOpt,str3) = getKey "Copyright" str2
- (licenseOpt,str4) = getKey "License" str3
- (licenceOpt,str5) = getKey "Licence" str4
- (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5
- (maintainerOpt,str7) = getKey "Maintainer" str6
- (stabilityOpt,str8) = getKey "Stability" str7
- (portabilityOpt,str9) = getKey "Portability" str8
+ kvs :: [(String, String)]
+ str1 :: String
+
+ (kvs, str1) = maybe ([], str0) id $ runP fields str0
+
+ -- trim whitespaces
+ trim :: String -> String
+ trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+ getKey :: String -> Maybe String
+ getKey key = fmap trim (lookup key kvs)
+
+ descriptionOpt = getKey "Description"
+ copyrightOpt = getKey "Copyright"
+ licenseOpt = getKey "License"
+ licenceOpt = getKey "Licence"
+ spdxLicenceOpt = getKey "SPDX-License-Identifier"
+ maintainerOpt = getKey "Maintainer"
+ stabilityOpt = getKey "Stability"
+ portabilityOpt = getKey "Portability"
in (HaddockModInfo {
hmi_description = parseString dflags <$> descriptionOpt,
hmi_copyright = copyrightOpt,
- hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt,
+ hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt,
hmi_maintainer = maintainerOpt,
hmi_stability = stabilityOpt,
hmi_portability = portabilityOpt,
hmi_safety = Nothing,
hmi_language = Nothing, -- set in LexParseRn
hmi_extensions = [] -- also set in LexParseRn
- }, parseParas dflags pkgName str9)
+ }, parseParas dflags pkgName str1)
+
+-------------------------------------------------------------------------------
+-- Small parser to parse module header.
+-------------------------------------------------------------------------------
--- | This function is how we read keys.
+-- | The below is a small parser framework how we read keys.
--
-- all fields in the header are optional and have the form
--
@@ -73,78 +85,105 @@ parseModuleHeader dflags pkgName str0 =
--
-- the value will be "this is a .. description" and the rest will begin
-- at "The module comment".
-parseKey :: String -> String -> Maybe (String,String)
-parseKey key toParse0 =
- do
- let
- (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0)
-
- indentation = spaces0
- afterKey0 <- extractPrefix key toParse1
- let
- afterKey1 = extractLeadingSpaces afterKey0
- afterColon0 <- case snd afterKey1 of
- ':':afterColon -> return afterColon
- _ -> Nothing
- let
- (_,afterColon1) = extractLeadingSpaces afterColon0
-
- return (scanKey True indentation afterColon1)
- where
- scanKey :: Bool -> String -> String -> (String,String)
- scanKey _ _ [] = ([],[])
- scanKey isFirst indentation str =
- let
- (nextLine,rest1) = extractNextLine str
-
- accept = isFirst || sufficientIndentation || allSpaces
-
- sufficientIndentation = case extractPrefix indentation nextLine of
- Just (c:_) | isSpace c -> True
- _ -> False
-
- allSpaces = case extractLeadingSpaces nextLine of
- (_,[]) -> True
- _ -> False
- in
- if accept
- then
- let
- (scanned1,rest2) = scanKey False indentation rest1
-
- scanned2 = case scanned1 of
- "" -> if allSpaces then "" else nextLine
- _ -> nextLine ++ "\n" ++ scanned1
- in
- (scanned2,rest2)
- else
- ([],str)
-
- extractLeadingSpaces :: String -> (String,String)
- extractLeadingSpaces [] = ([],[])
- extractLeadingSpaces (s@(c:cs))
- | isSpace c =
- let
- (spaces1,cs1) = extractLeadingSpaces cs
- in
- (c:spaces1,cs1)
- | otherwise = ([],s)
-
- extractNextLine :: String -> (String,String)
- extractNextLine [] = ([],[])
- extractNextLine (c:cs)
- | c == '\n' =
- ([],cs)
- | otherwise =
- let
- (line,rest) = extractNextLine cs
- in
- (c:line,rest)
-
- -- comparison is case-insensitive.
- extractPrefix :: String -> String -> Maybe String
- extractPrefix [] s = Just s
- extractPrefix _ [] = Nothing
- extractPrefix (c1:cs1) (c2:cs2)
- | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
- | otherwise = Nothing
+
+-- | 'C' is a 'Char' carrying its column.
+--
+-- This let us make an indentation-aware parser, as we know current indentation.
+-- by looking at the next character in the stream ('curInd').
+--
+-- Thus we can munch all spaces but only not-spaces which are indented.
+--
+data C = C {-# UNPACK #-} !Int Char
+
+newtype P a = P { unP :: [C] -> Maybe ([C], a) }
+ deriving Functor
+
+instance Applicative P where
+ pure x = P $ \s -> Just (s, x)
+ (<*>) = ap
+
+instance Monad P where
+ return = pure
+ m >>= k = P $ \s0 -> do
+ (s1, x) <- unP m s0
+ unP (k x) s1
+
+instance Alternative P where
+ empty = P $ \_ -> Nothing
+ a <|> b = P $ \s -> unP a s <|> unP b s
+
+runP :: P a -> String -> Maybe a
+runP p input = fmap snd (unP p input')
+ where
+ input' = concat
+ [ zipWith C [0..] l ++ [C (length l) '\n']
+ | l <- lines input
+ ]
+
+-------------------------------------------------------------------------------
+--
+-------------------------------------------------------------------------------
+
+curInd :: P Int
+curInd = P $ \s -> Just . (,) s $ case s of
+ [] -> 0
+ C i _ : _ -> i
+
+rest :: P String
+rest = P $ \cs -> Just ([], [ c | C _ c <- cs ])
+
+munch :: (Int -> Char -> Bool) -> P String
+munch p = P $ \cs ->
+ let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs)
+ where
+ p' (C i c)
+ | p i c = Just c
+ | otherwise = Nothing
+
+munch1 :: (Int -> Char -> Bool) -> P String
+munch1 p = P $ \s -> case s of
+ [] -> Nothing
+ (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs)
+ | otherwise -> Nothing
+ where
+ p' (C i c)
+ | p i c = Just c
+ | otherwise = Nothing
+
+char :: Char -> P Char
+char c = P $ \s -> case s of
+ [] -> Nothing
+ (C _ c' : cs) | c == c' -> Just (cs, c)
+ | otherwise -> Nothing
+
+skipSpaces :: P ()
+skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ())
+
+takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
+takeWhileMaybe f = go where
+ go xs0@[] = ([], xs0)
+ go xs0@(x:xs) = case f x of
+ Just y -> let (ys, zs) = go xs in (y : ys, zs)
+ Nothing -> ([], xs0)
+
+-------------------------------------------------------------------------------
+-- Fields
+-------------------------------------------------------------------------------
+
+field :: Int -> P (String, String)
+field i = do
+ fn <- munch1 $ \_ c -> isAlpha c || c == '-'
+ skipSpaces
+ _ <- char ':'
+ skipSpaces
+ val <- munch $ \j c -> isSpace c || j > i
+ return (fn, val)
+
+fields :: P ([(String, String)], String)
+fields = do
+ skipSpaces
+ i <- curInd
+ fs <- many (field i)
+ r <- rest
+ return (fs, r)
+
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 061ef8eb..bb9cd02d 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
@@ -28,13 +29,22 @@ import GHC.Builtin.Types (eqTyCon_RDR)
import Control.Applicative
import Control.Arrow ( first )
import Control.Monad hiding (mapM)
-import Data.List
+import Data.List (intercalate)
import qualified Data.Map as Map hiding ( Map )
+import qualified Data.Set as Set
import Prelude hiding (mapM)
import GHC.HsToCore.Docs
-renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
-renameInterface dflags renamingEnv warnings iface =
+-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to
+-- 'DocName'.
+--
+-- What this really boils down to is: for each 'Name', figure out which of the
+-- modules that export the name is the preferred place to link to.
+--
+-- The renamed output gets written into fields in the Haddock interface record
+-- that were previously left empty.
+renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
+renameInterface _dflags ignoredSymbols renamingEnv warnings iface =
-- first create the local env, where every name exported by this module
-- is mapped to itself, and everything else comes from the global renaming
@@ -69,8 +79,15 @@ renameInterface dflags renamingEnv warnings iface =
-- Note that since the renamed AST represents equality constraints as
-- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to
-- manually filter out 'eqTyCon_RDR' (aka @~@).
- strings = [ pretty dflags n
+
+ qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n
+
+ ignoreSet = Set.fromList ignoredSymbols
+
+ strings = [ qualifiedName n
+
| n <- missingNames
+ , not (qualifiedName n `Set.member` ignoreSet)
, not (isSystemName n)
, not (isBuiltInSyntax n)
, Exact n /= eqTyCon_RDR
@@ -82,7 +99,7 @@ renameInterface dflags renamingEnv warnings iface =
unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
tell ["Warning: " ++ moduleString (ifaceMod iface) ++
": could not find link destinations for:\n"++
- unwords (" " : strings) ]
+ intercalate "\n\t- " ("" : strings) ]
return $ iface { ifaceRnDoc = finalModuleDoc,
ifaceRnDocMap = rnDocMap,
@@ -130,6 +147,11 @@ lookupRn name = RnM $ \lkp ->
(False,maps_to) -> (maps_to, (name :))
(True, maps_to) -> (maps_to, id)
+-- | Look up a 'Name' in the renaming environment, but don't warn if you don't
+-- find the name. Prefer to use 'lookupRn' whenever possible.
+lookupRnNoWarn :: Name -> RnM DocName
+lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id)
+
-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
-- Returns the renamed value along with a list of `Name`'s that could not be
-- renamed because they weren't in the environment.
@@ -173,8 +195,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
renameLDocHsSyn = return
-renameDoc :: Traversable t => t Name -> RnM (t DocName)
-renameDoc = traverse rename
+renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
+renameDoc = traverse (traverse rename)
renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
@@ -544,7 +566,7 @@ renameSig sig = case sig of
lnames' <- mapM renameL lnames
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
MinimalSig _ src (L l s) -> do
- s' <- traverse renameL s
+ s' <- traverse (traverse lookupRnNoWarn) s
return $ MinimalSig noExtField src (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 0e9fc851..a084af90 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -3,19 +3,20 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Haddock.Interface.Specialize
( specializeInstHead
) where
+import Haddock.GhcUtils ( hsTyVarBndrName )
import Haddock.Syb
import Haddock.Types
import GHC
import GHC.Types.Name
import GHC.Data.FastString
-import GHC.Builtin.Types.Prim ( funTyConName )
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
@@ -57,13 +58,9 @@ specialize specs = go spec_map0
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
-specializeTyVarBndrs bndrs typs =
- specialize $ zip bndrs' typs
+specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs
where
- bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
- bname (UserTyVar _ _ (L _ name)) = name
- bname (KindedTyVar _ _ (L _ name) _) = name
- bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
+ bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs
@@ -217,7 +214,7 @@ freeVariables =
teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
- bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
+ bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)
-- | Make given type visually unambiguous.
@@ -365,9 +362,3 @@ alternativeNames name =
located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
-
-
-tyVarName :: HsTyVarBndr flag name -> IdP name
-tyVarName (UserTyVar _ _ name) = unLoc name
-tyVarName (KindedTyVar _ _ (L _ name) _) = name
-tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"