From 6173eeaa1608a4325ecd005feec05d3ab4e9323f Mon Sep 17 00:00:00 2001 From: Alan Zimmerman 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 --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hoogle.hs | 38 +++-- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 33 ++-- haddock-api/src/Haddock/Backends/Xhtml.hs | 3 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 78 ++++----- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 5 +- haddock-api/src/Haddock/Convert.hs | 187 +++++++++++---------- haddock-api/src/Haddock/GhcUtils.hs | 84 +++++---- haddock-api/src/Haddock/Interface.hs | 2 +- .../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 +-- haddock-api/src/Haddock/Types.hs | 106 ++++++++---- 17 files changed, 387 insertions(+), 336 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index e9433d73..730f4f5c 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -194,6 +194,7 @@ test-suite spec , exceptions , filepath , ghc-boot + , ghc-boot-th , transformers build-tool-depends: diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1a0cccf7..e70a705f 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -72,7 +72,7 @@ ppModule dflags unit_state iface = --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p) +dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn dropHsDocTy = drop_sig_ty where drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b) @@ -94,8 +94,7 @@ dropHsDocTy = drop_sig_ty drop_ty (HsDocTy _ a _) = drop_ty $ unL a drop_ty x = x -outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p) - => DynFlags -> HsSigType (GhcPass p) -> String +outHsSigType :: DynFlags -> HsSigType GhcRn -> String outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy @@ -154,13 +153,13 @@ ppSigWithDoc dflags sig subdocs = case sig of PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names _ -> [] where - mkDocSig leader typ n = mkSubdoc dflags n subdocs - [leader ++ pp_sig dflags [n] typ] + mkDocSig leader typ n = mkSubdocN dflags n subdocs + [leader ++ pp_sig dflags [n] typ] ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String +pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) = operator prettyNames ++ " :: " ++ outHsSigType dflags typ where @@ -187,7 +186,7 @@ ppClass dflags decl subdocs = pprTyFam :: LFamilyDecl GhcRn -> SDoc pprTyFam (L _ at) = vcat' $ map text $ - mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at) + mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at) whereWrapper elems = vcat' [ text "where" <+> lbrace @@ -222,7 +221,7 @@ ppSynonym dflags x = [out dflags x] ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs - = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : + = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} : concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where @@ -235,7 +234,7 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... -lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] @@ -248,11 +247,11 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ + [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) + funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ @@ -262,12 +261,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n - tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty + tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n + tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty tyVarArg _ = panic "ppCtor" resType = apps $ map reL $ - (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : + (HsTyVar noAnn NotPromoted (reL (tcdName dat))) : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names @@ -281,15 +280,15 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names name = out dflags $ map unL names con_sig_ty = HsSig noExtField outer_bndrs theta_ty where theta_ty = case mcxt of - Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) + Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) Nothing -> tau_ty tau_ty = foldr mkFunTy res_ty $ case args of PrefixConGADT pos_args -> map hsScaledThing pos_args RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds - mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- @@ -312,7 +311,10 @@ docWith dflags header d lines header ++ ["" | header /= "" && isJust d] ++ maybe [] (showTags . markup (markupTag dflags)) d -mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s + +mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 2def35ae..d9a2e0cd 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -360,7 +360,7 @@ classify tok = -- the GHC lexer for more), so we have to manually reverse this. The -- following is a hammer: it smashes _all_ pragma-like block comments into -- pragmas. - ITblockComment c + ITblockComment c _ | isPrefixOf "{-#" c , isSuffixOf "#-}" c -> TkPragma | otherwise -> TkComment diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e2e16947..abf882f0 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -390,10 +390,11 @@ ppFamHeader (FamilyDecl { fdLName = L _ name injAnn = case injectivity of Nothing -> empty - Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|") - : ppLDocName lhs - : arrow unicode - : map ppLDocName rhs) + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|") + : ppLDocName lhs + : arrow unicode + : map ppLDocName rhs) + Just _ -> empty @@ -597,8 +598,8 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName - -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -606,14 +607,16 @@ ppClassHdr summ lctxt n tvs fds unicode = <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode - -ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX +-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX +ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> + fundep (FunDep _ vars1 vars2) + = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> hsep (map (ppDocName . unLoc) vars2) + fundep (XFunDep _) = error "ppFds" -- TODO: associated type defaults, docs on default methods @@ -804,7 +807,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode @@ -893,7 +896,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = -- | Pretty-print a bundled pattern synonym -ppSideBySidePat :: [Located DocName] -- ^ pattern name(s) +ppSideBySidePat :: [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> Bool -- ^ unicode @@ -1036,7 +1039,7 @@ sumParens = ubxparens . hsep . punctuate (text " |") -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX +ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) @@ -1104,9 +1107,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arr <+> ppr_mono_lty ty2 u ] where arr = case mult of - HsLinearArrow _ -> lollipop u + HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u + HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name @@ -1187,7 +1190,7 @@ ppOccName = text . occNameString ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName -ppLDocName :: Located DocName -> LaTeX +ppLDocName :: GenLocated l DocName -> LaTeX ppLDocName (L _ d) = ppDocName d diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 1bdbf81b..d390a95a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -49,8 +49,7 @@ import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) import Data.Ord ( comparing ) -import GHC.Driver.Session (Language(..)) -import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) +import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor ) import GHC.Types.Name import GHC.Unit.State diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e48f9bdd..8de1b1b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -58,22 +58,22 @@ ppDecl :: Bool -- ^ print summary info only -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of - TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual - TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual - TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual - TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual - SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames (dropWildCards lty) fixities splice unicode pkg qual - SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames lty fixities splice unicode pkg qual - ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual + ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> + [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities @@ -90,7 +90,7 @@ ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg q -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName - -> [Located DocName] -- ^ names of patterns in declaration + -> [LocatedN DocName] -- ^ names of patterns in declaration -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html @@ -249,7 +249,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type) + full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml @@ -330,7 +330,7 @@ ppPseudoFamDecl links splice , pfdTyVars = tvs , pfdLName = L loc name }) unicode qual = - topDeclElem links loc splice [name] leader + topDeclElem links (locA loc) splice [name] leader where leader = hsep [ ppFamilyLeader True info , ppAppNameTypes name (map unLoc tvs) unicode qual @@ -361,10 +361,11 @@ ppFamHeader summary associated (FamilyDecl { fdInfo = info injAnn = case injectivity of Nothing -> noHtml - Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|" - : ppLDocName qual Raw lhs - : arrow unicode - : map (ppLDocName qual Raw) rhs) + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|" + : ppLDocName qual Raw lhs + : arrow unicode + : map (ppLDocName qual Raw) rhs) + Just _ -> error "ppFamHeader:XInjectivityAnn" -- | Print the keywords that begin the family declaration ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html @@ -474,8 +475,8 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName - -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -484,12 +485,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual = <+> ppFds fds unicode qual -ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html +ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + fundep (XFunDep _) = error "ppFds" ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan @@ -572,9 +574,9 @@ ppClassDecl summary links instances fixities loc d subdocs lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList [ (getName name, (vs, typ)) - | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ - , feqn_tycon = L _ name - , feqn_pats = vs })) <- atsDefs + | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs })) <- atsDefs ] -- Methods @@ -723,7 +725,7 @@ ppInstanceSigs links splice unicode qual sigs = do L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -828,7 +830,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNamesI (unLoc c)))) fixities + (map unL (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual @@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -895,7 +897,7 @@ ppShortConstrParts summary dataInst con unicode qual ) where - occ = map (nameOccName . getName . unLoc) $ getConNamesI con + occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -912,10 +914,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) - aConName = unLoc (head (getConNamesI con)) + aConName = unL (head (getConNamesI con)) fixity = ppFixities fixities qual - occ = map (nameOccName . getName . unLoc) $ getConNamesI con + occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) @@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -994,7 +996,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>= + mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst @@ -1044,7 +1046,7 @@ ppShortField summary unicode qual (ConDeclField _ names ltype _) -- | Pretty print an expanded pattern (for bundled patterns) ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification - -> [Located DocName] -- ^ pattern name(s) + -> [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> SubDecl @@ -1121,7 +1123,7 @@ sumParens = ubxSumList -- * Rendering of HsType -------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) @@ -1153,7 +1155,7 @@ instance RenderableBndrFlag () where ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) instance RenderableBndrFlag Specificity where @@ -1162,10 +1164,10 @@ instance RenderableBndrFlag Specificity where ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = - braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html @@ -1246,9 +1248,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = , arr <+> ppr_mono_lty ty2 u q e ] where arr = case mult of - HsLinearArrow _ -> lollipop u + HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u + HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) @@ -1283,7 +1285,7 @@ ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _ -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. ppr_op - | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' + | (getOccString . getName . unL) op == ":" = promoQuote ppr_op' | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 7670b193..b8f5ac0f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -31,7 +31,7 @@ import Haddock.Doc (combineDocumentation, emptyMetaDoc, import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) -import GHC +import GHC hiding (anchor) import GHC.Types.Name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index d61d6d9b..8f04a21f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -51,7 +51,7 @@ import Text.XHtml hiding ( name, title, quote ) import Data.Maybe (fromMaybe) import GHC.Data.FastString ( unpackFS ) -import GHC +import GHC hiding (anchor) import GHC.Types.Name (nameOccName) -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index b324fa38..6dfc60fa 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -27,7 +27,7 @@ import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M import Data.List ( stripPrefix ) -import GHC hiding (LexicalFixity(..)) +import GHC hiding (LexicalFixity(..), anchor) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Data.FastString (unpackFS) @@ -57,9 +57,10 @@ ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation -ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html ppLDocName qual notation (L _ d) = ppDocName qual notation True d + ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html ppDocName qual notation insertAnchors docName = case docName of diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a87ba7ce..19630077 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,7 +22,7 @@ module Haddock.Convert ( #include "HsVersions.h" import GHC.Data.Bag ( emptyBag ) -import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) ) import GHC.Types.SourceText (SourceText(..)) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class @@ -53,7 +53,6 @@ import GHC.Utils.Panic ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize @@ -92,20 +91,20 @@ tyThingToLHsDecl prr t = case t of extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - cvt :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p) + cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn -- Without this signature, we trigger GHC#18932 - cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n - cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField - (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind + cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n + cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn + (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind -- | Convert a LHsTyVarBndr to an equivalent LHsType. - hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) + hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn hsLTyVarBndrToType = mapLoc cvt extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs = - TyFamInstDecl $ FamEqn - { feqn_ext = noExtField + TyFamInstDecl noAnn $ FamEqn + { feqn_ext = noAnn , feqn_tycon = fdLName fd , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)} , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ @@ -119,8 +118,8 @@ tyThingToLHsDecl prr t = case t of extractAtItem (ATI at_tc def) = do tyDecl <- synifyTyCon prr Nothing at_tc famDecl <- extractFamilyDecl tyDecl - let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def - pure (noLoc famDecl, defEqnTy) + let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def + pure (noLocA famDecl, defEqnTy) atTyClDecls = map extractAtItem (classATItems cl) (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) @@ -128,14 +127,14 @@ tyThingToLHsDecl prr t = case t of in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) - , tcdLName = synifyName cl + , tcdLName = synifyNameN cl , tcdTyVars = synifyTyVars vs , tcdFixity = synifyFixity cl - , tcdFDs = map (\ (l,r) -> noLoc - (map (noLoc . getName) l, map (noLoc . getName) r) ) $ + , tcdFDs = map (\ (l,r) -> noLocA + (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : - [ noLoc tcdSig + , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) : + [ noLocA tcdSig | clsOp <- classOpItems cl , tcdSig <- synifyTcIdSig vs clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -152,25 +151,25 @@ tyThingToLHsDecl prr t = case t of ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc] (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) AConLike (PatSynCon ps) -> - allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) - = let name = synifyName tc + = let name = synifyNameN tc args_types_only = filterOutInvisibleTypes tc args typats = map (synifyType WithinType []) args_types_only annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} -- TODO: this must change eventually - in FamEqn { feqn_ext = noExtField + in FamEqn { feqn_ext = noAnn , feqn_tycon = name , feqn_bndrs = outer_bndrs , feqn_pats = map HsValArg annot_typats @@ -185,7 +184,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) , Just branch <- coAxiomSingleBranch_maybe ax = return $ InstD noExtField $ TyFamInstD noExtField - $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } + $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error @@ -203,7 +202,7 @@ synifyTyCon synifyTyCon prr _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ - DataDecl { tcdLName = synifyName tc + DataDecl { tcdLName = synifyNameN tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv (map scaledThing tyVarKinds) @@ -212,7 +211,7 @@ synifyTyCon prr _coax tc , tcdFixity = synifyFixity tc - , tcdDataDefn = HsDataDefn { dd_ext = noExtField + , tcdDataDefn = HsDataDefn { dd_ext = noAnn , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = Nothing @@ -220,13 +219,13 @@ synifyTyCon prr _coax tc , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors - , dd_derivs = noLoc [] } + , dd_derivs = [] } , tcdDExt = DataDeclRn False emptyNameSet } where -- tyConTyVars doesn't work on fun/prim, but we can make them up: mk_hs_tv realKind fakeTyVar - | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar)) - | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind) + | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar)) + | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc) tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind @@ -239,7 +238,7 @@ synifyTyCon _prr _coax tc ClosedSynFamilyTyCon mb | Just (CoAxiom { co_ax_branches = branches }) <- mb -> mkFamDecl $ ClosedTypeFamily $ Just - $ map (noLoc . synifyAxBranch tc) (fromBranches branches) + $ map (noLocA . synifyAxBranch tc) (fromBranches branches) | otherwise -> mkFamDecl $ ClosedTypeFamily $ Just [] BuiltInSynFamTyCon {} @@ -251,9 +250,10 @@ synifyTyCon _prr _coax tc where resultVar = famTcResVar tc mkFamDecl i = return $ FamDecl noExtField $ - FamilyDecl { fdExt = noExtField + FamilyDecl { fdExt = noAnn , fdInfo = i - , fdLName = synifyName tc + , fdTopLevel = TopLevel + , fdLName = synifyNameN tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = synifyFixity tc , fdResultSig = @@ -266,7 +266,7 @@ synifyTyCon _prr _coax tc synifyTyCon _prr coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdSExt = emptyNameSet - , tcdLName = synifyName tc + , tcdLName = synifyNameN tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = synifyFixity tc , tcdRhs = synifyType WithinType [] ty } @@ -276,9 +276,9 @@ synifyTyCon _prr coax tc alg_nd = if isNewTyCon tc then NewType else DataType alg_ctx = synifyCtx (tyConStupidTheta tc) name = case coax of - Just a -> synifyName a -- Data families are named according to their + Just a -> synifyNameN a -- Data families are named according to their -- CoAxioms, not their TyCons - _ -> synifyName tc + _ -> synifyNameN tc tyvars = synifyTyVars (tyConVisibleTyVars tc) kindSig = synifyDataTyConReturnKind tc -- The data constructors. @@ -301,8 +301,8 @@ synifyTyCon _prr coax tc consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. - alg_deriv = noLoc [] - defn = HsDataDefn { dd_ext = noExtField + alg_deriv = [] + defn = HsDataDefn { dd_ext = noAnn , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing @@ -342,15 +342,15 @@ synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity synifyInjectivityAnn Nothing _ _ = Nothing synifyInjectivityAnn _ _ NotInjective = Nothing synifyInjectivityAnn (Just lhs) tvs (Injective inj) = - let rhs = map (noLoc . tyVarName) (filterByList inj tvs) - in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs + let rhs = map (noLocA . tyVarName) (filterByList inj tvs) + in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind | isLiftedTypeKind kind = noLoc $ NoSig noExtField | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -364,7 +364,7 @@ synifyDataCon use_gadt_syntax dc = -- infix *syntax*. use_infix_syntax = dataConIsInfix dc use_named_field_syntax = not (null field_tys) - name = synifyName dc + name = synifyNameN dc -- con_qvars means a different thing depending on gadt-syntax (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors @@ -384,18 +384,18 @@ synifyDataCon use_gadt_syntax dc = let tySyn = synifyType WithinType [] (scaledThing ty) in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn - bang' -> noLoc $ HsBangTy noExtField bang' tySyn) + bang' -> noLocA $ HsBangTy noAnn bang' tySyn) arg_tys (dataConSrcBangs dc) field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys - con_decl_field fl synTy = noLoc $ - ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy + con_decl_field fl synTy = noLocA $ + ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy Nothing mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn) mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" - (True,False) -> return $ RecCon (noLoc field_tys) + (True,False) -> return $ RecCon (noLocA field_tys) (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys) (False,True) -> case linear_tys of [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) @@ -403,34 +403,37 @@ synifyDataCon use_gadt_syntax dc = mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn mk_gadt_arg_tys - | use_named_field_syntax = RecConGADT (noLoc field_tys) + | use_named_field_syntax = RecConGADT (noLocA field_tys) | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) -- finally we get synifyDataCon's result! in if use_gadt_syntax then do let hat = mk_gadt_arg_tys - return $ noLoc $ ConDeclGADT - { con_g_ext = noExtField + return $ noLocA $ ConDeclGADT + { con_g_ext = noAnn , con_names = [name] - , con_bndrs = noLoc outer_bndrs + , con_bndrs = noLocA outer_bndrs , con_mb_cxt = ctx , con_g_args = hat , con_res_ty = synifyType WithinType [] res_ty , con_doc = Nothing } else do hat <- mk_h98_arg_tys - return $ noLoc $ ConDeclH98 - { con_ext = noExtField + return $ noLocA $ ConDeclH98 + { con_ext = noAnn , con_name = name - , con_forall = noLoc False + , con_forall = False , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } -synifyName :: NamedThing n => n -> Located Name -synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) +synifyNameN :: NamedThing n => n -> LocatedN Name +synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) + +-- synifyName :: NamedThing n => n -> LocatedA Name +-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) -- | Guess the fixity of a something with a name. This isn't quite right, since -- a user can always declare an infix name in prefix form or a prefix name in @@ -445,7 +448,7 @@ synifyIdSig -> [TyVar] -- ^ free variables in the type to convert -> Id -- ^ the 'Id' from which to get the type signature -> Sig GhcRn -synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs t) +synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t) where t = defaultType prr (varType i) @@ -454,15 +457,15 @@ synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs -- 'ClassOpSig'. synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] synifyTcIdSig vs (i, dm) = - [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] ++ - [ ClassOpSig noExtField True [noLoc dn] (defSig dt) + [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] ++ + [ ClassOpSig noAnn True [noLocA dn] (defSig dt) | Just (dn, GenericDM dt) <- [dm] ] where mainSig t = synifySigType DeleteTopLevelQuantification vs t defSig t = synifySigType ImplicitizeForAll vs t synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn) -synifyCtx ts = Just (noLoc ( map (synifyType WithinType []) ts)) +synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts)) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn @@ -483,8 +486,8 @@ synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn synify_ty_var no_kinds flag tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds - = noLoc (UserTyVar noExtField flag (noLoc name)) - | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind)) + = noLocA (UserTyVar noAnn flag (noLocA name)) + | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -501,7 +504,7 @@ annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType [] ki - in noLoc (HsKindSig noExtField hs_ty hs_ki) + in noLocA (HsKindSig noAnn hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every argument type that a type constructor accepts, @@ -567,7 +570,7 @@ synifyType -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the type to convert -> LHsType GhcRn -synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv) +synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv) synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where @@ -578,63 +581,63 @@ synifyType _ vs (TyConApp tc tys) , [TyConApp rep [TyConApp lev []]] <- tys , rep `hasKey` boxedRepDataConKey , lev `hasKey` liftedDataConKey - = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName)) + = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == tys_len - = noLoc $ HsTupleTy noExtField + = noLocA $ HsTupleTy noAnn (case sort of BoxedTuple -> HsBoxedOrConstraintTuple ConstraintTuple -> HsBoxedOrConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType vs) vis_tys) - | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys - = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) + = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- vis_tys = - noLoc $ HsListTy noExtField (synifyType WithinType vs ty) + noLocA $ HsListTy noAnn (synifyType WithinType vs ty) | tc == promotedNilDataCon, [] <- vis_tys - = noLoc $ HsExplicitListTy noExtField IsPromoted [] + = noLocA $ HsExplicitListTy noExtField IsPromoted [] | tc == promotedConsDataCon , [ty1, ty2] <- vis_tys = let hTy = synifyType WithinType vs ty1 in case synifyType WithinType vs ty2 of tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy - -> noLoc $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') + -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise - -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy + -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty) + = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys - = noLoc $ HsOpTy noExtField + = noLocA $ HsOpTy noExtField (synifyType WithinType vs ty1) - (noLoc eqTyConName) + (noLocA eqTyConName) (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys = mk_app_tys (HsOpTy noExtField (synifyType WithinType vs ty1) - (noLoc $ getName tc) + (noLocA $ getName tc) (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc)) + = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc)) vis_tys where prom = if isPromotedDataCon tc then IsPromoted else NotPromoted mk_app_tys ty_app ty_args = - foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) - (noLoc ty_app) + foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) + (noLocA ty_app) (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) @@ -646,7 +649,7 @@ synifyType _ vs (TyConApp tc tys) | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind - in noLoc $ HsKindSig noExtField ty' full_kind' + in noLocA $ HsKindSig noAnn ty' full_kind' | otherwise = ty' synifyType _ vs ty@(AppTy {}) = let @@ -656,19 +659,19 @@ synifyType _ vs ty@(AppTy {}) = let filterOut isCoercionTy $ filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) ty_args - in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' + in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty synifyType _ vs (FunTy VisArg w t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 w' = synifyMult vs w - in noLoc $ HsFunTy noExtField w' s1 s2 + in noLocA $ HsFunTy noAnn w' s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = case argf of Required -> synifyVisForAllType vs forallty Invisible _ -> synifySigmaType s vs forallty -synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t +synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" @@ -686,9 +689,9 @@ synifyVisForAllType vs ty = -- absence of an explicit forall tvs' = orderedFVs (mkVarSet vs) [rho] - in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs - , hst_xforall = noExtField - , hst_body = synifyType WithinType (tvs' ++ vs) rho } + in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn sTvs + , hst_xforall = noExtField + , hst_body = synifyType WithinType (tvs' ++ vs) rho } -- | Process a 'Type' which starts with an invisible @forall@ or a constraint -- into an 'HsType' @@ -703,9 +706,9 @@ synifySigmaType s vs ty = , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs , hst_xforall = noExtField - , hst_body = noLoc sPhi } + , hst_body = noLocA sPhi } sTvs = map synifyTyVarBndr tvs @@ -718,8 +721,8 @@ synifySigmaType s vs ty = -- Put a forall in if there are any type variables WithinType - | not (null tvs) -> noLoc sTy - | otherwise -> noLoc sPhi + | not (null tvs) -> noLocA sTy + | otherwise -> noLocA sPhi ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau @@ -735,9 +738,9 @@ implicitForAll -> Type -- ^ inner type -> LHsType GhcRn implicitForAll tycons vs tvs ctx synInner tau - | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy - | tvs' /= (binderVars tvs) = noLoc sTy - | otherwise = noLoc sPhi + | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy + | tvs' /= (binderVars tvs) = noLocA sTy + | otherwise = noLocA sPhi where sRho = synInner (tvs' ++ vs) tau sPhi | null ctx = unLoc sRho @@ -745,9 +748,9 @@ implicitForAll tycons vs tvs ctx synInner tau = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs , hst_xforall = noExtField - , hst_body = noLoc sPhi } + , hst_body = noLocA sPhi } no_kinds_needed = noKindTyVars tycons tau sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs @@ -796,9 +799,9 @@ noKindTyVars _ _ = emptyVarSet synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of - One -> HsLinearArrow NormalSyntax + One -> HsLinearArrow NormalSyntax Nothing Many -> HsUnrestrictedArrow NormalSyntax - ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) + ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 41801710..b8db6dfd 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -26,7 +26,7 @@ import Control.Arrow import Data.Char ( isSpace ) import Data.Maybe ( mapMaybe, fromMaybe ) -import Haddock.Types( DocName, DocNameI ) +import Haddock.Types( DocName, DocNameI, XRecCond ) import GHC.Utils.FV as FV import GHC.Utils.Outputable ( Outputable ) @@ -44,7 +44,6 @@ import GHC.Types.Var.Set ( VarSet, emptyVarSet ) import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Core.Type ( isRuntimeRepVar ) -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Builtin.Types( liftedRepTy ) import GHC.Data.StringBuffer ( StringBuffer ) @@ -75,20 +74,20 @@ filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty)) + filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _ _) = Just orig filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig noExtField filtered ty) + filtered -> Just (TypeSig noAnn filtered ty) filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig noExtField is_default filtered ty) + filtered -> Just (ClassOpSig noAnn is_default filtered ty) filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (PatSynSig noExtField filtered ty) + filtered -> Just (PatSynSig noAnn filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -127,7 +126,7 @@ hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName hsLTyVarNameI = hsTyVarNameI . unLoc -getConNamesI :: ConDecl DocNameI -> [Located DocName] +getConNamesI :: ConDecl DocNameI -> [LocatedN DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names @@ -167,21 +166,22 @@ getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) - = noLoc (HsSig { sig_ext = noExtField - , sig_bndrs = outer_bndrs - , sig_body = theta_ty }) + = noLocA (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) + = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty }) | otherwise = tau_ty -- tau_ty :: LHsType DocNameI tau_ty = case args of - RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) + mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT @@ -197,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name] getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinderI _ = [] -familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName +familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName familyDeclLNameI (FamilyDecl { fdLName = n }) = n -tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName +tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln @@ -212,7 +212,7 @@ tcdNameI = unLoc . tyClDeclLNameI addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) + = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) where go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty })) = L loc (HsSig { sig_ext = noExtField @@ -230,14 +230,14 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) - add_ctxt Nothing = Just $ noLoc [extra_pred] + add_ctxt Nothing = Just $ noLocA [extra_pred] add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn] lHsQTyVarsToTypes tvs - = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) + = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -332,14 +332,13 @@ data Precedence -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(. -reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) +reparenTypePrec :: forall a. (XRecCond a) => Precedence -> HsType a -> HsType a reparenTypePrec = go where -- Shorter name for 'reparenType' - go :: Precedence -> HsType a -> HsType a + go :: XParTy a ~ ApiAnn' AnnParen => Precedence -> HsType a -> HsType a go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) @@ -361,6 +360,7 @@ reparenTypePrec = go Nothing -> Nothing Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) + -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty) go p (HsFunTy x w ty1 ty2) = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) @@ -378,40 +378,35 @@ reparenTypePrec = go go _ t@XHsType{} = t -- Located variant of 'go' - goL :: Precedence -> LHsType a -> LHsType a + goL :: XParTy a ~ ApiAnn' AnnParen => Precedence -> LHsType a -> LHsType a goL ctxt_prec = mapXRec @a (go ctxt_prec) -- Optionally wrap a type in parens - paren :: Precedence -- Precedence of context + paren :: XParTy a ~ ApiAnn' AnnParen + => Precedence -- Precedence of context -> Precedence -- Precedence of top-level operator -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) - paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a | otherwise = id -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) - => HsType a -> HsType a +reparenType :: XRecCond a => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) - => LHsType a -> LHsType a +reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a reparenLType = mapXRec @a reparenType -- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec') -reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) +reparenSigType :: forall a. ( XRecCond a ) => HsSigType a -> HsSigType a reparenSigType (HsSig x bndrs body) = HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body) reparenSigType v@XHsSigType{} = v -- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec') -reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) +reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a ) => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = @@ -419,8 +414,7 @@ reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) +reparenHsForAllTelescope :: forall a. (XRecCond a ) => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) = HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) @@ -429,17 +423,13 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) = reparenHsForAllTelescope v@XHsForAllTelescope{} = v -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) - => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a - , MapXRec a, UnXRec a, WrapXRec a ) - => ConDeclField a -> ConDeclField a +reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c @@ -449,13 +439,15 @@ reparenConDeclField c@XConDeclField{} = c ------------------------------------------------------------------------------- -unL :: Located a -> a +unL :: GenLocated l a -> a unL (L _ x) = x - -reL :: a -> Located a +reL :: a -> GenLocated l a reL = L undefined +mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b) +mapMA f (L al a) = L (locA al) <$> f a + ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -763,4 +755,4 @@ defaultRuntimeRepVars = go emptyVarEnv go _ ty@(CoercionTy {}) = ty fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI -fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt +fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index b42ae1a3..02e7ed38 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -311,7 +311,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env undocumentedExports :: [String] undocumentedExports = - [ formatName s n + [ formatName (locA s) n | ExportDecl { expItemDecl = L s n , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems 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 diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 83c9dd72..5c6f09a3 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] @@ -46,6 +47,7 @@ import Data.Void (Void) import Documentation.Haddock.Types import GHC.Types.Basic (PromotionFlag(..)) import GHC.Types.Fixity (Fixity(..)) +import GHC.Types.Var (Specificity) import GHC import GHC.Driver.Session (Language) @@ -406,13 +408,13 @@ instance (OutputableBndrId p) -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name - , pfdLName :: Located (IdP name) + , pfdLName :: LocatedN (IdP name) , pfdTyVars :: [LHsType name] , pfdKindSig :: LFamilyResultSig name } -mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p) +mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName @@ -420,12 +422,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl , pfdKindSig = fdResultSig } where - mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p) + mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn mkType (KindedTyVar _ _ (L loc name) lkind) = - HsKindSig noExtField tvar lkind + HsKindSig noAnn tvar lkind where - tvar = L loc (HsTyVar noExtField NotPromoted (L loc name)) - mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name + tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name)) + mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name -- | An instance head that may have documentation and a source location. @@ -694,36 +696,69 @@ liftErrMsg = writer . runWriter -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance XRec DocNameI a = Located a +type instance XRec DocNameI a = GenLocated (Anno a) a instance UnXRec DocNameI where unXRec = unLoc instance MapXRec DocNameI where mapXRec = fmap -instance WrapXRec DocNameI where - wrapXRec = noLoc - -type instance XForAllTy DocNameI = NoExtField -type instance XQualTy DocNameI = NoExtField -type instance XTyVar DocNameI = NoExtField -type instance XStarTy DocNameI = NoExtField -type instance XAppTy DocNameI = NoExtField -type instance XAppKindTy DocNameI = NoExtField -type instance XFunTy DocNameI = NoExtField -type instance XListTy DocNameI = NoExtField -type instance XTupleTy DocNameI = NoExtField -type instance XSumTy DocNameI = NoExtField -type instance XOpTy DocNameI = NoExtField -type instance XParTy DocNameI = NoExtField -type instance XIParamTy DocNameI = NoExtField -type instance XKindSig DocNameI = NoExtField +instance WrapXRec DocNameI (HsType DocNameI) where + wrapXRec = noLocA + +type instance Anno DocName = SrcSpanAnnN +type instance Anno (HsTyVarBndr flag DocNameI) = SrcSpanAnnA +type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC +type instance Anno (HsType DocNameI) = SrcSpanAnnA +type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA +type instance Anno (DerivStrategy DocNameI) = SrcSpan +type instance Anno (FieldOcc DocNameI) = SrcSpan +type instance Anno (ConDeclField DocNameI) = SrcSpan +type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan +type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan +type instance Anno (ConDecl DocNameI) = SrcSpan +type instance Anno (FunDep DocNameI) = SrcSpan +type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA +type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL +type instance Anno (FamilyDecl DocNameI) = SrcSpan +type instance Anno (Sig DocNameI) = SrcSpan +type instance Anno (InjectivityAnn DocNameI) = SrcSpan +type instance Anno (HsDecl DocNameI) = SrcSpanAnnA +type instance Anno (FamilyResultSig DocNameI) = SrcSpan +type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA +type instance Anno (HsSigType DocNameI) = SrcSpanAnnA + +type XRecCond a + = ( XParTy a ~ ApiAnn' AnnParen + -- , XParTy (NoGhcTc a) ~ ApiAnn' AnnParen + -- , NoGhcTcPass (NoGhcTcPass a) ~ NoGhcTcPass a + -- , IsPass a + , NoGhcTc a ~ a + , MapXRec a + , UnXRec a + , WrapXRec a (HsType a) + ) + +type instance XForAllTy DocNameI = ApiAnn +type instance XQualTy DocNameI = ApiAnn +type instance XTyVar DocNameI = ApiAnn +type instance XStarTy DocNameI = ApiAnn +type instance XAppTy DocNameI = ApiAnn +type instance XAppKindTy DocNameI = ApiAnn +type instance XFunTy DocNameI = ApiAnn +type instance XListTy DocNameI = ApiAnn' AnnParen +type instance XTupleTy DocNameI = ApiAnn' AnnParen +type instance XSumTy DocNameI = ApiAnn' AnnParen +type instance XOpTy DocNameI = ApiAnn +type instance XParTy DocNameI = ApiAnn' AnnParen +type instance XIParamTy DocNameI = ApiAnn +type instance XKindSig DocNameI = ApiAnn type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy` -type instance XDocTy DocNameI = NoExtField -type instance XBangTy DocNameI = NoExtField -type instance XRecTy DocNameI = NoExtField -type instance XExplicitListTy DocNameI = NoExtField -type instance XExplicitTupleTy DocNameI = NoExtField -type instance XTyLit DocNameI = NoExtField -type instance XWildCardTy DocNameI = NoExtField +type instance XDocTy DocNameI = ApiAnn +type instance XBangTy DocNameI = ApiAnn +type instance XRecTy DocNameI = ApiAnn +type instance XExplicitListTy DocNameI = ApiAnn +type instance XExplicitTupleTy DocNameI = ApiAnn +type instance XTyLit DocNameI = ApiAnn +type instance XWildCardTy DocNameI = ApiAnn type instance XXType DocNameI = HsCoreTy type instance XHsForAllVis DocNameI = NoExtField @@ -766,6 +801,9 @@ type instance XXFamEqn DocNameI _ = NoExtCon type instance XCClsInstDecl DocNameI = NoExtField type instance XCDerivDecl DocNameI = NoExtField +type instance XStockStrategy DocNameI = NoExtField +type instance XAnyClassStrategy DocNameI = NoExtField +type instance XNewtypeStrategy DocNameI = NoExtField type instance XViaStrategy DocNameI = LHsSigType DocNameI type instance XDataFamInstD DocNameI = NoExtField type instance XTyFamInstD DocNameI = NoExtField @@ -793,3 +831,9 @@ type instance XConDeclField DocNameI = NoExtField type instance XXConDeclField DocNameI = NoExtCon type instance XXPat DocNameI = NoExtCon + +type instance XCInjectivityAnn DocNameI = NoExtField + +type instance XCFunDep DocNameI = NoExtField + +type instance XCTyFamInstDecl DocNameI = NoExtField -- cgit v1.2.3