From 6173eeaa1608a4325ecd005feec05d3ab4e9323f Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sat, 18 Apr 2020 18:37:38 +0100
Subject: Match changes in GHC AST for in-tree API Annotations
As landed via https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2418
---
.../src/Haddock/Interface/AttachInstances.hs | 7 +-
haddock-api/src/Haddock/Interface/Create.hs | 41 ++++----
haddock-api/src/Haddock/Interface/Rename.hs | 106 +++++++++++----------
haddock-api/src/Haddock/Interface/Specialize.hs | 26 ++---
4 files changed, 92 insertions(+), 88 deletions(-)
(limited to 'haddock-api/src/Haddock/Interface')
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
--
cgit v1.2.3