diff options
author | Ben Gamari <ben@smart-cactus.org> | 2017-11-21 15:52:15 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-11-21 16:36:06 -0500 |
commit | ae0d140334fff57f2737dbd7c5804b4868d9c3ab (patch) | |
tree | 3f1ef4707ddf7fb79737643a9b4175a89e302247 /haddock-api | |
parent | be45ddae4e2f7d971f2166d9a8fe45402ddcb3c1 (diff) |
Revert "Match changes for Trees that Grow in GHC"
This reverts commit 01eeeb048acd2dd05ff6471ae148a97cf0720547.
Diffstat (limited to 'haddock-api')
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 40 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 12 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 50 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 69 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 59 | ||||
-rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 30 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 72 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 164 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Types.hs | 49 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Utils.hs | 15 |
11 files changed, 262 insertions, 300 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index ae993aba..f1d8ddb2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -73,22 +73,22 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy x a e) = HsForAllTy x a (g e) - f (HsQualTy x a e) = HsQualTy x a (g e) - f (HsBangTy x a b) = HsBangTy x a (g b) - f (HsAppTy x a b) = HsAppTy x (g a) (g b) - f (HsFunTy x a b) = HsFunTy x (g a) (g b) - f (HsListTy x a) = HsListTy x (g a) - f (HsPArrTy x a) = HsPArrTy x (g a) - f (HsTupleTy x a b) = HsTupleTy x a (map g b) - f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) - f (HsParTy x a) = HsParTy x (g a) - f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unL a + f (HsForAllTy a e) = HsForAllTy a (g e) + f (HsQualTy a e) = HsQualTy a (g e) + f (HsBangTy a b) = HsBangTy a (g b) + f (HsAppTy a b) = HsAppTy (g a) (g b) + f (HsFunTy a b) = HsFunTy (g a) (g b) + f (HsListTy a) = HsListTy (g a) + f (HsPArrTy a) = HsPArrTy (g a) + f (HsTupleTy a b) = HsTupleTy a (map g b) + f (HsOpTy a b c) = HsOpTy (g a) b (g c) + f (HsParTy a) = HsParTy (g a) + f (HsKindSig a b) = HsKindSig (g a) b + f (HsDocTy a _) = f $ unL a f x = x -outHsType :: (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a)) - => DynFlags -> HsType (GhcPass a) -> String +outHsType :: (SourceTextX a, OutputableBndrId a) + => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -236,12 +236,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ - [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (selectorFieldOcc . 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 x y) + apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -249,8 +249,8 @@ 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) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {} = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 9388e5c9..57ff72ff 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -99,7 +99,7 @@ types :: GHC.RenamedSource -> LTokenDetails types = everythingInRenamedSource ty where ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty @@ -118,11 +118,11 @@ binds = everythingInRenamedSource pure (sspan, RtkBind name) _ -> empty pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs - (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty rec term = case cast term of @@ -130,9 +130,9 @@ binds = everythingInRenamedSource pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -167,7 +167,7 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty fld term = case cast term of Just (field :: GHC.ConDeclField GHC.GhcRn) - -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field + -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty sig (GHC.L _ (GHC.TypeSig names _)) = map decl names sig _ = [] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 856a5f38..d79e0e6c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -389,15 +389,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX - do_args _n leader (HsForAllTy _ tvs ltype) + do_args _n leader (HsForAllTy tvs ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) <+> ppLType unicode ltype - do_args n leader (HsQualTy _ lctxt ltype) + do_args n leader (HsQualTy lctxt ltype) = decltt leader <-> ppLContextNoArrow lctxt unicode <+> nl $$ do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ lt r) + do_args n leader (HsFunTy lt r) = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ do_largs (n+1) (arrow unicode) r do_args n leader t @@ -764,7 +764,7 @@ ppSideBySideField subdocs unicode (ConDeclField names ltype _) = 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 + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -957,57 +957,57 @@ ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot , ppr_mono_lty pREC_TOP ty unicode ] -ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ sep [ ppLContext ctxt unicode , ppr_mono_lty pREC_TOP ty unicode ] -ppr_mono_ty _ (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name -ppr_mono_ty _ (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig _ ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) -ppr_mono_ty _ (HsListTy _ ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy _ ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name +ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u +ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys) +ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" -ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys -ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode -ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op occName = nameOccName . getName . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode +ppr_mono_ty ctxt_prec (HsParTy ty) unicode -- = parens (ppr_mono_lty pREC_TOP ty) = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u +ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index eb7705d1..3b85f96c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -123,19 +123,19 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy _ tvs ltype) + do_args n leader (HsForAllTy tvs ltype) = do_largs n leader' ltype where leader' = leader <+> ppForAll tvs unicode qual - do_args n leader (HsQualTy _ lctxt ltype) + do_args n leader (HsQualTy lctxt ltype) | null (unLoc lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ lt r) + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t @@ -143,7 +143,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -891,7 +891,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = 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 >>= combineDocumentation . fst + mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html @@ -978,12 +978,11 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual e ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html -ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = +ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = ppDocName qual Raw False name -ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = +ppHsTyVarBndr unicode qual (KindedTyVar name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) -ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr" ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) @@ -1002,16 +1001,16 @@ ppPatSigType unicode qual typ = hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = case unLoc t of - HsForAllTy _ _ s -> hasNonEmptyContext s - HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True - HsFunTy _ _ s -> hasNonEmptyContext s + HsForAllTy _ s -> hasNonEmptyContext s + HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of - HsForAllTy _ _ s -> isFirstContextEmpty s - HsQualTy _ cxt _ -> null (unLoc cxt) - HsFunTy _ _ s -> isFirstContextEmpty s + HsForAllTy _ s -> isFirstContextEmpty s + HsQualTy cxt _ -> null (unLoc cxt) + HsFunTy _ s -> isFirstContextEmpty s _ -> False ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html @@ -1022,50 +1021,50 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode qual emptyCtxts +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode qual emptyCtxts +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar _ _ (L _ name)) True _ _ +ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _ (HsBangTy _ b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty _ (HsTyVar _ _ (L _ name)) _ q _ = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e -ppr_mono_ty _ (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) -ppr_mono_ty _ (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) -ppr_mono_ty _ (HsKindSig _ ty kind) u q e = +ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e +ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q e = parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy _ ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) -ppr_mono_ty _ (HsPArrTy _ ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) -ppr_mono_ty ctxt_prec (HsIParamTy _ (L _ n) ty) u q _ = +ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy" -ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode qual _ +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _ = maybeParen ctxt_prec pREC_CTX $ ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts -ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode qual _ +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _ = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] -ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode qual _ +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts where @@ -1076,15 +1075,15 @@ ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode qual _ | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode qual emptyCtxts +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts -- = parens (ppr_mono_lty pREC_TOP ty) = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode qual emptyCtxts +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' -ppr_mono_ty _ (HsTyLit _ n) _ _ _ = ppr_tylit n +ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 0e57ab42..fc808568 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -151,7 +151,7 @@ synifyTyCon _coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) + = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) in HsQTvs { hsq_implicit = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) @@ -266,7 +266,7 @@ synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = noLoc $ KindSig (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig (noLoc $ KindedTyVar (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 @@ -296,12 +296,12 @@ synifyDataCon use_gadt_syntax dc = let tySyn = synifyType WithinType ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn - bang' -> noLoc $ HsBangTy noExt bang' tySyn) + bang' -> noLoc $ HsBangTy bang' tySyn) arg_tys (dataConSrcBangs 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 [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" @@ -347,8 +347,8 @@ synifyTyVars ktvs = HsQTvs { hsq_implicit = [] synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name)) - | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) + | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -365,7 +365,7 @@ annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType ki - in noLoc (HsKindSig noExt hs_ty hs_ki) + in noLoc (HsKindSig hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every type variable in the input, @@ -410,7 +410,7 @@ synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) synifyType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) = maybe_sig res_ty where @@ -420,42 +420,41 @@ synifyType _ (TyConApp tc tys) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` liftedRepDataConKey - = noLoc (HsTyVar noExt NotPromoted (noLoc starKindTyConName)) + = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys - = noLoc $ HsTupleTy noExt - (case sort of + = noLoc $ HsTupleTy (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy noExt (synifyType WithinType ty) + noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty) + = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) -- and equalities | tc `hasKey` eqTyConKey - , [ty1, ty2] <- vis_tys - = noLoc $ HsEqTy noExt (synifyType WithinType ty1) (synifyType WithinType ty2) + , [ty1, ty2] <- tys + = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys - = mk_app_tys (HsOpTy noExt (synifyType WithinType ty1) - (noLoc $ getName tc) - (synifyType WithinType ty2)) + = mk_app_tys (HsOpTy (synifyType WithinType ty1) + (noLoc $ getName tc) + (synifyType WithinType ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc)) + = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc)) vis_tys where mk_app_tys ty_app ty_args = - foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2) + foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2) (noLoc ty_app) (map (synifyType WithinType) $ filterOut isCoercionTy ty_args) @@ -469,7 +468,7 @@ synifyType _ (TyConApp tc tys) | needs_kind_sig = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType full_kind - in noLoc $ HsKindSig noExt ty' full_kind' + in noLoc $ HsKindSig ty' full_kind' | otherwise = ty' needs_kind_sig :: Bool @@ -490,24 +489,22 @@ synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 - in noLoc $ HsAppTy noExt s1 s2 + in noLoc $ HsAppTy s1 s2 synifyType _ (FunTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 - in noLoc $ HsFunTy noExt s1 s2 + in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_xqual = noExt , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt , hst_body = noLoc sPhi } ImplicitizeForAll -> noLoc sPhi -synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t +synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" @@ -520,12 +517,10 @@ synifyPatSynType ps = let -- possible by taking theta = [], as that will print no context at all | otherwise = req_theta sForAll [] s = s - sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_xqual = noExt - , hst_body = noLoc s } + sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_body = noLoc s } + sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta + , hst_body = noLoc s } sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 1999be76..a1009c1f 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -180,7 +180,7 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = case getConDetails con of - RecCon fields -> map (extFieldOcc . unL) $ + RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c6a67af0..27456998 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -454,12 +454,12 @@ subordinates instMap decl = case decl of cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) + fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) - | HsIB { hsib_body = L l (HsDocTy _ _ doc) } + | HsIB { hsib_body = L l (HsDocTy _ doc) } <- concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] @@ -478,9 +478,9 @@ typeDocs d = where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc + go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty + go n (HsFunTy _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ (L _ doc)) = M.singleton n doc go _ _ = M.empty @@ -1031,7 +1031,7 @@ extractDecl name decl , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , extFieldOcc n == name + , selectorFieldOcc n == name ] in case matches of [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) @@ -1057,18 +1057,17 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy PlaceHolder cxt typ) + ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) _ -> typ - typ'' = noLoc (HsQualTy PlaceHolder (noLoc []) typ') + typ'' = noLoc (HsQualTy (noLoc []) typ') in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: [LHsType (GhcPass name)] -> LHsType (GhcPass name) -> LHsType (GhcPass name) - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy PlaceHolder x y)) output inputs + longArrow :: [LHsType name] -> LHsType name -> LHsType name + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs data_ty con | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y)) - (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn @@ -1077,17 +1076,16 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConDetails con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy PlaceHolder data_ty (getBangType ty))))) + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds - , L l n <- ns, extFieldOcc n == nm ] + , L l n <- ns, selectorFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y)) - (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | 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 c7e4f6f8..7023a908 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -212,61 +212,61 @@ 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_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_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 ip . L l =<< rename n + HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype - HsAppTy _ a b -> do + HsAppTy a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy PlaceHolder a' b') + return (HsAppTy a' b') - HsFunTy _ a b -> do + HsFunTy a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy PlaceHolder a' b') + return (HsFunTy 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 =<< renameLType ty + HsPArrTy ty -> return . HsPArrTy =<< renameLType ty + HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) + HsEqTy ty1 ty2 -> liftM2 HsEqTy (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 b =<< mapM renameLType ts + HsSumTy ts -> HsSumTy <$> mapM renameLType ts - HsOpTy _ a (L loc op) b -> do + 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 a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty + HsParTy ty -> return . HsParTy =<< renameLType ty - HsKindSig _ ty k -> do + HsKindSig ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig PlaceHolder ty' k') + return (HsKindSig ty' k') - HsDocTy _ ty doc -> do + HsDocTy ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy PlaceHolder ty' doc') + return (HsDocTy ty' doc') - HsTyLit _ x -> return (HsTyLit PlaceHolder x) + HsTyLit x -> return (HsTyLit x) - HsRecTy _ a -> HsRecTy PlaceHolder <$> 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 - HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a - HsAppsTy _ _ -> error "renameType: HsAppsTy" + HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a + HsCoreTy a -> pure (HsCoreTy a) + HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b + HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b + HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) @@ -275,14 +275,13 @@ renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) -renameLTyVarBndr (L loc (UserTyVar x (L l n))) +renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar x (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) + ; return (L loc (UserTyVar (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar x (L lv n') kind')) } -renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr" + ; return (L loc (KindedTyVar (L lv n') kind')) } renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -467,10 +466,9 @@ renameConDeclFieldField (L l (ConDeclField names t doc)) = do return $ L l (ConDeclField names' t' doc') renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) -renameLFieldOcc (L l (FieldOcc sel lbl)) = do +renameLFieldOcc (L l (FieldOcc lbl sel)) = do sel' <- rename sel - return $ L l (FieldOcc sel' lbl) -renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" + return $ L l (FieldOcc lbl sel') renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 0cac818d..6d2888d3 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -28,19 +28,20 @@ import Data.Set (Set) import qualified Data.Set as Set -- | Instantiate all occurrences of given names with corresponding types. -specialize :: Data a - => [(Name, HsType GhcRn)] -> a -> a +specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)) + => Data a + => [(IdP name, HsType name)] -> a -> a specialize specs = go where go :: forall x. Data x => x -> x - go = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var + go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var strip_kind_sig :: HsType name -> HsType name - strip_kind_sig (HsKindSig _ (L _ t) _) = t + strip_kind_sig (HsKindSig (L _ t) _) = t strip_kind_sig typ = typ - specialize_ty_var :: HsType GhcRn -> HsType GhcRn - specialize_ty_var (HsTyVar _ _ (L _ name')) + specialize_ty_var :: HsType name -> HsType name + specialize_ty_var (HsTyVar _ (L _ name')) | Just t <- Map.lookup name' spec_map = t specialize_ty_var typ = typ -- This is a tricky recursive definition that is guaranteed to terminate @@ -53,33 +54,35 @@ specialize specs = go -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: Data a - => LHsQTyVars GhcRn -> [HsType GhcRn] +specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name)) + => Data a + => LHsQTyVars name -> [HsType name] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar _ (L _ name)) = name - bname (KindedTyVar _ (L _ name) _) = name - bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" + bname (UserTyVar (L _ name)) = name + bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] - -> PseudoFamilyDecl GhcRn - -> PseudoFamilyDecl GhcRn +specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name)) + => LHsQTyVars name -> [HsType name] + -> PseudoFamilyDecl name + -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl = decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] - -> Sig GhcRn - -> Sig GhcRn +specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) + => LHsQTyVars name -> [HsType name] + -> Sig name + -> Sig name specializeSig bndrs typs (TypeSig lnames typ) = TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where - true_type :: HsType GhcRn + true_type :: HsType name true_type = unLoc (hsSigWcType typ) - typ' :: HsType GhcRn + typ' :: HsType name typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig @@ -87,7 +90,8 @@ specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: InstHead GhcRn -> InstHead GhcRn +specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) + => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } where @@ -106,26 +110,27 @@ specializeInstHead ihd = ihd -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: HsType GhcRn -> HsType GhcRn +sugar :: forall name. (NamedThing (IdP name), DataId name) + => HsType name -> HsType name 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 +sugarLists :: NamedThing (IdP name) => HsType name -> HsType name +sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name strName = occNameString . nameOccName $ name' sugarLists typ = typ -sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name sugarTuples typ = aux [] typ where - 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 + 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 HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -135,10 +140,10 @@ sugarTuples typ = aux _ _ = typ -sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) -sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) +sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name +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 la lb where name' = getName name sugarOperators typ = typ @@ -203,15 +208,15 @@ setInternalOccName occ name = -- | Compute set of free variables of given type. -freeVariables :: forall p. (NamedThing (IdP p), DataId p, Typeable p) - => HsType p -> Set Name +freeVariables :: forall name. (NamedThing (IdP name), DataId name) + => HsType name -> Set Name freeVariables = everythingWithState Set.empty Set.union query where - query term ctx = case cast term :: Maybe (HsType p) of - Just (HsForAllTy _ bndrs _) -> + query term ctx = case cast term :: Maybe (HsType name) of + Just (HsForAllTy bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar _ _ (L _ name)) + Just (HsTyVar _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) @@ -226,7 +231,8 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: Set Name -> HsType GhcRn -> HsType GhcRn +rename :: (Eq (IdP name), DataId name, SetName (IdP name)) + => Set Name-> HsType name -> HsType name rename fv typ = evalState (renameType typ) env where env = RenameEnv @@ -246,58 +252,63 @@ data RenameEnv name = RenameEnv } -renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) -renameType (HsForAllTy x bndrs lt) = - HsForAllTy x +renameType :: (Eq (IdP name), SetName (IdP name)) + => HsType name -> Rename (IdP name) (HsType name) +renameType (HsForAllTy bndrs lt) = + HsForAllTy <$> mapM (located renameBinder) bndrs <*> renameLType lt -renameType (HsQualTy x lctxt lt) = - HsQualTy x +renameType (HsQualTy lctxt lt) = + HsQualTy <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name -renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la -renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr -renameType (HsListTy x lt) = HsListTy x <$> renameLType lt -renameType (HsPArrTy x lt) = HsPArrTy 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 -renameType (HsParTy x lt) = HsParTy x <$> renameLType lt -renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt -renameType (HsEqTy x la lb) = HsEqTy x <$> renameLType la <*> renameLType lb -renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk +renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name +renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la +renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr +renameType (HsListTy lt) = HsListTy <$> renameLType lt +renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt +renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt +renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt +renameType (HsOpTy la lop lb) = + HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb +renameType (HsParTy lt) = HsParTy <$> renameLType lt +renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt +renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb +renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk renameType t@(HsSpliceTy _ _) = pure t -renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc -renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt -renameType t@(HsRecTy _ _) = pure t -renameType t@(XHsType (NHsCoreTy _)) = pure t -renameType (HsExplicitListTy x ip ltys) = - HsExplicitListTy x ip <$> renameLTypes ltys -renameType (HsExplicitTupleTy x ltys) = - HsExplicitTupleTy x <$> renameLTypes ltys -renameType t@(HsTyLit _ _) = pure t +renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc +renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt +renameType t@(HsRecTy _) = pure t +renameType t@(HsCoreTy _) = pure t +renameType (HsExplicitListTy ip ph ltys) = + HsExplicitListTy ip ph <$> renameLTypes ltys +renameType (HsExplicitTupleTy phs ltys) = + HsExplicitTupleTy phs <$> renameLTypes ltys +renameType t@(HsTyLit _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) -renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming" +renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" -renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) +renameLType :: (Eq (IdP name), SetName (IdP name)) + => LHsType name -> Rename (IdP name) (LHsType name) renameLType = located renameType -renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] +renameLTypes :: (Eq (IdP name), SetName (IdP name)) + => [LHsType name] -> Rename (IdP name) [LHsType name] renameLTypes = mapM renameLType -renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) +renameContext :: (Eq (IdP name), SetName (IdP name)) + => HsContext name -> Rename (IdP name) (HsContext name) renameContext = renameLTypes -renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) -renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname -renameBinder (KindedTyVar x lname lkind) = - KindedTyVar x <$> located renameName lname <*> located renameType lkind -renameBinder (XTyVarBndr _) = error "haddock:renameBinder" +renameBinder :: (Eq (IdP name), SetName (IdP name)) + => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name) +renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname +renameBinder (KindedTyVar lname lkind) = + KindedTyVar <$> located renameName lname <*> located renameType lkind + -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -352,6 +363,5 @@ located f (L loc e) = L loc <$> f e tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar _ name) = unLoc name -tyVarName (KindedTyVar _ (L _ name) _) = name -tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" +tyVarName (UserTyVar name) = unLoc name +tyVarName (KindedTyVar (L _ name) _) = name diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index f0f1b2f4..b4cdc343 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -348,8 +347,8 @@ data InstType name | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a)) - => Outputable (InstType (GhcPass a)) where +instance (SourceTextX a, OutputableBndrId a) + => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx <+> ppr clsiTyVars @@ -373,7 +372,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl } -mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p) +mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName @@ -381,12 +380,11 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl , pfdKindSig = fdResultSig } where - mkType (KindedTyVar _ (L loc name) lkind) = - HsKindSig PlaceHolder tvar lkind + mkType (KindedTyVar (L loc name) lkind) = + HsKindSig tvar lkind where - tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name)) - mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name - mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" + tvar = L loc (HsTyVar NotPromoted (L loc name)) + mkType (UserTyVar name) = HsTyVar NotPromoted name -- | An instance head that may have documentation and a source location. @@ -664,36 +662,3 @@ 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 XXType DocNameI = NewHsTypeX - -type instance XUserTyVar DocNameI = PlaceHolder -type instance XKindedTyVar DocNameI = PlaceHolder -type instance XXTyVarBndr DocNameI = PlaceHolder - -type instance XFieldOcc DocNameI = DocName -type instance XXFieldOcc DocNameI = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 815aad47..84f58ab8 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -63,7 +63,7 @@ import Haddock.GhcUtils import GHC import Name import NameSet ( emptyNameSet ) -import HsTypes (extFieldOcc) +import HsTypes (selectorFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -136,14 +136,11 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_xforall = PlaceHolder - , hst_bndrs = tvs, hst_body = go ty }) + = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = PlaceHolder - , hst_ctxt = add_ctxt ctxt, hst_body = ty }) + = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_xqual = PlaceHolder - , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) add_ctxt (L loc preds) = L loc (extra_pred : preds) @@ -152,7 +149,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 NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -212,7 +209,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField fs _ _)) - = all (\f -> extFieldOcc (unLoc f) `elem` names) fs + = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing |