From 61335db90219eba267de90da1742a5b38f856e52 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 17 Sep 2013 09:34:05 -0400 Subject: Revision to reflect new role annotation syntax in GHC. --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/LaTeX.hs | 1 - src/Haddock/Backends/Xhtml/Decl.hs | 1 - src/Haddock/Convert.hs | 9 ++++----- src/Haddock/Interface/Create.hs | 2 +- src/Haddock/Interface/Rename.hs | 11 ++++++----- 6 files changed, 12 insertions(+), 14 deletions(-) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 58c02534..6afc7939 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -195,7 +195,7 @@ ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ - (tcdName dat) : [hsTyVarName v | L _ v@(HsTyVarBndr _ Nothing Nothing) <- hsQTvBndrs $ tyClDeclTyVars dat] + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] ResTyGADT x -> x diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 4f947249..c69f1e18 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -851,7 +851,6 @@ ppr_mono_ty _ (HsTyVar name) _ = 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 _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) -ppr_mono_ty _ (HsRoleAnnot {}) _ = error "ppr_mono_ty HsRoleAnnot" 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 n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 54c202b8..2ecc6464 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -676,7 +676,6 @@ ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsRoleAnnot {}) _ _ = error "ppr_mono_ty HsRoleAnnot" ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 04acbc9b..0f7e5b9c 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -120,9 +120,8 @@ synifyTyCon 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 $ HsTyVarBndr (getName fakeTyVar) - (Just $ synifyKindSig realKind) - Nothing + = noLoc $ KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind) in HsQTvs { hsq_kvs = [] -- No kind polymorphism , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * @@ -276,8 +275,8 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs where (kvs, tvs) = partition isKindVar ktvs synifyTyVar tv - | isLiftedTypeKind kind = noLoc (HsTyVarBndr name Nothing Nothing) - | otherwise = noLoc (HsTyVarBndr name (Just $ synifyKindSig kind) Nothing) + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index d4adbe1c..825e9624 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -354,7 +354,7 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup Name -> [LHsDecl Name] ungroup group_ = - mkDecls (concat . hs_tyclds) TyClD group_ ++ + mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ mkDecls hs_fords ForD group_ ++ diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index a6f48520..a5ed47e6 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -263,8 +263,6 @@ renameType t = case t of k' <- renameLKind k return (HsKindSig ty' k') - HsRoleAnnot _ _ -> error "renameType: HsRoleAnnot" - HsDocTy ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc @@ -290,10 +288,13 @@ renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (HsTyVarBndr n mkind mrole)) +renameLTyVarBndr (L loc (UserTyVar n)) + = do { n' <- rename n + ; return (L loc (UserTyVar n')) } +renameLTyVarBndr (L loc (KindedTyVar n kind)) = do { n' <- rename n - ; mkind' <- mapM renameLKind mkind - ; return (L loc (HsTyVarBndr n' mkind' mrole)) } + ; kind' <- renameLKind kind + ; return (L loc (KindedTyVar n' kind')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do -- cgit v1.2.3