From f5d2083807a03c57f194fcc3a7baf82e34aad524 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 22 Nov 2018 11:55:00 -0500 Subject: Overhaul -fprint-explicit-kinds to use VKA This patch changes the behavior of `-fprint-explicit-kinds` so that it displays kind argument using visible kind application. In other words, the flag now: 1. Prints instantiations of specified variables with `@(...)`. 2. Prints instantiations of inferred variables with `@{...}`. In addition, this patch removes the `Use -fprint-explicit-kinds to see the kind arguments` error message that often arises when a type mismatch occurs due to different kinds. Instead, whenever there is a kind mismatch, we now enable the `-fprint-explicit-kinds` flag locally to help cue to the programmer where the error lies. (See `Note [Kind arguments in error messages]` in `TcErrors`.) As a result, these funny `@{...}` things can now appear to the user even without turning on the `-fprint-explicit-kinds` flag explicitly, so I took the liberty of documenting them in the users' guide. Test Plan: ./validate Reviewers: goldfire, simonpj, bgamari Reviewed By: simonpj Subscribers: rwbarton, carter GHC Trac Issues: #15871 Differential Revision: https://phabricator.haskell.org/D5314 --- compiler/iface/IfaceSyn.hs | 7 +- compiler/iface/IfaceType.hs | 224 ++++++++++++++++++++++++++++---------------- compiler/iface/ToIface.hs | 7 +- 3 files changed, 147 insertions(+), 91 deletions(-) (limited to 'compiler/iface') diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 7d1e697cdf..4d70b11973 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -954,9 +954,7 @@ pprIfaceTyConParent :: IfaceTyConParent -> SDoc pprIfaceTyConParent IfNoParent = Outputable.empty pprIfaceTyConParent (IfDataInstance _ tc tys) - = sdocWithDynFlags $ \dflags -> - let ftys = stripInvisArgs dflags tys - in pprIfaceTypeApp topPrec tc ftys + = pprIfaceTypeApp topPrec tc tys pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression @@ -1414,8 +1412,7 @@ freeNamesIfKind :: IfaceType -> NameSet freeNamesIfKind = freeNamesIfType freeNamesIfAppArgs :: IfaceAppArgs -> NameSet -freeNamesIfAppArgs (IA_Vis t ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts -freeNamesIfAppArgs (IA_Invis k ks) = freeNamesIfKind k &&& freeNamesIfAppArgs ks +freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts freeNamesIfAppArgs IA_Nil = emptyNameSet freeNamesIfType :: IfaceType -> NameSet diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 4d6a3b3be3..e2ea655194 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -28,8 +28,8 @@ module IfaceType ( -- Equality testing isIfaceLiftedTypeKind, - -- Conversion from IfaceAppArgs -> [IfaceType] - appArgsIfaceTypes, + -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags + appArgsIfaceTypes, appArgsIfaceTypesArgFlags, -- Printing pprIfaceType, pprParendIfaceType, pprPrecIfaceType, @@ -158,21 +158,27 @@ data IfaceTyLit type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag --- See Note [Suppressing invisible arguments] --- We use a new list type (rather than [(IfaceType,Bool)], because --- it'll be more compact and faster to parse in interface --- files. Rather than two bytes and two decisions (nil/cons, and --- type/kind) there'll just be one. +-- | Stores the arguments in a type application as a list. +-- See @Note [Suppressing invisible arguments]@. data IfaceAppArgs = IA_Nil - | IA_Vis IfaceType IfaceAppArgs -- "Vis" means show when pretty-printing - | IA_Invis IfaceKind IfaceAppArgs -- "Invis" means don't show when pretty-printing - -- except with -fprint-explicit-kinds + | IA_Arg IfaceType -- The type argument + + ArgFlag -- The argument's visibility. We store this here so + -- that we can: + -- + -- 1. Avoid pretty-printing invisible (i.e., specified + -- or inferred) arguments when + -- -fprint-explicit-kinds isn't enabled, or + -- 2. When -fprint-explicit-kinds *is*, enabled, print + -- specified arguments in @(...) and inferred + -- arguments in @{...}. + + IfaceAppArgs -- The rest of the arguments instance Semi.Semigroup IfaceAppArgs where - IA_Nil <> xs = xs - IA_Vis ty rest <> xs = IA_Vis ty (rest Semi.<> xs) - IA_Invis ki rest <> xs = IA_Invis ki (rest Semi.<> xs) + IA_Nil <> xs = xs + IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) instance Monoid IfaceAppArgs where mempty = IA_Nil @@ -236,29 +242,29 @@ Here is how each equality predicate* is printed in homogeneous and heterogeneous contexts, depending on which combination of the -fprint-explicit-kinds and -fprint-equality-relations flags is used: ---------------------------------------------------------------------------------------- -| Predicate | Neither flag | -fprint-explicit-kinds | -|-------------------------------|----------------------------|------------------------| -| a ~ b (homogeneous) | a ~ b | (a :: *) ~ (b :: *) | -| a ~~ b, homogeneously | a ~ b | (a :: *) ~ (b :: *) | -| a ~~ b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) | -| a ~# b, homogeneously | a ~ b | (a :: *) ~ (b :: *) | -| a ~# b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) | -| Coercible a b (homogeneous) | Coercible a b | Coercible * a b | -| a ~R# b, homogeneously | Coercible a b | Coercible * a b | -| a ~R# b, heterogeneously | a ~R# b | (a :: *) ~R# (c :: k) | -|-------------------------------|----------------------------|------------------------| -| Predicate | -fprint-equality-relations | Both flags | -|-------------------------------|----------------------------|------------------------| -| a ~ b (homogeneous) | a ~ b | (a :: *) ~ (b :: *) | -| a ~~ b, homogeneously | a ~~ b | (a :: *) ~~ (b :: *) | -| a ~~ b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) | -| a ~# b, homogeneously | a ~# b | (a :: *) ~# (b :: *) | -| a ~# b, heterogeneously | a ~# c | (a :: *) ~# (c :: k) | -| Coercible a b (homogeneous) | Coercible a b | Coercible * a b | -| a ~R# b, homogeneously | a ~R# b | (a :: *) ~R# (b :: *) | -| a ~R# b, heterogeneously | a ~R# b | (a :: *) ~R# (c :: k) | ---------------------------------------------------------------------------------------- +-------------------------------------------------------------------------------------------- +| Predicate | Neither flag | -fprint-explicit-kinds | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +|-------------------------------|----------------------------|-----------------------------| +| Predicate | -fprint-equality-relations | Both flags | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | +| a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +-------------------------------------------------------------------------------------------- (* There is no heterogeneous, representational, lifted equality counterpart to (~~). There could be, but there seems to be no use for it.) @@ -349,7 +355,8 @@ isIfaceLiftedTypeKind :: IfaceKind -> Bool isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) = isLiftedTypeKindTyConName (ifaceTyConName tc) isIfaceLiftedTypeKind (IfaceTyConApp tc - (IA_Vis (IfaceTyConApp ptr_rep_lifted IA_Nil) IA_Nil)) + (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil) + Required IA_Nil)) = tc `ifaceTyConHasKey` tYPETyConKey && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey isIfaceLiftedTypeKind _ = False @@ -435,8 +442,7 @@ ifTypeIsVarFree ty = go ty go (IfaceCoercionTy {}) = False -- Safe go_args IA_Nil = True - go_args (IA_Vis arg args) = go arg && go_args args - go_args (IA_Invis arg args) = go arg && go_args args + go_args (IA_Arg arg _ args) = go arg && go_args args {- Note [Substitution on IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -505,9 +511,8 @@ substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args = go args where - go IA_Nil = IA_Nil - go (IA_Vis ty tys) = IA_Vis (substIfaceType env ty) (go tys) - go (IA_Invis ty tys) = IA_Invis (substIfaceType env ty) (go tys) + go IA_Nil = IA_Nil + go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType substIfaceTyVar env tv @@ -530,25 +535,33 @@ stripInvisArgs dflags tys where suppress_invis c = case c of - IA_Nil -> IA_Nil - IA_Invis _ ts -> suppress_invis ts - IA_Vis t ts -> IA_Vis t $ suppress_invis ts + IA_Nil -> IA_Nil + IA_Arg t argf ts + | isVisibleArgFlag argf + -> IA_Arg t argf $ suppress_invis ts -- Keep recursing through the remainder of the arguments, as it's -- possible that there are remaining invisible ones. -- See the "In type declarations" section of Note [VarBndrs, -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. + | otherwise + -> suppress_invis ts appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] appArgsIfaceTypes IA_Nil = [] -appArgsIfaceTypes (IA_Invis t ts) = t : appArgsIfaceTypes ts -appArgsIfaceTypes (IA_Vis t ts) = t : appArgsIfaceTypes ts +appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts + +appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] +appArgsIfaceTypesArgFlags IA_Nil = [] +appArgsIfaceTypesArgFlags (IA_Arg t a ts) + = (t, a) : appArgsIfaceTypesArgFlags ts ifaceVisAppArgsLength :: IfaceAppArgs -> Int ifaceVisAppArgsLength = go 0 where - go !n IA_Nil = n - go n (IA_Vis _ rest) = go (n+1) rest - go n (IA_Invis _ rest) = go n rest + go !n IA_Nil = n + go n (IA_Arg _ argf rest) + | isVisibleArgFlag argf = go (n+1) rest + | otherwise = go n rest {- Note [Suppressing invisible arguments] @@ -609,6 +622,37 @@ By flattening the arguments like this, we obtain two benefits: is not a constant-time operation, so by flattening the arguments first, we decrease the number of times we have to call typeKind. +Note [Pretty-printing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Suppressing invisible arguments] is all about how to avoid printing +invisible arguments when the -fprint-explicit-kinds flag is disables. Well, +what about when it's enabled? Then we can and should print invisible kind +arguments, and this Note explains how we do it. + +As two running examples, consider the following code: + + {-# LANGUAGE PolyKinds #-} + data T1 a + data T2 (a :: k) + +When displaying these types (with -fprint-explicit-kinds on), we could just +do the following: + + T1 k a + T2 k a + +That certainly gets the job done. But it lacks a crucial piece of information: +is the `k` argument inferred or specified? To communicate this, we use visible +kind application syntax to distinguish the two cases: + + T1 @{k} a + T2 @k a + +Here, @{k} indicates that `k` is an inferred argument, and @k indicates that +`k` is a specified argument. (See +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for +a lengthier explanation on what "inferred" and "specified" mean.) + ************************************************************************ * * Pretty-printing @@ -663,10 +707,19 @@ pprIfaceTvBndr use_parens (tv, ki) | otherwise = id pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc -pprIfaceTyConBinders = sep . map (go . ifTyConBinderVar) +pprIfaceTyConBinders = sep . map go where - go (IfaceIdBndr bndr) = pprIfaceIdBndr bndr - go (IfaceTvBndr bndr) = pprIfaceTvBndr True bndr + go :: IfaceTyConBinder -> SDoc + go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr + go (Bndr (IfaceTvBndr bndr) vis) = + -- See Note [Pretty-printing invisible arguments] + case vis of + AnonTCB -> ppr_bndr True + NamedTCB Required -> ppr_bndr True + NamedTCB Specified -> char '@' <> ppr_bndr True + NamedTCB Inferred -> char '@' <> braces (ppr_bndr False) + where + ppr_bndr use_parens = pprIfaceTvBndr use_parens bndr instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do @@ -735,9 +788,9 @@ ppr_ty ctxt_prec (IfaceAppTy t ts) sdocWithDynFlags $ \dflags -> pprIfacePrefixApp ctxt_prec (ppr_ty funPrec t) - (map (ppr_ty appPrec) (tys_wo_kinds dflags)) + (map (ppr_app_arg appPrec) (tys_wo_kinds dflags)) - tys_wo_kinds dflags = appArgsIfaceTypes $ stripInvisArgs dflags ts + tys_wo_kinds dflags = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags ts -- Strip any casts from the head of the application ppr_app_ty_no_casts = @@ -860,8 +913,8 @@ defaultRuntimeRepVars sty = go emptyFsEnv go_args :: FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs go_args _ IA_Nil = IA_Nil - go_args subs (IA_Vis ty args) = IA_Vis (go subs ty) (go_args subs args) - go_args subs (IA_Invis ty args) = IA_Invis (go subs ty) (go_args subs args) + go_args subs (IA_Arg ty argf args) + = IA_Arg (go subs ty) argf (go_args subs args) liftedRep :: IfaceTyCon liftedRep = @@ -887,16 +940,24 @@ pprIfaceAppArgs = ppr_app_args topPrec pprParendIfaceAppArgs = ppr_app_args appPrec ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc -ppr_app_args ctx_prec args - = let ppr_rest = ppr_app_args ctx_prec - pprTys t ts = ppr_ty ctx_prec t <+> ppr_rest ts - in case args of - IA_Nil -> empty - IA_Vis t ts -> pprTys t ts - IA_Invis t ts -> sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitKinds dflags - then pprTys t ts - else ppr_rest ts +ppr_app_args ctx_prec = go + where + go :: IfaceAppArgs -> SDoc + go IA_Nil = empty + go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts + +-- See Note [Pretty-printing invisible arguments] +ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc +ppr_app_arg ctx_prec (t, argf) = + sdocWithDynFlags $ \dflags -> + let print_kinds = gopt Opt_PrintExplicitKinds dflags + in case argf of + Required -> ppr_ty ctx_prec t + Specified | print_kinds + -> char '@' <> ppr_ty appPrec t + Inferred | print_kinds + -> char '@' <> braces (ppr_ty topPrec t) + _ -> empty ------------------- pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc @@ -1074,7 +1135,8 @@ pprIfaceTyList ctxt_prec ty1 ty2 -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl gather (IfaceTyConApp tc tys) | tc `ifaceTyConHasKey` consDataConKey - , (IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil))) <- tys + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf , (args, tl) <- gather ty2 = (ty1:args, tl) | tc `ifaceTyConHasKey` nilDataConKey @@ -1094,7 +1156,8 @@ pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> DynFlags -> PprStyle -> SDoc pprTyTcApp' ctxt_prec tc tys dflags style | ifaceTyConName tc `hasKey` ipClassKey - , IA_Vis (IfaceLitTy (IfaceStrTyLit n)) (IA_Vis ty IA_Nil) <- tys + , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) + Required (IA_Arg ty Required IA_Nil) <- tys = maybeParen ctxt_prec funPrec $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty @@ -1108,11 +1171,12 @@ pprTyTcApp' ctxt_prec tc tys dflags style | tc `ifaceTyConHasKey` consDataConKey , not (gopt Opt_PrintExplicitKinds dflags) - , IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil)) <- tys + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf = pprIfaceTyList ctxt_prec ty1 ty2 | tc `ifaceTyConHasKey` tYPETyConKey - , IA_Vis (IfaceTyConApp rep IA_Nil) IA_Nil <- tys + , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys , rep `ifaceTyConHasKey` liftedRepDataConKey = kindType @@ -1126,10 +1190,10 @@ pprTyTcApp' ctxt_prec tc tys dflags style -> doc | otherwise - -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds + -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds where info = ifaceTyConInfo tc - tys_wo_kinds = appArgsIfaceTypes $ stripInvisArgs dflags tys + tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags tys -- | Pretty-print a type-level equality. -- Returns (Just doc) if the argument is a /saturated/ application @@ -1436,22 +1500,18 @@ instance Binary IfaceTyLit where instance Binary IfaceAppArgs where put_ bh tk = case tk of - IA_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts - IA_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts - IA_Nil -> putByte bh 2 + IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts + IA_Nil -> putByte bh 1 get bh = do c <- getByte bh case c of 0 -> do t <- get bh + a <- get bh ts <- get bh - return $! IA_Vis t ts - 1 -> do - t <- get bh - ts <- get bh - return $! IA_Invis t ts - 2 -> return IA_Nil + return $! IA_Arg t a ts + 1 -> return IA_Nil _ -> panic ("get IfaceAppArgs " ++ show c) ------------------- diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs index a3d11e8891..7c8a939965 100644 --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -305,14 +305,13 @@ toIfaceAppArgsX fr kind ty_args | Just ty' <- coreView ty = go env ty' ts go env (ForAllTy (Bndr tv vis) res) (t:ts) - | isVisibleArgFlag vis = IA_Vis t' ts' - | otherwise = IA_Invis t' ts' + = IA_Arg t' vis ts' where t' = toIfaceTypeX fr t ts' = go (extendTCvSubst env tv t) res ts go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps - = IA_Vis (toIfaceTypeX fr t) (go env res ts) + = IA_Arg (toIfaceTypeX fr t) Required (go env res ts) go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) @@ -326,7 +325,7 @@ toIfaceAppArgsX fr kind ty_args -- carry on as if it were FunTy. Without the test for -- isEmptyTCvSubst we'd get an infinite loop (Trac #15473) WARN( True, ppr kind $$ ppr ty_args ) - IA_Vis (toIfaceTypeX fr t1) (go env ty ts1) + IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) tidyToIfaceType :: TidyEnv -> Type -> IfaceType tidyToIfaceType env ty = toIfaceType (tidyType env ty) -- cgit v1.2.1