diff options
author | Alan Zimmerman <alan.zimm@gmail.com> | 2020-04-18 18:37:38 +0100 |
---|---|---|
committer | Alan Zimmerman <alan.zimm@gmail.com> | 2021-03-15 17:15:26 +0000 |
commit | 6173eeaa1608a4325ecd005feec05d3ab4e9323f (patch) | |
tree | bb95cc5f7bd8ec026df1e94e989ffed83a548ab5 /haddock-api/src/Haddock/Interface | |
parent | d930bd87cd43d840bf2877e4a51b2a48c2e18f74 (diff) |
Match changes in GHC AST for in-tree API Annotations
As landed via https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2418
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 7 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 41 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 106 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 26 |
4 files changed, 92 insertions, 88 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 6bc8b8c8..e8a79b2b 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -30,14 +30,11 @@ import qualified Data.Set as Set import GHC.Data.FastString (unpackFS) import GHC.Core.Class -import GHC.Driver.Session import GHC.Core (isOrphan) -import GHC.Utils.Error import GHC.Core.FamInstEnv import GHC import GHC.Core.InstEnv import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts ) -import GHC.Utils.Monad (liftIO) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable (text, sep, (<+>)) @@ -104,7 +101,7 @@ attachToExportItem index expInfo getInstDoc getFixity export = fam_instances = maybeToList mb_instances >>= snd fam_insts = [ ( synFamInst , getInstDoc n - , spanNameE n synFamInst (L eSpan (tcdName d)) + , spanNameE n synFamInst (L (locA eSpan) (tcdName d)) , nameModule_maybe n ) | i <- sortBy (comparing instFam) fam_instances @@ -116,7 +113,7 @@ attachToExportItem index expInfo getInstDoc getFixity export = ] cls_insts = [ ( synClsInst , getInstDoc n - , spanName n synClsInst (L eSpan (tcdName d)) + , spanName n synClsInst (L (locA eSpan) (tcdName d)) , nameModule_maybe n ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4e788260..a280c0b2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -79,6 +79,8 @@ import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..)) import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic (pprPanic) +import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.Unit.Module.Warnings newtype IfEnv m = IfEnv { @@ -200,7 +202,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do loc_splices :: [SrcSpan] loc_splices = case tcg_rn_decls of Nothing -> [] - Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ] + Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ] decls <- case tcg_rn_decls of Nothing -> do @@ -530,7 +532,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do , [(Name, IntMap (MDoc Name))] , [(Name, [LHsDecl GhcRn])] ) - mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do + mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do let declDoc :: [HsDocString] -> IntMap HsDocString -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do @@ -559,7 +561,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do seqList subDocs `seq` seqList subArgs `seq` pure (dm, am, cm) - mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], []) + mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], []) instanceMap :: Map RealSrcSpan Name instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] @@ -570,7 +572,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and -- get the identifier with the right location. - TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d') + TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -701,7 +703,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let t = availName avail r <- findDecl avail case r of - ([L l (ValD _ _)], (doc, _)) -> do + ([L l' (ValD _ _)], (doc, _)) -> do + let l = locA l' -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] @@ -734,7 +737,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames L loc (TyClD _ ClassDecl {..}) -> do mdef <- minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef availExportDecl avail (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ @@ -892,7 +895,7 @@ hiDecl dflags t = do Just x -> case tyThingToLHsDecl ShowRuntimeRep x of Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing Right (m, t') -> liftErrMsg (tell $ map bugWarn m) - >> return (Just $ noLoc t') + >> return (Just $ noLocA t') where warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> O.comma O.<+> O.quotes (O.ppr t) O.<+> @@ -912,7 +915,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do Nothing -> return (ExportNoDecl name []) Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) where - fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t + fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t fixities = case fixity of Just f -> [(name, f)] Nothing -> [] @@ -1101,7 +1104,7 @@ extractDecl declMap name decl , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of - [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) + [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0))) _ -> Left "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl d ) @@ -1113,7 +1116,7 @@ extractDecl declMap name decl , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) + [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) @@ -1143,21 +1146,21 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField (Just cxt) typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ) _ -> typ - typ'' = noLoc (HsQualTy noExtField (Just (noLoc [])) typ') - in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'') + typ'' = noLocA (HsQualTy noExtField Nothing typ') + in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs + longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExtField f + mkAppTyArg f (HsArgPar _) = HsParTy noAnn f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) @@ -1166,7 +1169,7 @@ 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 l (TypeSig noExtField [noLoc nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) + pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1175,11 +1178,11 @@ extractRecSel nm t tvs (L _ con : rest) = data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExtField f + mkAppTyArg f (HsArgPar _) = HsParTy noAnn f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b62f79ce..2833df49 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -34,6 +34,7 @@ import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set import Prelude hiding (mapM) import GHC.HsToCore.Docs +import GHC.Types.Basic ( TopLevelFlag(..) ) -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to -- 'DocName'. @@ -173,10 +174,9 @@ rename :: Name -> RnM DocName rename = lookupRn -renameL :: Located Name -> RnM (Located DocName) +renameL :: GenLocated l Name -> RnM (GenLocated l DocName) renameL = mapM rename - renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -235,10 +235,10 @@ renameFamilyResultSig (L loc (TyVarSig _ bndr)) ; return (L loc (TyVarSig noExtField bndr')) } renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) -renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) +renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs)) = do { lhs' <- renameL lhs ; rhs' <- mapM renameL rhs - ; return (L loc (InjectivityAnn lhs' rhs')) } + ; return (L loc (InjectivityAnn noExtField lhs' rhs')) } renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI)) @@ -246,75 +246,75 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) -renameArrow (HsLinearArrow u) = return (HsLinearArrow u) -renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a) +renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of HsForAllTy { hst_tele = tele, hst_body = ltype } -> do tele' <- renameHsForAllTelescope tele ltype' <- renameLType ltype - return (HsForAllTy { hst_xforall = noExtField + return (HsForAllTy { hst_xforall = noAnn , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- traverse renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype - HsStarTy _ isUni -> return (HsStarTy noExtField isUni) + HsStarTy _ isUni -> return (HsStarTy noAnn isUni) HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy noExtField a' b') + return (HsAppTy noAnn a' b') HsAppKindTy _ a b -> do a' <- renameLType a b' <- renameLKind b - return (HsAppKindTy noExtField a' b') + return (HsAppKindTy noAnn a' b') HsFunTy _ w a b -> do a' <- renameLType a b' <- renameLType b w' <- renameArrow w - return (HsFunTy noExtField w' a' b') + return (HsFunTy noAnn w' a' b') - HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty - HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) + HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty) - HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy noExtField a' (L loc op') b') + return (HsOpTy noAnn a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig noExtField ty' k') + return (HsKindSig noAnn ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy noExtField ty' doc') + return (HsDocTy noAnn ty' doc') - HsTyLit _ x -> return (HsTyLit noExtField x) + HsTyLit _ x -> return (HsTyLit noAnn x) - HsRecTy _ a -> HsRecTy noExtField <$> mapM renameConDeclFieldField a + HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a XHsType a -> pure (XHsType a) - HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b - HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b + HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b + HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b HsSpliceTy _ s -> renameHsSpliceTy s - HsWildCardTy a -> pure (HsWildCardTy a) + HsWildCardTy _ -> pure (HsWildCardTy noAnn) renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do @@ -341,21 +341,21 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) renameHsForAllTelescope tele = case tele of - HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs - pure $ HsForAllVis x bndrs' - HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs - pure $ HsForAllInvis x bndrs' + HsForAllVis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllVis noExtField bndrs' + HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllInvis noExtField bndrs' renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) -renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) +renameLTyVarBndr (L loc (UserTyVar _ fl (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar x fl (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind)) + ; return (L loc (UserTyVar noExtField fl (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar x fl (L lv n') kind')) } + ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } -renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) +renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') @@ -406,8 +406,8 @@ renameDecl decl = case decl of return (DerivD noExtField d') _ -> error "renameDecl" -renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) -renameLThing fn (L loc x) = return . L loc =<< fn x +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI)) +renameLThing fn (L loc x) = return . L (locA loc) =<< fn x renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of @@ -446,12 +446,13 @@ renameTyClD d = case d of , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField }) where - renameLFunDep (L loc (xs, ys)) = do + renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI) + renameLFunDep (L loc (FunDep _ xs ys)) = do xs' <- mapM rename (map unLoc xs) ys' <- mapM rename (map unLoc ys) - return (L loc (map noLoc xs', map noLoc ys')) + return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) - renameLSig (L loc sig) = return . L loc =<< renameSig sig + renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname @@ -464,7 +465,8 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel + , fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' @@ -492,12 +494,12 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- traverse renameLContext lcontext k' <- renameMaybeLKind k - cons' <- mapM (mapM renameCon) cons + cons' <- mapM (mapMA renameCon) cons -- I don't think we need the derivings, so we return Nothing return (HsDataDefn { dd_ext = noExtField , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' - , dd_derivs = noLoc [] }) + , dd_derivs = [] }) renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -537,7 +539,7 @@ renameH98Details :: HsConDeclH98Details GhcRn -> RnM (HsConDeclH98Details DocNameI) renameH98Details (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields - return (RecCon (L l fields')) + return (RecCon (L (locA l) fields')) renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps renameH98Details (InfixCon a b) = do a' <- renameHsScaled a @@ -548,7 +550,7 @@ renameGADTDetails :: HsConDeclGADTDetails GhcRn -> RnM (HsConDeclGADTDetails DocNameI) renameGADTDetails (RecConGADT (L l fields)) = do fields' <- mapM renameConDeclFieldField fields - return (RecConGADT (L l fields')) + return (RecConGADT (L (locA l) fields')) renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) @@ -556,7 +558,7 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField noExtField names' t' doc') + return $ L (locA l) (ConDeclField noExtField names' t' doc') renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -621,10 +623,10 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_overlap_mode = omode }) renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) -renameDerivStrategy StockStrategy = pure StockStrategy -renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy -renameDerivStrategy NewtypeStrategy = pure NewtypeStrategy -renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty +renameDerivStrategy (StockStrategy a) = pure (StockStrategy a) +renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a) +renameDerivStrategy (NewtypeStrategy a) = pure (NewtypeStrategy a) +renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode @@ -642,7 +644,7 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) = do { eqn' <- renameTyFamInstEqn eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' }) } + ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) } renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 5ef5d92d..16f00fda 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -19,7 +19,6 @@ import GHC import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State @@ -75,7 +74,7 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) = - TypeSig noExtField lnames (typ {hswc_body = noLoc typ'}) + TypeSig noAnn lnames (typ {hswc_body = noLocA typ'}) where true_type :: HsSigType GhcRn true_type = unLoc (dropWildCards typ) @@ -111,7 +110,7 @@ sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | getName name == listTyConName = HsListTy noExtField ltyp + | getName name == listTyConName = HsListTy noAnn ltyp sugarLists typ = typ @@ -122,7 +121,7 @@ sugarTuples typ = aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy _ (L _ typ')) = aux apps typ' aux apps (HsTyVar _ _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedOrConstraintTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps where name' = getName name strName = getOccString name @@ -132,10 +131,10 @@ sugarTuples typ = aux _ _ = typ -sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +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 noExtField (HsUnrestrictedArrow NormalSyntax) la lb + | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ @@ -286,7 +285,7 @@ renameType (HsQualTy x lctxt lt) = HsQualTy x <$> renameMContext lctxt <*> renameLType lt -renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name +renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk @@ -295,7 +294,7 @@ 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 <*> located renameName lop <*> renameLType lb + HsOpTy x <$> 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 @@ -312,7 +311,7 @@ renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p renameHsArrow mult = pure mult @@ -342,9 +341,9 @@ renameForAllTelescope (HsForAllInvis x bndrs) = HsForAllInvis x <$> mapM renameLBinder bndrs renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) -renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname +renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname renameBinder (KindedTyVar x fl lname lkind) = - KindedTyVar x fl <$> located renameName lname <*> located renameType lkind + KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) renameLBinder = located renameBinder @@ -397,9 +396,12 @@ alternativeNames name = str = nameRepString name -located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b) located f (L loc e) = L loc <$> f e +locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b) +locatedN f (L loc e) = L loc <$> f e + tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn tyVarName (UserTyVar _ _ name) = unLoc name |