From 50c0faf18a5c963c0df874aa94b034430280856a Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 8 Dec 2015 23:54:34 -0500 Subject: Update for type=kinds --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 9 +++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 14 +++---- haddock-api/src/Haddock/Convert.hs | 43 +++++++++++----------- .../src/Haddock/Interface/AttachInstances.hs | 24 ++++++++---- haddock-api/src/Haddock/Interface/Rename.hs | 12 +++--- haddock-api/src/Haddock/Utils.hs | 8 ++-- 7 files changed, 62 insertions(+), 50 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index cef0da20..a8882fe2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -242,7 +242,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} name = commaSeparate dflags . map unL $ getConNames con resType = apps $ map (reL . HsTyVar . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] + (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/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e7780d6e..75a4edba 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -413,7 +413,7 @@ ppTyVars = map (ppSymName . getName . hsLTyVarName) tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -725,7 +725,7 @@ ppSideBySideConstr subdocs unicode leader (L loc con) = tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty) + mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) | otherwise = ty mk_phi ty | null context = ty | otherwise = L loc (HsQualTy (con_cxt con) ty) @@ -957,7 +957,6 @@ ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ @@ -967,7 +966,7 @@ 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 @@ -987,6 +986,8 @@ ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" + ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 0e5e381a..124debfb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -176,7 +176,7 @@ ppTyVars :: [LHsTyVarBndr DocName] -> [Html] ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs +tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName @@ -200,7 +200,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] - ++ ppTyVars (hsQTvBndrs ltyvars)) + ++ ppTyVars (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppLType unicode qual ltype occ = nameOccName . getName $ name fixs @@ -969,11 +969,9 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = - promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = - promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys +ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual = maybeParen ctxt_prec pREC_CTX $ @@ -983,7 +981,7 @@ 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, ppr_mono_lty pREC_CON arg_ty unicode qual] -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 <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f68db9bc..664598ab 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -26,19 +26,19 @@ import Data.List( partition ) import DataCon import FamInstEnv import HsSyn -import Kind ( splitKindFunTys, tyConResKind, isKind ) import Name import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon -import Type (isStrLitTy, mkFunTys) -import TypeRep +import Type +import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon, ipTyCon ) +import TysWiredIn ( listTyConName, ipTyCon ) +import PrelNames ( hasKey, eqTyConKey ) import Unique ( getUnique ) -import Util ( filterByList ) +import Util ( filterByList, filterOut ) import Var import Haddock.Types @@ -117,11 +117,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs - (kvs, tvs) = partition isKindVar tkvs in TyFamEqn { tfe_tycon = name , tfe_pats = HsIB { hsib_body = typats - , hsib_kvs = map tyVarName kvs - , hsib_tvs = map tyVarName tvs } + , hsib_vars = map tyVarName tkvs } , tfe_rhs = hs_rhs } synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) @@ -149,8 +147,8 @@ synifyTyCon _coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_kvs = [] -- No kind polymorphism - , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + in HsQTvs { hsq_implicit = [] -- No kind polymorphism + , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -188,11 +186,12 @@ synifyTyCon _coax tc , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) + synifyFamilyResultSig resultVar tyConResKind , fdInjectivityAnn = synifyInjectivityAnn resultVar (tyConTyVars tc) (familyTyConInjectivityInfo tc) } + tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc)) synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc @@ -300,7 +299,7 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - gadt_ty = HsIB [] [] (synifyType WithinType res_ty) + gadt_ty = HsIB [] (synifyType WithinType res_ty) -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> @@ -329,10 +328,8 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars Name -synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs - , hsq_tvs = map synifyTyVar tvs } - where - (kvs, tvs) = partition isKindVar ktvs +synifyTyVars ktvs = HsQTvs { hsq_implicit = [] + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr Name synifyTyVar tv @@ -387,19 +384,21 @@ synifyType _ (TyConApp tc tys) , Just x <- isStrLitTy name = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities - | tc == eqTyCon + | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) (noLoc $ HsTyVar $ noLoc (getName tc)) - (map (synifyType WithinType) tys) + (map (synifyType WithinType) $ + filterOut isCoercionTy tys) +synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsAppTy s1 s2 -synifyType _ (FunTy t1 t2) = let +synifyType _ (ForAllTy (Anon t1) t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 in noLoc $ HsFunTy s1 s2 @@ -414,6 +413,8 @@ synifyType s forallty@(ForAllTy _tv _ty) = ImplicitizeForAll -> noLoc sPhi synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType s (CastTy t _) = synifyType s t +synifyType _ (CoercionTy {}) = error "synifyType:Coercion" synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n @@ -437,7 +438,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead } } where - (ks,ts) = break (not . isKind) types + (ks,ts) = partitionInvisibles (classTyCon cls) id types synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family @@ -456,5 +457,5 @@ synifyFamInst fi opaque = do return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi ityp (DataFamilyInst c) = DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c - (ks,ts) = break (not . isKind) $ fi_tys fi + (ks,ts) = partitionInvisibles (classTyCon cls) id $ fi_tys fi synifyTypes = map (unLoc. synifyType WithinType) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 21569374..56382341 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -22,6 +22,7 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) +import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -42,7 +43,7 @@ import SrcLoc import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) import TyCon -import TypeRep +import TyCoRep import TysPrim( funTyCon ) import Var hiding (varName) #define FSLIT(x) (mkFastString# (x#)) @@ -160,18 +161,26 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 +argCount (ForAllTy (Anon _) _ ) = 2 argCount (ForAllTy _ t) = argCount t +argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType +simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] -simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) +simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (TyConApp tc ts) = SimpleType (tyConName tc) + (mapMaybe simplify_maybe ts) simplify (LitTy l) = SimpleTyLit l +simplify (CastTy ty _) = simplify ty +simplify (CoercionTy _) = error "simplify:Coercion" + +simplify_maybe :: Type -> Maybe SimpleType +simplify_maybe (CoercionTy {}) = Nothing +simplify_maybe ty = Just (simplify ty) -- Used for sorting instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) @@ -221,9 +230,10 @@ isTypeHidden expInfo = typeHidden TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 - ForAllTy _ ty -> typeHidden ty + ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty LitTy _ -> False + CastTy ty _ -> typeHidden ty + CoercionTy {} -> False nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 378dcf61..e3a5a7d5 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -234,11 +234,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, L loc op) b -> do + HsOpTy a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, L loc op') b') + return (HsOpTy a' (L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -254,18 +254,18 @@ renameType t = case t of HsTyLit x -> return (HsTyLit x) - HsWrapTy a b -> HsWrapTy a <$> renameType b HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy a b -> HsExplicitListTy 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 Name -> RnM (LHsQTyVars DocName) -renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) +renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) } + ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs' }) } -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) @@ -547,7 +547,7 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) } + , hsib_vars = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs Name in_thing diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 45deca9c..3510d908 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) - | tv <- hsQTvBndrs tvs ] + | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- -- * Making abstract declarations @@ -200,7 +200,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] c' :: ConDecl Name c' = ConDeclH98 { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_kvs = mempty, hsq_tvs = tvs } + , con_qvars = Just $ HsQTvs { hsq_implicit = mempty + , hsq_explicit = tvs } , con_cxt = Just cxt , con_details = details , con_doc = con_doc c @@ -224,7 +225,8 @@ emptyHsQTvs :: LHsQTyVars Name -- 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_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } +emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_explicit = [] } -------------------------------------------------------------------------------- -- cgit v1.2.3