Commit 1c353623 authored by Ryan Scott's avatar Ryan Scott

Use IfaceAppArgs to store an IfaceAppTy's arguments

Summary:
Currently, an `IfaceAppTy` has no way to tell whether its
argument is visible or not, so it simply treats all arguments as
visible, leading to #15330. We already have a solution for this
problem in the form of the `IfaceTcArgs` data structure, used by
`IfaceTyConApp` to represent the arguments to a type constructor.
Therefore, it makes sense to reuse this machinery for `IfaceAppTy`,
so this patch does just that.

This patch:

1. Renames `IfaceTcArgs` to `IfaceAppArgs` to reflect its more
   general purpose.
2. Changes the second field of `IfaceAppTy` from `IfaceType` to
   `IfaceAppArgs`, and propagates the necessary changes through. In
   particular, pretty-printing an `IfaceAppTy` now goes through the
   `IfaceAppArgs` pretty-printer, which correctly displays arguments
   as visible or not for free, fixing #15330.
3. Changes `toIfaceTypeX` and related functions so that when
   converting an `AppTy` to an `IfaceAppTy`, it flattens as many
   argument `AppTy`s as possible, and then converts those arguments
   into an `IfaceAppArgs` list, using the kind of the function
   `Type` as a guide. (Doing so minimizes the number of times we need
   to call `typeKind`, which is more expensive that finding the kind
   of a `TyCon`.)

Test Plan: make test TEST=T15330

Reviewers: goldfire, simonpj, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15330

Differential Revision: https://phabricator.haskell.org/D4938
parent e24da5ed
......@@ -512,7 +512,7 @@ rnIfaceTyConParent :: Rename IfaceTyConParent
rnIfaceTyConParent (IfDataInstance n tc args)
= IfDataInstance <$> rnIfaceGlobal n
<*> rnIfaceTyCon tc
<*> rnIfaceTcArgs args
<*> rnIfaceAppArgs args
rnIfaceTyConParent IfNoParent = pure IfNoParent
rnIfaceConDecls :: Rename IfaceConDecls
......@@ -557,7 +557,7 @@ rnMaybeDefMethSpec mb = return mb
rnIfaceAxBranch :: Rename IfaceAxBranch
rnIfaceAxBranch d = do
ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
lhs <- rnIfaceTcArgs (ifaxbLHS d)
lhs <- rnIfaceAppArgs (ifaxbLHS d)
rhs <- rnIfaceType (ifaxbRHS d)
return d { ifaxbTyVars = ty_vars
, ifaxbLHS = lhs
......@@ -693,16 +693,16 @@ rnIfaceType :: Rename IfaceType
rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n)
rnIfaceType (IfaceAppTy t1 t2)
= IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2
= IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l)
rnIfaceType (IfaceFunTy t1 t2)
= IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceDFunTy t1 t2)
= IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceTupleTy s i tks)
= IfaceTupleTy s i <$> rnIfaceTcArgs tks
= IfaceTupleTy s i <$> rnIfaceAppArgs tks
rnIfaceType (IfaceTyConApp tc tks)
= IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs tks
= IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks
rnIfaceType (IfaceForAllTy tv t)
= IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
rnIfaceType (IfaceCoercionTy co)
......@@ -713,7 +713,7 @@ rnIfaceType (IfaceCastTy ty co)
rnIfaceForAllBndr :: Rename IfaceForAllBndr
rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis
rnIfaceTcArgs :: Rename IfaceTcArgs
rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts
rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts
rnIfaceTcArgs ITC_Nil = pure ITC_Nil
rnIfaceAppArgs :: Rename IfaceAppArgs
rnIfaceAppArgs (IA_Invis t ts) = IA_Invis <$> rnIfaceType t <*> rnIfaceAppArgs ts
rnIfaceAppArgs (IA_Vis t ts) = IA_Vis <$> rnIfaceType t <*> rnIfaceAppArgs ts
rnIfaceAppArgs IA_Nil = pure IA_Nil
......@@ -184,7 +184,7 @@ data IfaceTyConParent
= IfNoParent
| IfDataInstance IfExtName
IfaceTyCon
IfaceTcArgs
IfaceAppArgs
data IfaceFamTyConFlav
= IfaceDataFamilyTyCon -- Data family
......@@ -211,7 +211,7 @@ data IfaceAT = IfaceAT -- See Class.ClassATItem
-- This is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
, ifaxbCoVars :: [IfaceIdBndr]
, ifaxbLHS :: IfaceTcArgs
, ifaxbLHS :: IfaceAppArgs
, ifaxbRoles :: [Role]
, ifaxbRHS :: IfaceType
, ifaxbIncomps :: [BranchIndex] }
......@@ -573,7 +573,7 @@ pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
| otherwise
= brackets (pprWithCommas (pprIfaceTvBndr True) tvs <> semi <+>
pprWithCommas pprIfaceIdBndr cvs)
pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)
pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys)
maybe_incomps = ppUnless (null incomps) $ parens $
text "incompatible indices:" <+> ppr incomps
......@@ -1050,7 +1050,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
-- See Note [Result type of a data family GADT]
mk_user_con_res_ty eq_spec
| IfDataInstance _ tc tys <- parent
= pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))
= pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys))
| otherwise
= sdocWithDynFlags (ppr_tc_app gadt_subst)
where
......@@ -1347,7 +1347,7 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
, ifaxbRHS = rhs })
= fnList freeNamesIfTvBndr tyvars &&&
fnList freeNamesIfIdBndr covars &&&
freeNamesIfTcArgs lhs &&&
freeNamesIfAppArgs lhs &&&
freeNamesIfType rhs
freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
......@@ -1407,17 +1407,17 @@ freeNamesIfBang _ = emptyNameSet
freeNamesIfKind :: IfaceType -> NameSet
freeNamesIfKind = freeNamesIfType
freeNamesIfTcArgs :: IfaceTcArgs -> NameSet
freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
freeNamesIfTcArgs ITC_Nil = emptyNameSet
freeNamesIfAppArgs :: IfaceAppArgs -> NameSet
freeNamesIfAppArgs (IA_Vis t ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts
freeNamesIfAppArgs (IA_Invis k ks) = freeNamesIfKind k &&& freeNamesIfAppArgs ks
freeNamesIfAppArgs IA_Nil = emptyNameSet
freeNamesIfType :: IfaceType -> NameSet
freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet
freeNamesIfType (IfaceTyVar _) = emptyNameSet
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts
freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t
freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts
freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
freeNamesIfType (IfaceLitTy _) = emptyNameSet
freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTyVarBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
......@@ -1567,7 +1567,7 @@ freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
freeNamesIfaceTyConParent IfNoParent = emptyNameSet
freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
= unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys
= unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys
-- helpers
(&&&) :: NameSet -> NameSet -> NameSet
......
......@@ -17,7 +17,7 @@ module IfaceType (
IfaceMCoercion(..),
IfaceUnivCoProv(..),
IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
IfaceTyLit(..), IfaceTcArgs(..),
IfaceTyLit(..), IfaceAppArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
......@@ -28,14 +28,14 @@ module IfaceType (
-- Equality testing
isIfaceLiftedTypeKind,
-- Conversion from IfaceTcArgs -> [IfaceType]
tcArgsIfaceTypes,
-- Conversion from IfaceAppArgs -> [IfaceType]
appArgsIfaceTypes,
-- Printing
pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs,
pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll,
pprIfaceSigmaType, pprIfaceTyLit,
pprIfaceCoercion, pprParendIfaceCoercion,
......@@ -46,7 +46,7 @@ module IfaceType (
stripIfaceInvisVars,
stripInvisArgs,
mkIfaceTySubst, substIfaceTyVar, substIfaceTcArgs, inDomIfaceTySubst
mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst
) where
#include "HsVersions.h"
......@@ -71,7 +71,6 @@ import FastStringEnv
import Util
import Data.Maybe( isJust )
import Data.List (foldl')
import qualified Data.Semigroup as Semi
{-
......@@ -115,28 +114,57 @@ data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
-------------------------------
type IfaceKind = IfaceType
data IfaceType -- A kind of universal type, used for types and kinds
-- | A kind of universal type, used for types and kinds.
--
-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'
-- before being printed. See @Note [IfaceType and pretty-printing]@.
data IfaceType
= IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
| IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceLitTy IfaceTyLit
| IfaceAppTy IfaceType IfaceType
| IfaceAppTy IfaceType IfaceAppArgs
-- See Note [Suppressing invisible arguments] for
-- an explanation of why the second field isn't
-- IfaceType, analogous to AppTy.
| IfaceFunTy IfaceType IfaceType
| IfaceDFunTy IfaceType IfaceType
| IfaceForAllTy IfaceForAllBndr IfaceType
| IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
| IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
| IfaceCastTy IfaceType IfaceCoercion
| IfaceCoercionTy IfaceCoercion
| IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
TupleSort -- What sort of tuple?
IsPromoted -- A bit like IfaceTyCon
IfaceTcArgs -- arity = length args
IfaceAppArgs -- arity = length args
-- For promoted data cons, the kind args are omitted
type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
{-
Note [IfaceType and pretty-printing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
IfaceType has a dual role. Similarly to other Iface data types, it is used as a
serialization mechanism for Type when writing to and reading from interface
files. Less obviously, it is also a vehicle for pretty-printing. Any time that
a Type is pretty-printed, it is first converted to an IfaceType and /then/
printed out.
Why go through all this trouble? One major reason for this is that an IfaceType
stores slightly more information about its structure than a Type does, which
makes certain pretty-printing decisions easier. Most notably, in type
application forms (such as IfaceAppTy, IfaceTyConApp, and IfaceTupleTy), we
track whether each of the arguments to a function are visible or not, which
makes it easier to suppress printing out the invisible arguments.
See Note [Suppressing invisible arguments] for more.
Another minor benefit of using IfaceTypes for pretty-printing is that this
avoids the need to duplicate code between the Outputable instances for Type
and IfaceType.
-}
data IfaceTyLit
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
......@@ -150,19 +178,19 @@ type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag
-- 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.
data IfaceTcArgs
= ITC_Nil
| ITC_Vis IfaceType IfaceTcArgs -- "Vis" means show when pretty-printing
| ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printing
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
instance Semi.Semigroup IfaceTcArgs where
ITC_Nil <> xs = xs
ITC_Vis ty rest <> xs = ITC_Vis ty (rest Semi.<> xs)
ITC_Invis ki rest <> xs = ITC_Invis ki (rest Semi.<> xs)
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)
instance Monoid IfaceTcArgs where
mempty = ITC_Nil
instance Monoid IfaceAppArgs where
mempty = IA_Nil
mappend = (Semi.<>)
-- Encodes type constructors, kind constructors,
......@@ -337,10 +365,10 @@ ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool
ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key
isIfaceLiftedTypeKind :: IfaceKind -> Bool
isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil)
= isLiftedTypeKindTyConName (ifaceTyConName tc)
isIfaceLiftedTypeKind (IfaceTyConApp tc
(ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
(IA_Vis (IfaceTyConApp ptr_rep_lifted IA_Nil) IA_Nil))
= tc `ifaceTyConHasKey` tYPETyConKey
&& ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey
isIfaceLiftedTypeKind _ = False
......@@ -415,7 +443,7 @@ ifTypeIsVarFree ty = go ty
where
go (IfaceTyVar {}) = False
go (IfaceFreeTyVar {}) = False
go (IfaceAppTy fun arg) = go fun && go arg
go (IfaceAppTy fun args) = go fun && go_args args
go (IfaceFunTy arg res) = go arg && go res
go (IfaceDFunTy arg res) = go arg && go res
go (IfaceForAllTy {}) = False
......@@ -425,9 +453,9 @@ ifTypeIsVarFree ty = go ty
go (IfaceCastTy {}) = False -- Safe
go (IfaceCoercionTy {}) = False -- Safe
go_args ITC_Nil = True
go_args (ITC_Vis arg args) = go arg && go_args args
go_args (ITC_Invis arg args) = go arg && go_args args
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
{- Note [Substitution on IfaceType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -452,12 +480,12 @@ substIfaceType env ty
where
go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv
go (IfaceTyVar tv) = substIfaceTyVar env tv
go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts)
go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
go ty@(IfaceLitTy {}) = ty
go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys)
go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys)
go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
......@@ -492,13 +520,13 @@ substIfaceType env ty
go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
go_prov (IfacePluginProv str) = IfacePluginProv str
substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
substIfaceTcArgs env args
substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs
substIfaceAppArgs env args
= go args
where
go ITC_Nil = ITC_Nil
go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys)
go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
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)
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
......@@ -509,52 +537,96 @@ substIfaceTyVar env tv
{-
************************************************************************
* *
Functions over IFaceTcArgs
Functions over IfaceAppArgs
* *
************************************************************************
-}
stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs
stripInvisArgs dflags tys
| gopt Opt_PrintExplicitKinds dflags = tys
| otherwise = suppress_invis tys
where
suppress_invis c
= case c of
ITC_Nil -> ITC_Nil
ITC_Invis _ ts -> suppress_invis ts
ITC_Vis t ts -> ITC_Vis t $ suppress_invis ts
IA_Nil -> IA_Nil
IA_Invis _ ts -> suppress_invis ts
IA_Vis t ts -> IA_Vis t $ 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 [TyVarBndrs,
-- TyVarBinders, TyConBinders, and visibility] in TyCoRep.
tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
tcArgsIfaceTypes ITC_Nil = []
tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts
appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType]
appArgsIfaceTypes IA_Nil = []
appArgsIfaceTypes (IA_Invis t ts) = t : appArgsIfaceTypes ts
appArgsIfaceTypes (IA_Vis t ts) = t : appArgsIfaceTypes ts
ifaceVisTcArgsLength :: IfaceTcArgs -> Int
ifaceVisTcArgsLength = go 0
ifaceVisAppArgsLength :: IfaceAppArgs -> Int
ifaceVisAppArgsLength = go 0
where
go !n ITC_Nil = n
go n (ITC_Vis _ rest) = go (n+1) rest
go n (ITC_Invis _ rest) = go n rest
go !n IA_Nil = n
go n (IA_Vis _ rest) = go (n+1) rest
go n (IA_Invis _ rest) = go n rest
{-
Note [Suppressing invisible arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use the IfaceTcArgs to specify which of the arguments to a type
constructor should be displayed when pretty-printing, under
the control of -fprint-explicit-kinds.
We use the IfaceAppArgs data type to specify which of the arguments to a type
should be displayed when pretty-printing, under the control of
-fprint-explicit-kinds.
See also Type.filterOutInvisibleTypes.
For example, given
T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
'Just :: forall k. k -> 'Maybe k -- Promoted
we want
T * Tree Int prints as T Tree Int
'Just * prints as Just *
T * Tree Int prints as T Tree Int
'Just * prints as Just *
For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit,
since the corresponding Core constructor:
data Type
= ...
| TyConApp TyCon [Type]
Already puts all of its arguments into a list. So when converting a Type to an
IfaceType (see toIfaceAppArgsX in ToIface), we simply use the kind of the TyCon
(which is cached) to guide the process of converting the argument Types into an
IfaceAppArgs list.
We also want this behavior for IfaceAppTy, since given:
data Proxy (a :: k)
f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True)
We want to print the return type as `Proxy (t True)` without the use of
-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the
tycon case, because the corresponding Core constructor for IfaceAppTy:
data Type
= ...
| AppTy Type Type
Only stores one argument at a time. Therefore, when converting an AppTy to an
IfaceAppTy (in toIfaceTypeX in ToIface), we:
1. Flatten the chain of AppTys down as much as possible
2. Use typeKind to determine the function Type's kind
3. Use this kind to guide the process of converting the argument Types into an
IfaceAppArgs list.
By flattening the arguments like this, we obtain two benefits:
(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as
we do IfaceTyApp arguments, which means that we only need to implement the
logic to filter out invisible arguments once.
(b) Unlike for tycons, finding the kind of a type in general (through typeKind)
is not a constant-time operation, so by flattening the arguments first, we
decrease the number of times we have to call typeKind.
************************************************************************
* *
......@@ -672,30 +744,29 @@ ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
ppr_fun_tail other_ty
= [arrow <+> pprIfaceType other_ty]
ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
ppr_ty ctxt_prec (IfaceAppTy t ts)
= if_print_coercions
ppr_app_ty
ppr_app_ty_no_casts
where
ppr_app_ty =
maybeParen ctxt_prec appPrec
$ ppr_ty funPrec ty1 <+> ppr_ty appPrec ty2
sdocWithDynFlags $ \dflags ->
pprIfacePrefixApp ctxt_prec
(ppr_ty funPrec t)
(map (ppr_ty appPrec) (tys_wo_kinds dflags))
tys_wo_kinds dflags = appArgsIfaceTypes $ stripInvisArgs dflags ts
-- Strip any casts from the head of the application
ppr_app_ty_no_casts =
case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of
(IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args)
_ -> ppr_app_ty
split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs)
split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args)
split_app_tys head args = (head, args)
case t of
IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts)
_ -> ppr_app_ty
mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType
mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType
mk_app_tys (IfaceTyConApp tc tys1) tys2 =
IfaceTyConApp tc (tys1 `mappend` tys2)
mk_app_tys t1 tys2 =
foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2)
mk_app_tys t1 tys2 = IfaceAppTy t1 tys2
ppr_ty ctxt_prec (IfaceCastTy ty co)
= if_print_coercions
......@@ -770,14 +841,14 @@ defaultRuntimeRepVars sty = go emptyFsEnv
go subs ty@(IfaceTyVar tv)
| tv `elemFsEnv` subs
= IfaceTyConApp liftedRep ITC_Nil
= IfaceTyConApp liftedRep IA_Nil
| otherwise
= ty
go _ ty@(IfaceFreeTyVar tv)
| userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
-- don't require -fprint-explicit-runtime-reps for good debugging output
= IfaceTyConApp liftedRep ITC_Nil
= IfaceTyConApp liftedRep IA_Nil
| otherwise
= ty
......@@ -790,8 +861,8 @@ defaultRuntimeRepVars sty = go emptyFsEnv
go subs (IfaceFunTy arg res)
= IfaceFunTy (go subs arg) (go subs res)
go subs (IfaceAppTy x y)
= IfaceAppTy (go subs x) (go subs y)
go subs (IfaceAppTy t ts)
= IfaceAppTy (go subs t) (go_args subs ts)
go subs (IfaceDFunTy x y)
= IfaceDFunTy (go subs x) (go subs y)
......@@ -802,10 +873,10 @@ defaultRuntimeRepVars sty = go emptyFsEnv
go _ ty@(IfaceLitTy {}) = ty
go _ ty@(IfaceCoercionTy {}) = ty
go_args :: FastStringEnv () -> IfaceTcArgs -> IfaceTcArgs
go_args _ ITC_Nil = ITC_Nil
go_args subs (ITC_Vis ty args) = ITC_Vis (go subs ty) (go_args subs args)
go_args subs (ITC_Invis ty args) = ITC_Invis (go subs ty) (go_args subs args)
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)
liftedRep :: IfaceTyCon
liftedRep =
......@@ -823,24 +894,24 @@ eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
then f ty
else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
instance Outputable IfaceTcArgs where
ppr tca = pprIfaceTcArgs tca
instance Outputable IfaceAppArgs where
ppr tca = pprIfaceAppArgs tca
pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
pprIfaceTcArgs = ppr_tc_args topPrec
pprParendIfaceTcArgs = ppr_tc_args appPrec
pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc
pprIfaceAppArgs = ppr_app_args topPrec
pprParendIfaceAppArgs = ppr_app_args appPrec
ppr_tc_args :: PprPrec -> IfaceTcArgs -> SDoc
ppr_tc_args ctx_prec args
= let ppr_rest = ppr_tc_args ctx_prec
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
ITC_Nil -> empty
ITC_Vis t ts -> pprTys t ts
ITC_Invis t ts -> sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitKinds dflags
then pprTys t ts
else ppr_rest ts
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
-------------------
pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
......@@ -997,33 +1068,33 @@ pprIfaceTyList ctxt_prec ty1 ty2
-- = (tys, Just tl) means ty is of form t1:t2:...tn:tl
gather (IfaceTyConApp tc tys)
| tc `ifaceTyConHasKey` consDataConKey
, (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
, (IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil))) <- tys
, (args, tl) <- gather ty2
= (ty1:args, tl)
| tc `ifaceTyConHasKey` nilDataConKey
= ([], Nothing)
gather ty = ([], Just ty)
pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprTyTcApp ctxt_prec tc tys =
sdocWithDynFlags $ \dflags ->
getPprStyle $ \style ->
pprTyTcApp' ctxt_prec tc tys dflags style
pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceTcArgs
pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
-> DynFlags -> PprStyle -> SDoc
pprTyTcApp' ctxt_prec tc tys dflags style
| ifaceTyConName tc `hasKey` ipClassKey
, ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
, IA_Vis (IfaceLitTy (IfaceStrTyLit n)) (IA_Vis ty IA_Nil) <- tys
= maybeParen ctxt_prec funPrec
$ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
| IfaceTupleTyCon arity sort <- ifaceTyConSort info
, not (debugStyle style)
, arity == ifaceVisTcArgsLength tys
, arity == ifaceVisAppArgsLength tys
= pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
| IfaceSumTyCon arity <- ifaceTyConSort info
......@@ -1031,11 +1102,11 @@ pprTyTcApp' ctxt_prec tc tys dflags style
| tc `ifaceTyConHasKey` consDataConKey
, not (gopt Opt_PrintExplicitKinds dflags)
, ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
, IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil)) <- tys
= pprIfaceTyList ctxt_prec ty1 ty2
| tc `ifaceTyConHasKey` tYPETyConKey