diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 126 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 12 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 28 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 22 |
5 files changed, 111 insertions, 81 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index cc9569af..4527360f 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -135,12 +135,12 @@ attachToExportItem index expInfo getInstDoc getFixity export = , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ - [ (n',f) | n <- getMainDeclBinder d + [ (n',f) | n <- getMainDeclBinder emptyOccEnv d , n' <- n : (map fst subDocs ++ patsyn_names) , f <- maybeToList (getFixity n') ] } where - patsyn_names = concatMap (getMainDeclBinder . fst) patsyns + patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 17b9f367..b832128f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -34,7 +34,7 @@ import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl) import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents, pretty, restrictTo, sigName, unL) -import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader) +import Haddock.Interface.LexParseRn import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace) @@ -56,7 +56,7 @@ import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) import GHC.Data.FastString (bytesFS, unpackFS) import GHC.Driver.Ppr (showSDoc) -import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) import GHC.IORef (readIORef) import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) @@ -64,12 +64,13 @@ import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import GHC.Types.Basic (PromotionFlag (..)) -import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName) +import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv) import GHC.Types.Name.Env (lookupNameEnv) import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet) import GHC.Types.SourceFile (HscSource (..)) import GHC.Types.SourceText (SourceText (..), sl_fs) +import GHC.Unit.Types import qualified GHC.Types.SrcLoc as SrcLoc import qualified GHC.Unit.Module as Module import GHC.Unit.Module.ModSummary (msHsFilePath) @@ -77,6 +78,7 @@ import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic (pprPanic) import GHC.Unit.Module.Warnings +import GHC.Types.Unique.Map newtype IfEnv m = IfEnv { @@ -253,7 +255,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do -- Process the top-level module header documentation. (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name - tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr)) + tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr)) -- Warnings on declarations in this module decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) @@ -347,8 +349,7 @@ mkAliasMap state impDecls = -- them to the user. We should reuse that information; -- or at least reuse the renamed imports, which know what -- they import! - (fmap Module.fsToUnit $ - fmap sl_fs $ ideclPkgQual impDecl) + (ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -391,11 +392,11 @@ unrestrictedModuleImports idecls = -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: - UnitState -> Maybe Unit -> ModuleName -> Module -lookupModuleDyn _ (Just pkgId) mdlName = - Module.mkModule pkgId mdlName -lookupModuleDyn state Nothing mdlName = - case lookupModuleInAllUnits state mdlName of + UnitState -> PkgQual -> ModuleName -> Module +lookupModuleDyn state pkg_qual mdlName = case pkg_qual of + OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName + ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName + NoPkgQual -> case lookupModuleInAllUnits state mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainUnit mdlName @@ -404,7 +405,7 @@ lookupModuleDyn state Nothing mdlName = -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap +mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> pure M.empty WarnAll _ -> pure M.empty @@ -415,18 +416,18 @@ mkWarningMap dflags warnings gre exps = case warnings of , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name)) moduleWarning _ _ NoWarnings = pure Nothing moduleWarning _ _ (WarnSome _) = pure Nothing moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of - DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) where format x bs = DocWarning . DocParagraph . DocAppend (DocString x) - <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs) + <$> processDocStringFromString dflags gre bs ------------------------------------------------------------------------------- @@ -478,7 +479,7 @@ mkMaps :: DynFlags -> Maybe Package -- this package -> GlobalRdrEnv -> [Name] - -> [(LHsDecl GhcRn, [HsDocString])] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] -> ExtractedTHDocs -- ^ Template Haskell putDoc docs -> ErrMsgM Maps mkMaps dflags pkgName gre instances decls thDocs = do @@ -511,36 +512,40 @@ mkMaps dflags pkgName gre instances decls thDocs = do thMappings = do let ExtractedTHDocs _ - (DeclDocMap declDocs) - (ArgDocMap argDocs) - (DeclDocMap instDocs) = thDocs - ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name) - ds2mdoc = processDocStringParas dflags pkgName gre - - declDocs' <- mapM ds2mdoc declDocs - argDocs' <- mapM (mapM ds2mdoc) argDocs - instDocs' <- mapM ds2mdoc instDocs + declDocs + argDocs + instDocs = thDocs + ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name) + ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString + + let cvt = M.fromList . nonDetEltsUniqMap + + declDocs' <- mapM ds2mdoc (cvt declDocs) + argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs) + instDocs' <- mapM ds2mdoc (cvt instDocs) return (declDocs' <> instDocs', argDocs') - mappings :: (LHsDecl GhcRn, [HsDocString]) + mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, IntMap (MDoc Name))] , [(Name, [LHsDecl GhcRn])] ) - mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do - let declDoc :: [HsDocString] -> IntMap HsDocString + mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do + let docStrs = map hsDocString hs_docStrs + declDoc :: [HsDocString] -> IntMap HsDocString -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (declTypeDocs decl) + (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl)) let subs :: [(Name, [HsDocString], IntMap HsDocString)] - subs = subordinates instanceMap decl + subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im)) + $ subordinates emptyOccEnv instanceMap decl (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs @@ -571,7 +576,23 @@ mkMaps dflags pkgName gre instances decls thDocs = do TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. - names _ decl = getMainDeclBinder decl + names _ decl = getMainDeclBinder emptyOccEnv decl + +-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two +-- maps with values for the same key merge the inner map as well. +-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. + +unionArgMaps :: forall b . Map Name (IntMap b) + -> Map Name (IntMap b) + -> Map Name (IntMap b) +unionArgMaps a b = M.foldrWithKey go b a + where + go :: Name -> IntMap b + -> Map Name (IntMap b) -> Map Name (IntMap b) + go n newArgMap acc + | Just oldArgMap <- M.lookup n acc = + M.insert n (newArgMap `IM.union` oldArgMap) acc + | otherwise = M.insert n newArgMap acc -- Note [2]: ------------ @@ -633,11 +654,11 @@ mkExportItems Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do - doc <- processDocString dflags gre docStr + doc <- processDocString dflags gre (hsDocString . unLoc $ docStr) return [ExportGroup lev "" doc] lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do - doc <- processDocStringParas dflags pkgName gre docStr + doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $ @@ -705,7 +726,7 @@ 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 emptyOccEnv (unL decl) in case () of _ -- We should not show a subordinate by itself if any of its @@ -784,7 +805,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let patSynNames = - concatMap (getMainDeclBinder . fst) bundledPatSyns + concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns fixities = [ (n, f) @@ -1006,17 +1027,17 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam (concat . concat) `fmap` (for decls $ \decl -> do case decl of (L _ (DocD _ (DocGroup lev docStr))) -> do - doc <- liftErrMsg (processDocString dflags gre docStr) + doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr)) return [[ExportGroup lev "" doc]] (L _ (DocD _ (DocCommentNamed _ docStr))) -> do - doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) + doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ -> - for (getMainDeclBinder (unLoc decl)) $ \nm -> do + for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of Just avail -> availExportItem is_sig modMap thisMod @@ -1041,7 +1062,7 @@ extractDecl -> LHsDecl GhcRn -- ^ parent declaration -> Either ErrMsg (LHsDecl GhcRn) extractDecl declMap name decl - | name `elem` getMainDeclBinder (unLoc decl) = pure decl + | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl | otherwise = case unLoc decl of TyClD _ d@ClassDecl { tcdLName = L _ clsNm @@ -1109,7 +1130,7 @@ extractDecl declMap name decl , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , extFieldOcc n == name + , foExt n == name ] in case matches of [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) @@ -1138,17 +1159,17 @@ extractPatternSyn nm t tvs cons = InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] ConDeclGADT { con_g_args = con_args' } -> case con_args' of PrefixConGADT args' -> map hsScaledThing args' - RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields + RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ) _ -> typ - typ'' = noLocA (HsQualTy noExtField Nothing typ') + typ'' = noLocA (HsQualTy noExtField (noLocA []) typ') in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs + longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -1165,12 +1186,12 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getRecConArgs_maybe con of Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) + pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] - matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds - , L l n <- ns, extFieldOcc n == nm ] + matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds + , L l n <- ns, foExt n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con @@ -1196,10 +1217,10 @@ mkVisibleNames (_, _, _, instMap) exports opts where exportName e@ExportDecl {} = name ++ subs ++ patsyns where subs = map fst (expItemSubDocs e) - patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) + patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e) name = case unLoc $ expItemDecl e of InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap - decl -> getMainDeclBinder decl + decl -> getMainDeclBinder emptyOccEnv decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -1216,6 +1237,7 @@ findNamedDoc name = search tell ["Cannot find documentation for: $" ++ name] return Nothing search (DocD _ (DocCommentNamed name' doc) : rest) - | name == name' = return (Just doc) + | name == name' = return (Just (hsDocString . unLoc $ doc)) + | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index d769f0cc..4e1964af 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn ( processDocString + , processDocStringFromString , processDocStringParas , processDocStrings , processModuleHeader @@ -38,6 +39,7 @@ import GHC.Parser.PostProcess import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet +import GHC.Utils.Trace processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -52,11 +54,15 @@ processDocStrings dflags pkg gre strs = do processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags pkg gre hds = - overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds) + overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre hds = - rename dflags gre $ parseString dflags (unpackHDS hds) + processDocStringFromString dflags gre (renderHsDocString hds) + +processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name) +processDocStringFromString dflags gre hds = + rename dflags gre $ parseString dflags hds processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) @@ -65,7 +71,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do case mayStr of Nothing -> return failure Just hds -> do - let str = unpackHDS hds + let str = renderHsDocString hds (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2833df49..6057bf75 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -191,8 +191,8 @@ renameDocumentation (Documentation mDoc mWarning) = Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning -renameLDocHsSyn :: LHsDocString -> RnM LHsDocString -renameLDocHsSyn = return +renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b)) +renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) [])) renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) @@ -245,9 +245,10 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) -renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) -renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a) -renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p +renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr) +renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr)) +renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr)) +renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of @@ -258,7 +259,7 @@ renameType t = case t of , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do - lcontext' <- traverse renameLContext lcontext + lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) @@ -289,11 +290,11 @@ renameType t = case t of HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts - HsOpTy _ a (L loc op) b -> do + HsOpTy _ prom a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy noAnn a' (L loc op') b') + return (HsOpTy noAnn prom a' (L loc op') b') HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty @@ -316,6 +317,7 @@ renameType t = case t of HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy _ -> pure (HsWildCardTy noAnn) + renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do bndrs' <- renameOuterTyVarBndrs bndrs @@ -505,15 +507,15 @@ renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_mb_cxt = lcontext, con_args = details , con_doc = mbldoc - , con_forall = forall }) = do + , con_forall = forall_ }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameH98Details details - mbldoc' <- mapM renameLDocHsSyn mbldoc + mbldoc' <- mapM (renameLDocHsSyn) mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' - , con_forall = forall -- Remove when #18311 is fixed + , con_forall = forall_ -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs @@ -548,9 +550,9 @@ renameH98Details (InfixCon a b) = do renameGADTDetails :: HsConDeclGADTDetails GhcRn -> RnM (HsConDeclGADTDetails DocNameI) -renameGADTDetails (RecConGADT (L l fields)) = do +renameGADTDetails (RecConGADT (L l fields) arr) = do fields' <- mapM renameConDeclFieldField fields - return (RecConGADT (L (locA l) fields')) + return (RecConGADT (L (locA l) fields') arr) renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 16f00fda..d1164858 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -16,6 +16,7 @@ import Haddock.Syb import Haddock.Types import GHC +import GHC.Types.Basic ( PromotionFlag(..) ) import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) @@ -132,9 +133,9 @@ sugarTuples typ = sugarOperators :: HsType GhcRn -> HsType GhcRn -sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) - | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb +sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb) + | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb + | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb where name' = getName name sugarOperators typ = typ @@ -283,7 +284,7 @@ renameType (HsForAllTy x tele lt) = <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x - <$> renameMContext lctxt + <$> renameLContext lctxt <*> renameLType lt renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name renameType t@(HsStarTy _ _) = pure t @@ -293,8 +294,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType l renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt -renameType (HsOpTy x la lop lb) = - HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb +renameType (HsOpTy x prom la lop lb) = + HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb renameType (HsParTy x lt) = HsParTy x <$> renameLType lt renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk @@ -311,7 +312,7 @@ renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p +renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p renameHsArrow mult = pure mult @@ -324,11 +325,10 @@ renameLKind = renameLType renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType -renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn)) -renameMContext Nothing = return Nothing -renameMContext (Just (L l ctxt)) = do +renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn) +renameLContext (L l ctxt) = do ctxt' <- renameContext ctxt - return (Just (L l ctxt')) + return (L l ctxt') renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes |