From b9bf41f6a25239bb2c0780d146ba1f18c061d6d3 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 6 Jan 2018 08:20:43 -0800 Subject: Pass to GHC visible modules for instance filtering The GHC-side `getNameToInstancesIndex` filters out incorrectly some instances because it is not aware of what modules are visible. On the Haddock side, we need to pass in the modules we are processing. On the GHC side, we need to check against _those_ modules when checking if an instance is visible. --- haddock-api/src/Haddock/Interface/AttachInstances.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 2231ce7e..4fd9d264 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -54,7 +54,7 @@ type ExportInfo = (ExportedNames, Modules) -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] attachInstances expInfo ifaces instIfaceMap = do - (_msgs, mb_index) <- getNameToInstancesIndex + (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where -- TODO: take an IfaceMap as input -- cgit v1.2.3 From 271a9cb0c7a070deef8df2d4fb54ebe47a0bf560 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 19 Apr 2018 14:04:04 +0200 Subject: Match changes in GHC for TTG --- haddock-api/src/Haddock/Backends/Hoogle.hs | 21 +-- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 18 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 43 +++--- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 49 ++++--- haddock-api/src/Haddock/Convert.hs | 77 +++++----- haddock-api/src/Haddock/GhcUtils.hs | 44 +++--- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 118 ++++++++-------- haddock-api/src/Haddock/Interface/Rename.hs | 155 ++++++++++++--------- haddock-api/src/Haddock/Interface/Specialize.hs | 6 +- haddock-api/src/Haddock/Types.hs | 124 ++++++++++------- haddock-api/src/Haddock/Utils.hs | 26 ++-- 13 files changed, 386 insertions(+), 299 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 09f62a19..2c7be079 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -126,12 +126,12 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where - f (TyClD d@DataDecl{}) = ppData dflags d subdocs - f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (SigD sig) = ppSig dflags sig ++ ppFixities + f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (SigD _ sig) = ppSig dflags sig ++ ppFixities f _ = [] ppFixities = concatMap (ppFixity dflags) fixities @@ -189,7 +189,7 @@ ppClass dflags decl subdocs = , tcdTyVars = feqn_pats tfe , tcdFixity = feqn_fixity tfe , tcdRhs = feqn_rhs tfe - , tcdFVs = emptyNameSet + , tcdSExt = emptyNameSet } @@ -241,8 +241,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [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 PlaceHolder x y) - apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y) + funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y) + apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -250,7 +250,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $ + resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@(ConDeclGADT { }) @@ -260,6 +260,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con +ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor" ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 19d638d9..56137f51 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC +import qualified Outputable as GHC import Control.Applicative import Control.Monad (guard) @@ -146,9 +147,10 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ _ -> pure . decl $ name - GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.SynDecl _ name _ _ _ -> pure . decl $ name + GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs + GHC.XTyClDecl {} -> GHC.panic "haddock:decls" fun term = case cast term of (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) @@ -159,10 +161,10 @@ decls (group, _, _, _) = concatMap ($ group) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn)) :: GHC.InstDecl GHC.GhcRn)) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of @@ -183,10 +185,10 @@ imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v - (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingWith t _ vs _fls)) -> + (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingWith _ t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4535979e..1b2515fa 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -216,7 +216,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -256,11 +256,11 @@ declNames :: LHsDecl DocNameI , [DocName] -- ^ names being declared ) declNames (L _ decl) = case decl of - TyClD d -> (empty, [tcdName d]) - SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) - SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) - ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) - ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) + TyClD _ d -> (empty, [tcdName d]) + SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) + ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n]) + ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -293,20 +293,20 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD d@FamDecl {} -> ppTyFam False doc d unicode - TyClD d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode - TyClD d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode + TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode + TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now --- TyClD d@TySynonym{} +-- TyClD _ d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode - SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD _ d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ _ -> empty + DerivD _ _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False @@ -318,7 +318,7 @@ ppTyFam _ _ _ _ = ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX -ppFor doc (ForeignImport (L _ name) typ _ _) unicode = +ppFor doc (ForeignImport _ (L _ name) typ _) unicode = ppFunSig doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat [ empty <-> ppSideBySidePat lnames typ d unicode - | (SigD (PatSynSig _ lnames typ), d) <- pats + | (SigD _ (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" @@ -726,6 +726,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -759,6 +760,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ] + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" -- don't use "con_doc con", in case it's reconstructed from a .hi file, @@ -771,13 +773,14 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst +ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" -- | Pretty-print a bundled pattern synonym diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 00937245..464c166b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -663,7 +663,7 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5f253cbd..8ac3d91b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,6 +39,7 @@ import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc ) +import Outputable ( panic ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -54,18 +55,18 @@ ppDecl :: Bool -- ^ print summary info only -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigType lty) fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual - InstD _ -> noHtml - DerivD _ -> noHtml - _ -> error "declaration not supported by ppDecl" + ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + InstD _ _ -> noHtml + DerivD _ _ -> noHtml + _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> @@ -225,7 +226,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities +ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode qual = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -318,12 +319,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ClosedTypeFamily _ -> keyword "where ..." _ -> mempty ) +ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader" ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + NoSig _ -> noHtml + KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + XFamilyResultSig _ -> panic "haddock:ppResultSig" ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html @@ -367,6 +370,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) + ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam" + ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam" @@ -399,6 +404,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) +ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars" -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html @@ -740,13 +746,14 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig _ lnames typ),_) <- pats + | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -772,6 +779,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -793,7 +801,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats patternBit = subPatterns qual [ ppSideBySidePat subfixs unicode qual lnames typ d - | (SigD (PatSynSig _ lnames typ), d) <- pats + | (SigD _ (PatSynSig _ lnames typ), d) <- pats , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities ] @@ -854,6 +862,7 @@ ppShortConstrParts summary dataInst con unicode qual , noHtml , noHtml ) + XConDecl {} -> panic "haddock:ppShortConstrParts" where occ = map (nameOccName . getName . unLoc) $ getConNames con @@ -923,6 +932,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -951,6 +961,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" -- 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. @@ -980,7 +991,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocNameI -> SubDecl -ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) | L _ name <- names , let field = (unLoc . rdrNameFieldOcc) name @@ -994,12 +1005,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst +ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html -ppShortField summary unicode qual (ConDeclField names ltype _) +ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype +ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField" -- | Pretty print an expanded pattern (for bundled patterns) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fd9f0089..b4804758 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert @@ -62,14 +62,14 @@ tyThingToLHsDecl t = case t of -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl d) = return $ noLoc d + extractFamilyDecl (FamDecl _ d) = return $ noLoc d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" @@ -77,7 +77,7 @@ tyThingToLHsDecl t = case t of atFamDecls = map extractFamilyDecl (rights atTyClDecls) tyClErrors = lefts atTyClDecls famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl + in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) @@ -93,20 +93,20 @@ tyThingToLHsDecl t = case t of , tcdATs = rights atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNamesTc } + , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD + -> synifyTyCon Nothing tc >>= allOK . TyClD noExt -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -119,9 +119,10 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType rhs - in HsIB { hsib_vars = map tyVarName tkvs - , hsib_closed = True - , hsib_body = FamEqn { feqn_tycon = name + in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs + , hsib_closed = True } + , hsib_body = FamEqn { feqn_ext = noExt + , feqn_tycon = name , feqn_pats = annot_typats , feqn_fixity = Prefix , feqn_rhs = hs_rhs } } @@ -132,13 +133,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD - $ TyFamInstD + = return $ InstD noExt + $ TyFamInstD noExt $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD + = synifyTyCon (Just ax) tc >>= return . TyClD noExt | otherwise = Left "synifyAxiom: closed/open family confusion" @@ -153,14 +154,17 @@ synifyTyCon _coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_implicit = [] -- No kind polymorphism + in HsQTvs { hsq_ext = + HsQTvsRn { hsq_implicit = [] -- No kind polymorphism + , hsq_dependent = emptyNameSet } , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * - , hsq_dependent = emptyNameSet } + } , tcdFixity = Prefix - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + , tcdDataDefn = HsDataDefn { dd_ext = noExt + , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing @@ -168,8 +172,7 @@ synifyTyCon _coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } - , tcdDataCusk = False - , tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } synifyTyCon _coax tc | Just flav <- famTyConFlav_maybe tc @@ -190,8 +193,9 @@ synifyTyCon _coax tc -> mkFamDecl DataFamily where resultVar = famTcResVar tc - mkFamDecl i = return $ FamDecl $ - FamilyDecl { fdInfo = i + mkFamDecl i = return $ FamDecl noExt $ + FamilyDecl { fdExt = noExt + , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = Prefix @@ -204,11 +208,11 @@ synifyTyCon _coax tc synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc - = return $ SynDecl { tcdLName = synifyName tc + = return $ SynDecl { tcdSExt = emptyNameSet + , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNamesTc } + , tcdRhs = synifyType WithinType ty } | otherwise = -- (closed) newtype and data let @@ -241,7 +245,8 @@ synifyTyCon coax tc cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = noLoc [] - defn = HsDataDefn { dd_ND = alg_nd + defn = HsDataDefn { dd_ext = noExt + , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = fmap synifyKindSig kindSig @@ -251,7 +256,7 @@ synifyTyCon coax tc [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity @@ -264,9 +269,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) = synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = - noLoc $ KindSig (synifyKindSig kind) + noLoc $ KindSig noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc 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 @@ -297,7 +302,7 @@ synifyDataCon use_gadt_syntax dc = field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLoc $ - ConDeclField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy + ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" @@ -311,7 +316,8 @@ synifyDataCon use_gadt_syntax dc = \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_names = [name] + ConDeclGADT { con_g_ext = noExt + , con_names = [name] , con_forall = True , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) , con_mb_cxt = Just ctx @@ -319,7 +325,8 @@ synifyDataCon use_gadt_syntax dc = , con_res_ty = synifyType WithinType res_ty , con_doc = Nothing } else return $ noLoc $ - ConDeclH98 { con_name = name + ConDeclH98 { con_ext = noExt + , con_name = name , con_forall = True , con_ex_tvs = map synifyTyVar ex_tvs , con_mb_cxt = Just ctx @@ -341,9 +348,9 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn -synifyTyVars ktvs = HsQTvs { hsq_implicit = [] - , hsq_explicit = map synifyTyVar ktvs - , hsq_dependent = emptyNameSet } +synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] + , hsq_dependent = emptyNameSet } + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv @@ -546,7 +553,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do - (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls + (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls pure $ mkPseudoFamilyDecl fam } } diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 14111a6a..2d254414 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -47,28 +47,36 @@ isConSym = isLexConSym . occNameFS getMainDeclBinder :: HsDecl name -> [IdP name] -getMainDeclBinder (TyClD d) = [tcdName d] -getMainDeclBinder (ValD d) = +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl +getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) +getInstLoc (DataFamInstD _ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l -getInstLoc (TyFamInstD (TyFamInstDecl +getInstLoc (TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l +getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (XInstDecl _) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" + + -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. @@ -124,16 +132,16 @@ isUserLSig _ = False isClassD :: HsDecl a -> Bool -isClassD (TyClD d) = isClassDecl d +isClassD (TyClD _ d) = isClassDecl d isClassD _ = False isValD :: HsDecl a -> Bool -isValD (ValD _) = True +isValD (ValD _ _) = True isValD _ = False declATs :: HsDecl a -> [IdP a] -declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d +declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = [] @@ -165,13 +173,13 @@ getGADTConType (ConDeclGADT { con_forall = has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -184,6 +192,7 @@ getGADTConType (ConDeclGADT { con_forall = has_forall getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT +getGADTConType (XConDecl {}) = panic "getGADTConType" -- ------------------------------------- @@ -196,13 +205,13 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -213,8 +222,9 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall mkFunTy a b = noLoc (HsFunTy noExt a b) -getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConType" +getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT +getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG" ------------------------------------------------------------------------------- -- * Located @@ -286,7 +296,7 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration parents :: Name -> HsDecl GhcRn -> [Name] -parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 4fd9d264..286907e5 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -87,7 +87,7 @@ attachToExportItem -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c119f3c3..bc93449f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -125,7 +125,7 @@ createInterface tm flags modMap instIfaceMap = do $ map getName instances ++ map getName fam_instances -- Locations of all TH splices - splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] + splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) @@ -406,9 +406,9 @@ mkMaps dflags gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] names :: SrcSpan -> HsDecl GhcRn -> [Name] - names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of - TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs + TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -433,16 +433,16 @@ subordinates :: InstMap -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of - InstD (ClsInstD d) -> do + InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) -> dataSubs (feqn_rhs d) - TyClD d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd @@ -456,7 +456,7 @@ subordinates instMap decl = case decl of | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConArgs cons - , L _ (ConDeclField ns _ doc) <- (unLoc flds) + , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) | HsIB { hsib_body = L l (HsDocTy _ _ doc) } @@ -481,11 +481,11 @@ conArgDocs con = case getConArgs con of -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString -declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) -declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) +declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) declTypeDocs _ = M.empty -- | Extract function argument docs from inside types. @@ -505,10 +505,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs (TyClD . FamDecl) class_ + docs = mkDecls tcdDocs (DocD noExt) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ + sigs = mkDecls tcdSigs (SigD noExt) class_ + ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ -- | The top-level declarations of a module that we care about, @@ -526,14 +526,14 @@ mkFixMap group_ = M.fromList [ (n,f) -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ ++ - mkDecls (valbinds . hs_valds) ValD group_ + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ + mkDecls hs_derivds (DerivD noExt) group_ ++ + mkDecls hs_defds (DefD noExt) group_ ++ + mkDecls hs_fords (ForD noExt) group_ ++ + mkDecls hs_docs (DocD noExt) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExt) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" @@ -564,14 +564,14 @@ sortByLoc = sortBy (comparing getLoc) filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst) where - isHandled (ForD (ForeignImport {})) = True + isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (DerivD {}) = True - isHandled (SigD d) = isUserLSig (reL d) - isHandled (ValD _) = True + isHandled (SigD _ d) = isUserLSig (reL d) + isHandled (ValD {}) = True -- we keep doc declarations to be able to get at named docs - isHandled (DocD _) = True + isHandled (DocD {}) = True isHandled _ = False @@ -580,8 +580,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where - filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } + filterClass (TyClD x c) = + TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -600,10 +600,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD (DocCommentNext str)) : ds) + go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds + go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -644,22 +644,22 @@ mkExportItems decls maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do + lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do doc <- processDocString dflags gre docStr return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr, _) = liftErrMsg $ do + lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEDocNamed str, _) = liftErrMsg $ + lookupExport (IEDocNamed _ str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEModuleContents (L _ mod_name), _) + lookupExport (IEModuleContents _ (L _ mod_name), _) -- only consider exporting a module if we are sure we -- are really exporting the whole module and not some -- subset. We also look through module aliases here. @@ -696,7 +696,7 @@ 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 -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] @@ -721,17 +721,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames -- A single signature might refer to many names, but we -- create an export item for a single name only. So we -- modify the signature to contain only that single name. - L loc (SigD sig) -> + L loc (SigD _ sig) -> -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. - let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig + let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD cl@ClassDecl{}) -> do + L loc (TyClD _ cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_ _ -> availExportDecl avail decl docs_ @@ -994,7 +994,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames for (getMainDeclBinder (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of Just avail - | L _ (ValD valDecl) <- decl + | L _ (ValD _ valDecl) <- decl , (name:_) <- collectHsBindBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> pure [] @@ -1017,7 +1017,7 @@ extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of - TyClD d@ClassDecl {} -> + TyClD _ d@ClassDecl {} -> let matchesMethod = [ lsig @@ -1037,8 +1037,8 @@ extractDecl declMap name decl in case (matchesMethod, matchesAssociatedType) of ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) - (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + in L pos (SigD noExt sig) + (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl)) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap @@ -1047,21 +1047,21 @@ extractDecl declMap name decl O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) - TyClD d@DataDecl {} -> + TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) - else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) - TyClD FamDecl {} + then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_pats = tys , feqn_rhs = defn }}))) -> - SigD <$> extractRecSel name n tys (dd_cons defn) - InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> + SigD noExt <$> extractRecSel name n tys (dd_cons defn) + InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) @@ -1071,7 +1071,7 @@ extractDecl declMap name decl , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" @@ -1112,12 +1112,12 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of - RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] - matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds , L l n <- ns, extFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty @@ -1142,8 +1142,8 @@ mkVisibleNames (_, _, _, instMap) exports opts where subs = map fst (expItemSubDocs e) patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of - InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap - decl -> getMainDeclBinder decl + InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -1184,7 +1184,7 @@ findNamedDoc name = search search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search (DocD (DocCommentNamed name' doc) : rest) + search (DocD _ (DocCommentNamed name' doc) : rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0652ae47..5b588964 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -21,6 +21,7 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name +import Outputable ( panic ) import Control.Applicative import Control.Monad hiding (mapM) @@ -188,14 +189,15 @@ renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) -renameFamilyResultSig (L loc NoSig) - = return (L loc NoSig) -renameFamilyResultSig (L loc (KindSig ki)) +renameFamilyResultSig (L loc (NoSig _)) + = return (L loc (NoSig noExt)) +renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki - ; return (L loc (KindSig ki')) } -renameFamilyResultSig (L loc (TyVarSig bndr)) + ; return (L loc (KindSig noExt ki')) } +renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr - ; return (L loc (TyVarSig bndr')) } + ; return (L loc (TyVarSig noExt bndr')) } +renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig" renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -212,55 +214,55 @@ renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy PlaceHolder a' b') + return (HsAppTy NoExt a' b') HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy PlaceHolder a' b') + return (HsFunTy NoExt a' b') - HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty - HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty - HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty) - HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2) + HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty + HsPArrTy _ ty -> return . (HsPArrTy NoExt) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) + HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy NoExt) (renameLType ty1) (renameLType ty2) - HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy PlaceHolder a' (L loc op') b') + return (HsOpTy NoExt a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig PlaceHolder ty' k') + return (HsKindSig NoExt ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy PlaceHolder ty' doc') + return (HsDocTy NoExt ty' doc') - HsTyLit _ x -> return (HsTyLit PlaceHolder x) + HsTyLit _ x -> return (HsTyLit NoExt x) - HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a + HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b @@ -269,10 +271,11 @@ renameType t = case t of HsAppsTy _ _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) -renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) +renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } - -- This is rather bogus, but I'm not sure what else to do + ; return (HsQTvs { hsq_ext = noExt + , hsq_explicit = tvs' }) } +renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars" renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar x (L l n))) @@ -289,8 +292,8 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) -renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo +renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name)) renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do @@ -321,21 +324,21 @@ renamePats = mapM renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of - TyClD d -> do + TyClD _ d -> do d' <- renameTyClD d - return (TyClD d') - SigD s -> do + return (TyClD noExt d') + SigD _ s -> do s' <- renameSig s - return (SigD s') - ForD d -> do + return (SigD noExt s') + ForD _ d -> do d' <- renameForD d - return (ForD d') - InstD d -> do + return (ForD noExt d') + InstD _ d -> do d' <- renameInstD d - return (InstD d') - DerivD d -> do + return (InstD noExt d') + DerivD _ d -> do d' <- renameDerivD d - return (DerivD d') + return (DerivD noExt d') _ -> error "renameDecl" renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) @@ -346,19 +349,21 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl - return (FamDecl { tcdFam = decl' }) + return (FamDecl { tcdFExt = noExt, tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames }) + return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdRhs = rhs' }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) + return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -373,7 +378,8 @@ renameTyClD d = case d of return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt }) + XTyClDecl _ -> panic "haddock:renameTyClD" where renameLFunDep (L loc (xs, ys)) = do @@ -394,11 +400,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) +renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl" renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -424,9 +431,11 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType + return (HsDataDefn { dd_ext = noExt + , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) +renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn" renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -437,7 +446,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_ex_tvs = ltyvars' + return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_args = details', con_doc = mbldoc' }) @@ -451,9 +460,10 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars details' <- renameDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars' + return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) +renameCon (XConDecl _) = panic "haddock:renameCon" renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do @@ -466,11 +476,12 @@ renameDetails (InfixCon a b) = do return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) -renameConDeclFieldField (L l (ConDeclField names t doc)) = do +renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField names' t' doc') + return $ L l (ConDeclField noExt names' t' doc') +renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField" renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -503,35 +514,39 @@ renameSig sig = case sig of renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) -renameForD (ForeignImport lname ltype co x) = do +renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignImport lname' ltype' co x) -renameForD (ForeignExport lname ltype co x) = do + return (ForeignImport noExt lname' ltype' x) +renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignExport lname' ltype' co x) + return (ForeignExport noExt lname' ltype' x) +renameForD (XForeignDecl _) = panic "haddock:renameForD" renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d - return (ClsInstD { cid_inst = d' }) + return (ClsInstD { cid_d_ext = noExt, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d - return (TyFamInstD { tfid_inst = d' }) + return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d - return (DataFamInstD { dfid_inst = d' }) + return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' }) +renameInstD (XInstDecl _) = panic "haddock:renameInstD" renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do ty' <- renameLSigWcType ty - return (DerivDecl { deriv_type = ty' + return (DerivDecl { deriv_ext = noExt + , deriv_type = ty' , deriv_strategy = strat , deriv_overlap_mode = omode }) +renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD" renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode @@ -540,10 +555,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_overlap_mode = omode + return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) +renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD" renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -563,10 +579,12 @@ renameTyFamInstEqn eqn = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } + rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn" renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs @@ -574,10 +592,12 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs - ; return (L loc (FamEqn { feqn_tycon = tc' + ; return (L loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = tvs' , feqn_fixity = fixity , feqn_rhs = rhs' })) } +renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn" renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) @@ -592,10 +612,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; defn' <- renameDataDefn defn - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } + rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD" renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -603,8 +625,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder }) } + , hsib_ext = noExt }) } +renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit" renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -612,7 +634,8 @@ renameWc :: (in_thing -> RnM out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder }) } + , hswc_ext = noExt }) } +renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc" renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index b84a676f..c49663db 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -110,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) - | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp + | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp where name' = getName name strName = occNameString . nameOccName $ name' @@ -124,7 +124,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 PlaceHolder HsBoxedTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -137,7 +137,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb where name' = getName name sugarOperators typ = typ diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 2234894c..99fccf2a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -381,11 +381,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl } where mkType (KindedTyVar _ (L loc name) lkind) = - HsKindSig PlaceHolder tvar lkind + HsKindSig NoExt tvar lkind where - tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name)) - mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name + tvar = L loc (HsTyVar NoExt NotPromoted (L loc name)) + mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" +mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl" -- | An instance head that may have documentation and a source location. @@ -652,54 +653,77 @@ instance Monad ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocNameI NameSet = PlaceHolder -type instance PostRn DocNameI Fixity = PlaceHolder -type instance PostRn DocNameI Bool = PlaceHolder -type instance PostRn DocNameI Name = DocName -type instance PostRn DocNameI (Located Name) = Located DocName -type instance PostRn DocNameI [Name] = PlaceHolder -type instance PostRn DocNameI DocName = DocName - -type instance PostTc DocNameI Kind = PlaceHolder -type instance PostTc DocNameI Type = PlaceHolder -type instance PostTc DocNameI Coercion = PlaceHolder - - -type instance XForAllTy DocNameI = PlaceHolder -type instance XQualTy DocNameI = PlaceHolder -type instance XTyVar DocNameI = PlaceHolder -type instance XAppsTy DocNameI = PlaceHolder -type instance XAppTy DocNameI = PlaceHolder -type instance XFunTy DocNameI = PlaceHolder -type instance XListTy DocNameI = PlaceHolder -type instance XPArrTy DocNameI = PlaceHolder -type instance XTupleTy DocNameI = PlaceHolder -type instance XSumTy DocNameI = PlaceHolder -type instance XOpTy DocNameI = PlaceHolder -type instance XParTy DocNameI = PlaceHolder -type instance XIParamTy DocNameI = PlaceHolder -type instance XEqTy DocNameI = PlaceHolder -type instance XKindSig DocNameI = PlaceHolder -type instance XSpliceTy DocNameI = PlaceHolder -type instance XDocTy DocNameI = PlaceHolder -type instance XBangTy DocNameI = PlaceHolder -type instance XRecTy DocNameI = PlaceHolder -type instance XExplicitListTy DocNameI = PlaceHolder -type instance XExplicitTupleTy DocNameI = PlaceHolder -type instance XTyLit DocNameI = PlaceHolder -type instance XWildCardTy DocNameI = HsWildCardInfo DocNameI +type instance XForAllTy DocNameI = NoExt +type instance XQualTy DocNameI = NoExt +type instance XTyVar DocNameI = NoExt +type instance XAppsTy DocNameI = NoExt +type instance XAppTy DocNameI = NoExt +type instance XFunTy DocNameI = NoExt +type instance XListTy DocNameI = NoExt +type instance XPArrTy DocNameI = NoExt +type instance XTupleTy DocNameI = NoExt +type instance XSumTy DocNameI = NoExt +type instance XOpTy DocNameI = NoExt +type instance XParTy DocNameI = NoExt +type instance XIParamTy DocNameI = NoExt +type instance XEqTy DocNameI = NoExt +type instance XKindSig DocNameI = NoExt +type instance XSpliceTy DocNameI = NoExt +type instance XDocTy DocNameI = NoExt +type instance XBangTy DocNameI = NoExt +type instance XRecTy DocNameI = NoExt +type instance XExplicitListTy DocNameI = NoExt +type instance XExplicitTupleTy DocNameI = NoExt +type instance XTyLit DocNameI = NoExt +type instance XWildCardTy DocNameI = HsWildCardInfo type instance XXType DocNameI = NewHsTypeX -type instance XUserTyVar DocNameI = PlaceHolder -type instance XKindedTyVar DocNameI = PlaceHolder -type instance XXTyVarBndr DocNameI = PlaceHolder +type instance XUserTyVar DocNameI = NoExt +type instance XKindedTyVar DocNameI = NoExt +type instance XXTyVarBndr DocNameI = NoExt type instance XFieldOcc DocNameI = DocName -type instance XXFieldOcc DocNameI = PlaceHolder - -type instance XFixitySig DocNameI = PlaceHolder -type instance XFixSig DocNameI = PlaceHolder -type instance XPatSynSig DocNameI = PlaceHolder -type instance XClassOpSig DocNameI = PlaceHolder -type instance XTypeSig DocNameI = PlaceHolder -type instance XMinimalSig DocNameI = PlaceHolder +type instance XXFieldOcc DocNameI = NoExt + +type instance XFixitySig DocNameI = NoExt +type instance XFixSig DocNameI = NoExt +type instance XPatSynSig DocNameI = NoExt +type instance XClassOpSig DocNameI = NoExt +type instance XTypeSig DocNameI = NoExt +type instance XMinimalSig DocNameI = NoExt + +type instance XForeignExport DocNameI = NoExt +type instance XForeignImport DocNameI = NoExt +type instance XConDeclGADT DocNameI = NoExt +type instance XConDeclH98 DocNameI = NoExt + +type instance XDerivD DocNameI = NoExt +type instance XInstD DocNameI = NoExt +type instance XForD DocNameI = NoExt +type instance XSigD DocNameI = NoExt +type instance XTyClD DocNameI = NoExt + +type instance XNoSig DocNameI = NoExt +type instance XCKindSig DocNameI = NoExt +type instance XTyVarSig DocNameI = NoExt + +type instance XCFamEqn DocNameI _ _ = NoExt + +type instance XCClsInstDecl DocNameI = NoExt +type instance XCDerivDecl DocNameI = NoExt +type instance XDataFamInstD DocNameI = NoExt +type instance XTyFamInstD DocNameI = NoExt +type instance XClsInstD DocNameI = NoExt +type instance XCHsDataDefn DocNameI = NoExt +type instance XCFamilyDecl DocNameI = NoExt +type instance XClassDecl DocNameI = NoExt +type instance XDataDecl DocNameI = NoExt +type instance XSynDecl DocNameI = NoExt +type instance XFamDecl DocNameI = NoExt + +type instance XHsIB DocNameI _ = NoExt +type instance XHsWC DocNameI _ = NoExt + +type instance XHsQTvs DocNameI = NoExt +type instance XConDeclField DocNameI = NoExt + diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 1ebf7ffa..e3cc9655 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -64,6 +64,7 @@ import GHC import Name import NameSet ( emptyNameSet ) import HsTypes (extFieldOcc) +import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -152,7 +153,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -162,10 +163,10 @@ lHsQTyVarsToTypes tvs restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl @@ -178,6 +179,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] @@ -195,9 +197,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] InfixCon _ _ -> Just d where field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField fs _ _)) + field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ t | ConDeclField _ t _ <- flds ] + field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail" + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing @@ -208,13 +211,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsQTyVars Name +emptyHsQTvs :: LHsQTyVars GhcRn -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" - , hsq_explicit = [] - , hsq_dependent = error "haddock:emptyHsQTvs" } +emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_dependent = error "haddock:emptyHsQTvs" } + , hsq_explicit = [] } -------------------------------------------------------------------------------- -- cgit v1.2.3