diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-01-05 16:23:02 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2021-01-05 16:23:02 -0500 |
commit | 99f61534a470b84c424fde0835215de6a3b6d721 (patch) | |
tree | 7152e5a53fe1c18e6fd5044d5aa3168ab99c3cc6 /haddock-api/src/Haddock/Interface | |
parent | 3e29ec51498dfe092b228889343dc8370ec0e64b (diff) | |
parent | 1e56f63c3197e7ca1c1e506e083c2bad25d08793 (diff) |
Merge commit '1e56f63c3197e7ca1c1e506e083c2bad25d08793' into ghc-9.0
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 5 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 180 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Json.hs | 166 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 103 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 229 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 38 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 19 |
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" |