diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-06-03 14:15:52 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-06-03 14:24:08 +0100 |
| commit | b4856f9f4f0fb3db473901b247d3fa94a11c25a0 (patch) | |
| tree | 64512fff57acca9baf54d0e72d516679763711a9 | |
| parent | da64c97f1c0b147ea80a34fe64fe947ba7820c00 (diff) | |
| download | haskell-b4856f9f4f0fb3db473901b247d3fa94a11c25a0.tar.gz | |
Do pretty-printing of TyThings via IfaceDecl (Trac #7730)
All the initial work on this was done fy 'archblob' (fcsernik@gmail.com);
thank you!
I reviewed the patch, started some tidying, up and then ended up in a huge
swamp of changes, not all of which I can remember now. But:
* To suppress kind arguments when we have -fno-print-explicit-kinds,
- IfaceTyConApp argument types are in a tagged list IfaceTcArgs
* To allow overloaded types to be printed with =>, add IfaceDFunTy to IfaceType.
* When printing data/type family instances for the user, I've made them
print out an informative RHS, which is a new feature. Thus
ghci> info T
data family T a
data instance T Int = T1 Int Int
data instance T Bool = T2
* In implementation terms, pprIfaceDecl has just one "context" argument,
of type IfaceSyn.ShowSub, which says
- How to print the binders of the decl
see note [Printing IfaceDecl binders] in IfaceSyn
- Which sub-comoponents (eg constructors) to print
* Moved FastStringEnv from RnEnv to OccName
It all took a ridiculously long time to do. But it's done!
35 files changed, 1135 insertions, 917 deletions
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 7769192b5d..487318bb09 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -102,7 +102,10 @@ module OccName ( -- * Lexical characteristics of Haskell names isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, - startsVarSym, startsVarId, startsConSym, startsConId + startsVarSym, startsVarId, startsConSym, startsConId, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where import Util @@ -119,6 +122,29 @@ import Data.Data %************************************************************************ %* * + FastStringEnv +%* * +%************************************************************************ + +FastStringEnv can't be in FastString becuase the env depends on UniqFM + +\begin{code} +type FastStringEnv a = UniqFM a -- Keyed by FastString + + +emptyFsEnv :: FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a + +emptyFsEnv = emptyUFM +lookupFsEnv = lookupUFM +extendFsEnv = addToUFM +mkFsEnv = listToUFM +\end{code} + +%************************************************************************ +%* * \subsection{Name space} %* * %************************************************************************ @@ -246,6 +272,9 @@ instance Data OccName where toConstr _ = abstractConstr "OccName" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id \end{code} diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 5462667c5b..c8e7ea87ff 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -23,6 +23,7 @@ module IfaceSyn ( IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceBang(..), IfaceAxBranch(..), + IfaceTyConParent(..), -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, @@ -32,7 +33,9 @@ module IfaceSyn ( freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, -- Pretty printing - pprIfaceExpr + pprIfaceExpr, + pprIfaceDecl, + ShowSub(..), ShowHowMuch(..) ) where #include "HsVersions.h" @@ -52,11 +55,13 @@ import BasicTypes import Outputable import FastString import Module -import TysWiredIn ( eqTyConName ) import Fingerprint import Binary import BooleanFormula ( BooleanFormula ) import HsBinds +import TyCon (Role (..)) +import StaticFlags (opt_PprStyle_Debug) +import Util( filterOut ) import Control.Monad import System.IO.Unsafe @@ -89,8 +94,8 @@ data IfaceDecl ifPromotable :: Bool, -- Promotable to kind level? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax - ifAxiom :: Maybe IfExtName -- The axiom, for a newtype, - -- or data/newtype family instance + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance } | IfaceSyn { ifName :: OccName, -- Type constructor @@ -266,13 +271,15 @@ instance Binary IfaceDecl where data IfaceSynTyConRhs = IfaceOpenSynFamilyTyCon - | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + [IfaceAxBranch] -- for pretty printing purposes only | IfaceAbstractClosedSynFamilyTyCon | IfaceSynonymTyCon IfaceType instance Binary IfaceSynTyConRhs where put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 - put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax + put_ bh (IfaceClosedSynFamilyTyCon ax br) = putByte bh 1 >> put_ bh ax + >> put_ bh br put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty @@ -280,7 +287,8 @@ instance Binary IfaceSynTyConRhs where ; case h of 0 -> return IfaceOpenSynFamilyTyCon 1 -> do { ax <- get bh - ; return (IfaceClosedSynFamilyTyCon ax) } + ; br <- get bh + ; return (IfaceClosedSynFamilyTyCon ax br) } 2 -> return IfaceAbstractClosedSynFamilyTyCon _ -> do { ty <- get bh ; return (IfaceSynonymTyCon ty) } } @@ -290,6 +298,9 @@ data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType -- Just False => ordinary polymorphic default method -- Just True => generic default method +instance HasOccName IfaceClassOp where + occName (IfaceClassOp n _ _) = n + instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do put_ bh (occNameFS n) @@ -315,33 +326,26 @@ instance Binary IfaceAT where defs <- get bh return (IfaceAT dec defs) -instance Outputable IfaceAxBranch where - ppr = pprAxBranch Nothing - -pprAxBranch :: Maybe IfaceTyCon -> IfaceAxBranch -> SDoc -pprAxBranch mtycon (IfaceAxBranch { ifaxbTyVars = tvs +pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs , ifaxbLHS = pat_tys - , ifaxbRHS = ty + , ifaxbRHS = rhs , ifaxbIncomps = incomps }) - = ppr tvs <+> ppr_lhs <+> char '=' <+> ppr ty $+$ + = hang (pprUserIfaceForAll tvs) + 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ nest 2 maybe_incomps - where - ppr_lhs - | Just tycon <- mtycon - = ppr (IfaceTyConApp tycon pat_tys) - | otherwise - = hsep (map ppr pat_tys) - - maybe_incomps - | [] <- incomps - = empty - - | otherwise - = parens (ptext (sLit "incompatible indices:") <+> ppr incomps) + where + pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) + maybe_incomps = ppUnless (null incomps) $ parens $ + ptext (sLit "incompatible indices:") <+> ppr incomps --- this is just like CoAxBranch +-- This is just like CoAxBranch data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbLHS :: [IfaceType] + , ifaxbLHS :: IfaceTcArgs , ifaxbRoles :: [Role] , ifaxbRHS :: IfaceType , ifaxbIncomps :: [BranchIndex] } @@ -383,7 +387,7 @@ instance Binary IfaceConDecls where visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls IfDataFamTyCon = [] +visibleIfConDecls IfDataFamTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] @@ -394,13 +398,18 @@ data IfaceConDecl ifConInfix :: Bool, -- True <=> declared infix ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality constraints + ifConEqSpec :: IfaceEqSpec, -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types ifConFields :: [OccName], -- ...ditto... (field labels) ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys +type IfaceEqSpec = [(OccName,IfaceType)] + +instance HasOccName IfaceConDecl where + occName = ifConOcc + instance Binary IfaceConDecl where put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do put_ bh a1 @@ -856,6 +865,29 @@ instance Binary IfaceLetBndr where b <- get bh c <- get bh return (IfLetBndr a b c) + +data IfaceTyConParent + = IfNoParent + | IfDataInstance IfExtName + IfaceTyCon + IfaceTcArgs + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty \end{code} Note [Empty case alternatives] @@ -1043,74 +1075,197 @@ ifaceDeclFingerprints hash decl ----------------------------- Printing IfaceDecl ------------------------------ +instance HasOccName IfaceDecl where + occName = ifName + instance Outputable IfaceDecl where - ppr = pprIfaceDecl + ppr = pprIfaceDecl showAll + +data ShowSub + = ShowSub + { ss_ppr_bndr :: OccName -> SDoc -- Pretty-printer for binders in IfaceDecl + -- See Note [Printing IfaceDecl binders] + , ss_how_much :: ShowHowMuch } + +data ShowHowMuch + = ShowHeader -- Header information only, not rhs + | ShowSome [OccName] -- [] <=> Print all sub-components + -- (n:ns) <=> print sub-component 'n' with ShowSub=ns + -- elide other sub-components to "..." + -- May 14: the list is max 1 element long at the moment + | ShowIface -- Everything including GHC-internal information (used in --show-iface) + +showAll :: ShowSub +showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _ = empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (n:_) }) thing = n == occName thing +showSub (ShowSub { ss_how_much = _ }) _ = True +\end{code} -pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, - ifIdDetails = details, ifIdInfo = info}) - = sep [ pprPrefixOcc var <+> dcolon <+> ppr ty, - nest 2 (ppr details), - nest 2 (ppr info) ] +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see PprTyThing), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. -pprIfaceDecl (IfaceForeign {ifName = tycon}) - = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. + +\begin{code} +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) + where + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifTyVars = tyvars, + ifRoles = roles, ifCons = condecls, + ifParent = parent, ifRec = isrec, + ifGadtSyntax = gadt, + ifPromotable = is_prom }) + + | gadt_style = vcat [ pp_roles + , pp_nd <+> pp_lhs <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + + gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt_style && not (null cons)) $ ptext (sLit "where") + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + + pp_lhs = case parent of + IfNoParent -> pprIfaceDeclHead context ss tycon tyvars + _ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) (pprIfDeclBndr ss tycon) tyvars roles + -- Don't display roles for data family instances (yet) + -- See discussion on Trac #8672. + + add_bars [] = empty + add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc + | otherwise = Nothing -pprIfaceDecl (IfaceSyn {ifName = tycon, - ifTyVars = tyvars, - ifSynRhs = IfaceSynonymTyCon mono_ty}) - = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (vcat [equals <+> ppr mono_ty]) + mk_user_con_res_ty :: [IfaceTvBndr] -> IfaceEqSpec -> ([IfaceTvBndr], SDoc) + mk_user_con_res_ty univ_tvs eq_spec + = (filterOut done_univ_tv univ_tvs, sdocWithDynFlags pp_res_ty) + where + gadt_env = mkFsEnv [(occNameFS occ, ty) | (occ,ty) <- eq_spec] + done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_env tv) + + pp_res_ty dflags + = case parent of + IfNoParent + -> hang (pprIfDeclBndr ss tycon) + 2 (sep (map pprParendIfaceType tc_args)) + IfDataInstance _ parent_tc tys + -> pprIfaceType (IfaceTyConApp parent_tc (substIfaceTcArgs subst tys)) + where + subst = mkIfaceTySubst tyvars tc_args + where + tc_args = map (substIfaceTyVar gadt_env . fst) (stripIfaceKindVars dflags univ_tvs) + + + pp_nd = case condecls of + IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) + IfDataFamTyCon -> ptext (sLit "data family") + IfDataTyCon _ -> ptext (sLit "data") + IfNewTyCon _ -> ptext (sLit "newtype") -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = rhs, ifSynKind = kind }) - = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (sep [dcolon <+> ppr kind, parens (pp_rhs rhs)]) + pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom] + + pp_prom | is_prom = ptext (sLit "Promotable") + | otherwise = empty + + +pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec + , ifCtxt = context, ifName = clas + , ifTyVars = tyvars, ifRoles = roles + , ifFDs = fds }) + = vcat [ pprRoles (== Nominal) (pprIfDeclBndr ss clas) tyvars roles + , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars + <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [vcat asocs, vcat dsigs, pprec])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where")) + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + pprec = ppShowIface ss (pprRec isrec) + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + +pprIfaceDecl ss (IfaceSyn { ifName = tc + , ifTyVars = tv + , ifSynRhs = IfaceSynonymTyCon mono_ty }) + = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals) + 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau]) where - pp_rhs IfaceOpenSynFamilyTyCon = ptext (sLit "open") - pp_rhs (IfaceClosedSynFamilyTyCon ax) = ptext (sLit "closed, axiom") <+> ppr ax - pp_rhs IfaceAbstractClosedSynFamilyTyCon = ptext (sLit "closed, abstract") - pp_rhs _ = panic "pprIfaceDecl syn" + (tvs, theta, tau) = splitIfaceSigmaTy mono_ty -pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, - ifCtxt = context, - ifTyVars = tyvars, ifRoles = roles, ifCons = condecls, - ifRec = isrec, ifPromotable = is_prom, - ifAxiom = mbAxiom}) - = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 2 (vcat [ pprCType cType - , pprRoles roles - , pprRec isrec <> comma <+> pp_prom - , pp_condecls tycon condecls - , pprAxiom mbAxiom]) +pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars + , ifSynRhs = rhs, ifSynKind = kind }) + = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon) + 2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs)) + , ppShowRhs ss (nest 2 (pp_branches rhs)) ] where - pp_prom | is_prom = ptext (sLit "Promotable") - | otherwise = ptext (sLit "Not promotable") - pp_nd = case condecls of - IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis) - IfDataFamTyCon -> ptext (sLit "data family") - IfDataTyCon _ -> ptext (sLit "data") - IfNewTyCon _ -> ptext (sLit "newtype") - -pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs, - ifRec = isrec}) - = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) - 2 (vcat [pprRoles roles, - pprRec isrec, - sep (map ppr ats), - sep (map ppr sigs)]) - -pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches }) - = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) - 2 (vcat $ map (pprAxBranch $ Just tycon) branches) - -pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper, - ifPatIsInfix = is_infix, - ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, - ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, - ifPatArgs = args, - ifPatTy = ty }) + pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open")) + pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract")) + pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where") + pp_rhs _ = panic "pprIfaceDecl syn" + + pp_branches (IfaceClosedSynFamilyTyCon ax brs) + = vcat (map (pprAxBranch (pprIfDeclBndr ss tycon)) brs) + $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) + pp_branches _ = empty + +pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper, + ifPatIsInfix = is_infix, + ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = args, + ifPatTy = ty }) = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt) where has_wrap = isJust wrapper @@ -1125,70 +1280,102 @@ pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper, pprCtxt [] = Nothing pprCtxt ctxt = Just $ pprIfaceContext ctxt +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (parenSymOcc var (pprIfDeclBndr ss var) <+> dcolon) + 2 (pprIfaceSigmaType ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info)] + +pprIfaceDecl _ (IfaceForeign {ifName = tycon}) + = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) + 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) + + pprCType :: Maybe CType -> SDoc -pprCType Nothing = ptext (sLit "No C type associated") +pprCType Nothing = empty pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType -pprRoles :: [Role] -> SDoc -pprRoles [] = empty -pprRoles roles = text "Roles:" <+> ppr roles +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTvBndr] -> [Role] -> SDoc +pprRoles suppress_if tyCon tyvars roles + = sdocWithDynFlags $ \dflags -> + let froles = suppressIfaceKinds dflags tyvars roles + in ppUnless (all suppress_if roles || null froles) $ + ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles) pprRec :: RecFlag -> SDoc -pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec +pprRec NonRecursive = empty +pprRec Recursive = ptext (sLit "RecFlag: Recursive") -pprAxiom :: Maybe Name -> SDoc -pprAxiom Nothing = ptext (sLit "FamilyInstance: none") -pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax +pprIfDeclBndr :: ShowSub -> OccName -> SDoc +pprIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) = ppr_bndr instance Outputable IfaceClassOp where - ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty + ppr = pprIfaceClassOp showAll + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty) + where opHdr = parenSymOcc n (pprIfDeclBndr ss n) <+> + ppShowIface ss (ppr dm) <+> dcolon instance Outputable IfaceAT where - ppr (IfaceAT d defs) - = vcat [ ppr d - , ppUnless (null defs) $ nest 2 $ - ptext (sLit "Defaults:") <+> vcat (map ppr defs) ] - -pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc -pprIfaceDeclHead context thing tyvars - = hsep [pprIfaceContextArr context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] - -pp_condecls :: OccName -> IfaceConDecls -> SDoc -pp_condecls _ (IfAbstractTyCon {}) = empty -pp_condecls _ IfDataFamTyCon = empty -pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c -pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) - (map (pprIfaceConDecl tc) cs)) - -mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType --- IA0_NOTE: This is wrong, but only used for pretty-printing. -mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2] - -pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc -pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, + ppr = pprIfaceAT showAll + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d defs) + = vcat [ pprIfaceDecl ss d + , ppUnless (null defs) $ nest 2 $ + ptext (sLit "Defaults:") <+> vcat (map (pprAxBranch pp_tc) defs) ] + where + pp_tc = ppr (ifName d) + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = sdocWithDynFlags $ \dflags -> + let ftys = stripKindArgs dflags tys + in pprIfaceTypeApp tc ftys + +pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context ss thing tyvars + = sdocWithDynFlags $ \ dflags -> + let ftyvars = stripIfaceKindVars dflags tyvars + in sep [pprIfaceContextArr context, parenSymOcc thing (pprIfDeclBndr ss thing) + <+> pprIfaceTvBndrs ftyvars] + +isVanillaIfaceConDecl :: IfaceConDecl -> Bool +isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs + , ifConEqSpec = eq_spec + , ifConCtxt = ctxt }) + = (null ex_tvs) && (null eq_spec) && (null ctxt) + +pprIfaceConDecl :: ShowSub -> Bool + -> ([IfaceTvBndr] -> IfaceEqSpec -> ([IfaceTvBndr], SDoc)) + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style mk_user_con_res_ty + (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = strs, ifConFields = fields }) - = sep [main_payload, - if is_infix then ptext (sLit "Infix") else empty, - if has_wrap then ptext (sLit "HasWrapper") else empty, - ppUnless (null strs) $ - nest 2 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), - ppUnless (null fields) $ - nest 2 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + ifConStricts = stricts, ifConFields = labels }) + | gadt_style = qualName <+> dcolon <+> ppr_ty + | otherwise = ppr_fields tys_w_strs where - ppr_bang IfNoBang = char '_' -- Want to see these - ppr_bang IfStrict = char '!' - ppr_bang IfUnpack = ptext (sLit "!!") - ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceCoercion co + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts arg_tys + qualName = pprIfDeclBndr ss name - main_payload = ppr name <+> dcolon <+> - pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - - eq_ctxt = [(mkIfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- eq_spec] + (univ_tvs', pp_res_ty) = mk_user_con_res_ty univ_tvs eq_spec + ppr_ty = pprIfaceForAllPart (univ_tvs' ++ ex_tvs) ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName @@ -1196,7 +1383,27 @@ pprIfaceConDecl tc (t:ts) -> fsep (t : map (arrow <+>) ts) [] -> panic "pp_con_taus" - pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs] + ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = ptext (sLit "{-# UNPACK #-}") + ppr_bang (IfUnpackCo co) = ptext (sLit "! {-# UNPACK #-}") <> + pprParendIfaceCoercion co + + pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty + pprBangTy (bang, ty) = ppr_bang bang <> ppr ty + + maybe_show_label (lbl,bty) + | showSub ss lbl = Just (pprIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty) + | otherwise = Nothing + + ppr_fields [ty1, ty2] + | is_infix && null labels + = sep [pprParendBangTy ty1, pp_infix_name , pprParendBangTy ty2] + where pp_infix_name = pprInfixVar (isSymOcc name) qualName + ppr_fields fields + | null labels = qualName <+> sep (map pprParendBangTy fields) + | otherwise = qualName <+> (braces $ sep $ punctuate comma $ ppr_trim $ + map maybe_show_label (zip labels fields)) instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, @@ -1208,15 +1415,15 @@ instance Outputable IfaceRule where ] instance Outputable IfaceClsInst where - ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag, - ifInstCls = cls, ifInstTys = mb_tcs}) + ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag + , ifInstCls = cls, ifInstTys = mb_tcs}) = hang (ptext (sLit "instance") <+> ppr flag <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where - ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstAxiom = tycon_ax}) + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax}) = hang (ptext (sLit "family instance") <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) 2 (equals <+> ppr tycon_ax) @@ -1233,6 +1440,9 @@ ppr_rough (Just tc) = ppr tc instance Outputable IfaceExpr where ppr e = pprIfaceExpr noParens e +noParens :: SDoc -> SDoc +noParens pp = pp + pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens @@ -1378,7 +1588,7 @@ freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& - maybe emptyNameSet unitNameSet (ifAxiom d) &&& + freeNamesIfaceTyConParent (ifParent d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = @@ -1409,7 +1619,7 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars , ifaxbLHS = lhs , ifaxbRHS = rhs }) = freeNamesIfTvBndrs tyvars &&& - fnList freeNamesIfType lhs &&& + freeNamesIfTcArgs lhs &&& freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet @@ -1420,7 +1630,8 @@ freeNamesIfIdDetails _ = emptyNameSet freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet -freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax +freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax br) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet @@ -1450,15 +1661,21 @@ freeNamesIfConDecl c = freeNamesIfKind :: IfaceType -> NameSet freeNamesIfKind = freeNamesIfType +freeNamesIfTcArgs :: IfaceTcArgs -> NameSet +freeNamesIfTcArgs (ITC_Type t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts +freeNamesIfTcArgs (ITC_Kind k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks +freeNamesIfTcArgs ITC_Nil = emptyNameSet + freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = - freeNamesIfTc tc &&& fnList freeNamesIfType ts + freeNamesIfTc tc &&& freeNamesIfTcArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t @@ -1540,8 +1757,7 @@ freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) - = freeNamesIfExpr s - &&& fnList fn_alt alts &&& fn_cons alts + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts where fn_alt (_con,_bs,r) = freeNamesIfExpr r @@ -1563,7 +1779,7 @@ freeNamesIfExpr (IfaceLet (IfaceRec as) x) freeNamesIfExpr _ = emptyNameSet freeNamesIfTc :: IfaceTyCon -> NameSet -freeNamesIfTc (IfaceTc tc) = unitNameSet tc +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfRule :: IfaceRule -> NameSet @@ -1573,13 +1789,18 @@ freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es &&& freeNamesIfExpr rhs - + freeNamesIfFamInst :: IfaceFamInst -> NameSet freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName , ifFamInstAxiom = axName }) = unitNameSet famName &&& unitNameSet axName +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys + -- helpers (&&&) :: NameSet -> NameSet -> NameSet (&&&) = unionNameSets @@ -1612,4 +1833,3 @@ not happen. Here's the one that bit me: Now, lookupModule depends on DynFlags, but the transitive dependency on the *locally-defined* type PackageState is not visible. We need to take account of the use of the data constructor PS in the pattern match. - diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index e4a789f0f5..4a19264432 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -6,17 +6,22 @@ This module defines interface types and binders \begin{code} +{-# LANGUAGE CPP #-} module IfaceType ( IfExtName, IfLclName, IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..), - IfaceTyLit(..), - IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, + IfaceTyLit(..), IfaceTcArgs(..), + IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, -- Conversion from Type -> IfaceType - toIfaceType, toIfaceKind, toIfaceContext, - toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, - toIfaceTyCon, toIfaceTyCon_name, + toIfaceType, toIfaceTypes, toIfaceKind, + toIfaceContext, toIfaceBndr, toIfaceIdBndr, + toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, + toIfaceTcArgs, + + -- Conversion from IfaceTcArgs -> IfaceType + tcArgsIfaceTypes, -- Conversion from Coercion -> IfaceCoercion toIfaceCoercion, @@ -24,31 +29,40 @@ module IfaceType ( -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, - pprIfaceBndrs, - tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart, - pprIfaceCoercion, pprParendIfaceCoercion - + pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs, + pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType, + pprIfaceCoercion, pprParendIfaceCoercion, + splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + + suppressIfaceKinds, + stripIfaceKindVars, + stripKindArgs, + substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst ) where +#include "HsVersions.h" + import Coercion +import DataCon ( dataConTyCon ) import TcType import DynFlags -import TypeRep hiding( maybeParen ) +import TypeRep import Unique( hasKey ) -import TyCon +import Util ( filterOut, lengthIs, zipWithEqual ) +import TyCon hiding ( pprPromotionQuote ) import CoAxiom import Id import Var +-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv ) import TysWiredIn import TysPrim -import PrelNames( funTyConKey ) +import PrelNames( funTyConKey, ipClassName ) import Name import BasicTypes import Binary import Outputable import FastString - -import Control.Monad +import UniqSet \end{code} %************************************************************************ @@ -77,8 +91,9 @@ data IfaceType -- A kind of universal type, used for types and kinds = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceAppTy IfaceType IfaceType | IfaceFunTy IfaceType IfaceType + | IfaceDFunTy IfaceType IfaceType | IfaceForAllTy IfaceTvBndr IfaceType - | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated + | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated -- Includes newtypes, synonyms, tuples | IfaceLitTy IfaceTyLit @@ -89,9 +104,24 @@ data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString --- Encodes type constructors, kind constructors --- coercion constructors, the lot -newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName } +-- See Note [Suppressing kinds] +-- 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. +data IfaceTcArgs + = ITC_Nil + | ITC_Type IfaceType IfaceTcArgs + | ITC_Kind IfaceKind IfaceTcArgs + +-- Encodes type constructors, kind constructors, +-- coercion constructors, the lot. +-- We have to tag them in order to pretty print them +-- properly. +data IfaceTyCon + = IfaceTc { ifaceTyConName :: IfExtName } + | IfacePromotedDataCon { ifaceTyConName :: IfExtName } + | IfacePromotedTyCon { ifaceTyConName :: IfExtName } data IfaceCoercion = IfaceReflCo Role IfaceType @@ -131,40 +161,167 @@ splitIfaceSigmaTy ty = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) } split_foralls rho = ([], rho) - split_rho (IfaceFunTy ty1 ty2) - | isIfacePredTy ty1 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } + split_rho (IfaceDFunTy ty1 ty2) + = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) + +suppressIfaceKinds :: DynFlags -> [IfaceTvBndr] -> [a] -> [a] +suppressIfaceKinds dflags tys xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = suppress tys xs + where + suppress _ [] = [] + suppress [] a = a + suppress (k:ks) a@(_:xs) + | isIfaceKindVar k = suppress ks xs + | otherwise = a + +stripIfaceKindVars :: DynFlags -> [IfaceTvBndr] -> [IfaceTvBndr] +stripIfaceKindVars dflags tyvars + | gopt Opt_PrintExplicitKinds dflags = tyvars + | otherwise = filterOut isIfaceKindVar tyvars + +isIfaceKindVar :: IfaceTvBndr -> Bool +isIfaceKindVar (_, IfaceTyConApp tc _) = ifaceTyConName tc == superKindTyConName +isIfaceKindVar _ = False + +ifTyVarsOfType :: IfaceType -> UniqSet IfLclName +ifTyVarsOfType ty + = case ty of + IfaceTyVar v -> unitUniqSet v + IfaceAppTy fun arg + -> ifTyVarsOfType fun `unionUniqSets` ifTyVarsOfType arg + IfaceFunTy arg res + -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res + IfaceDFunTy arg res + -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res + IfaceForAllTy (var,t) ty + -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets` + ifTyVarsOfType t + IfaceTyConApp _ args -> ifTyVarsOfArgs args + IfaceLitTy _ -> emptyUniqSet + +ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName +ifTyVarsOfArgs args = argv emptyUniqSet args + where + argv vs (ITC_Type t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts + argv vs (ITC_Kind k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks + argv vs ITC_Nil = vs +\end{code} + +Substitutions on IfaceType. This is only used during pretty-printing to construct +the result type of a GADT, and does not deal with binders (eg IfaceForAll), so +it doesn't need fancy capture stuff. + +\begin{code} +type IfaceTySubst = FastStringEnv IfaceType + +mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst +mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys + +substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +substIfaceType env ty + = go ty + where + go (IfaceTyVar tv) = substIfaceTyVar env tv + go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2) + 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 (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + +substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs +substIfaceTcArgs env args + = go args + where + go ITC_Nil = ITC_Nil + go (ITC_Type ty tys) = ITC_Type (substIfaceType env ty) (go tys) + go (ITC_Kind ty tys) = ITC_Kind (substIfaceType env ty) (go tys) + +substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar env tv + | Just ty <- lookupFsEnv env tv = ty + | otherwise = IfaceTyVar tv \end{code} %************************************************************************ %* * - Pretty-printing + Functions over IFaceTcArgs +%* * +%************************************************************************ + + +\begin{code} +stripKindArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs +stripKindArgs dflags tys + | gopt Opt_PrintExplicitKinds dflags = tys + | otherwise = suppressKinds tys + where + suppressKinds c + = case c of + ITC_Kind _ ts -> suppressKinds ts + _ -> c + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs +-- See Note [Suppressing kinds] +toIfaceTcArgs tc ty_args + = go (tyConKind tc) ty_args + where + go _ [] = ITC_Nil + go (ForAllTy _ res) (t:ts) = ITC_Kind (toIfaceKind t) (go res ts) + go (FunTy _ res) (t:ts) = ITC_Type (toIfaceType t) (go res ts) + go kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) + ITC_Type (toIfaceType t) (go kind ts) -- Ill-kinded + +tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType] +tcArgsIfaceTypes ITC_Nil = [] +tcArgsIfaceTypes (ITC_Kind t ts) = t : tcArgsIfaceTypes ts +tcArgsIfaceTypes (ITC_Type t ts) = t : tcArgsIfaceTypes ts +\end{code} + +Note [Suppressing kinds] +~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceTcArgs to specify which of the arguments to a type +constructor instantiate a for-all, and which are regular kind args. +This in turn used to control kind-suppression when printing types, +under the control of -fprint-explicit-kinds. See also TypeRep.suppressKinds. +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 * + + +%************************************************************************ +%* * + Functions over IFaceTyCon %* * %************************************************************************ -Precedence -~~~~~~~~~~ -@ppr_ty@ takes an @Int@ that is the precedence of the context. -The precedence levels are: -\begin{description} -\item[tOP_PREC] No parens required. -\item[fUN_PREC] Left hand argument of a function arrow. -\item[tYCON_PREC] Argument of a type constructor. -\end{description} +\begin{code} +--isPromotedIfaceTyCon :: IfaceTyCon -> Bool +--isPromotedIfaceTyCon (IfacePromotedTyCon _) = True +--isPromotedIfaceTyCon _ = False +\end{code} +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ \begin{code} -tOP_PREC, fUN_PREC, tYCON_PREC :: Int -tOP_PREC = 0 -- type in ParseIface.y -fUN_PREC = 1 -- btype in ParseIface.y -tYCON_PREC = 2 -- atype in ParseIface.y - -noParens :: SDoc -> SDoc -noParens pp = pp - -maybeParen :: Int -> Int -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty +pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc +pprIfaceInfixApp pp p pp_tc ty1 ty2 + = maybeParen p FunPrec $ + sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] + +pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp p pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) \end{code} @@ -182,9 +339,9 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, IfaceTyConApp tc []) +pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil) | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv -pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) +pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars) @@ -213,109 +370,200 @@ instance Outputable IfaceType where ppr ty = pprIfaceType ty pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc -pprIfaceType = ppr_ty tOP_PREC -pprParendIfaceType = ppr_ty tYCON_PREC - -isIfacePredTy :: IfaceType -> Bool -isIfacePredTy _ = False --- FIXME: fix this to print iface pred tys correctly --- isIfacePredTy ty = isConstraintKind (ifaceTypeKind ty) +pprIfaceType = ppr_ty TopPrec +pprParendIfaceType = ppr_ty TyConPrec -ppr_ty :: Int -> IfaceType -> SDoc +ppr_ty :: TyPrec -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ppr_ty ctxt_prec tc tys - -ppr_ty _ (IfaceLitTy n) = ppr_tylit n - +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys) +ppr_ty _ (IfaceLitTy n) = ppr_tylit n -- Function types ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - maybeParen ctxt_prec fUN_PREC $ - sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2) + maybeParen ctxt_prec FunPrec $ + sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)] where - arr | isIfacePredTy ty1 = darrow - | otherwise = arrow - ppr_fun_tail (IfaceFunTy ty1 ty2) - = (arr <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2 + = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2 ppr_fun_tail other_ty - = [arr <+> pprIfaceType other_ty] + = [arrow <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) - = maybeParen ctxt_prec tYCON_PREC $ - ppr_ty fUN_PREC ty1 <+> pprParendIfaceType ty2 + = maybeParen ctxt_prec TyConPrec $ + ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2 -ppr_ty ctxt_prec ty@(IfaceForAllTy _ _) - = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau)) - where - (tvs, theta, tau) = splitIfaceSigmaTy ty +ppr_ty ctxt_prec ty + = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty) + +instance Outputable IfaceTcArgs where + ppr tca = pprIfaceTcArgs tca + +pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc +pprIfaceTcArgs = ppr_tc_args TopPrec +pprParendIfaceTcArgs = ppr_tc_args TyConPrec + +ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc +ppr_tc_args ctx_prec args + = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts + in case args of + ITC_Nil -> empty + ITC_Type t ts -> pprTys t ts + ITC_Kind t ts -> pprTys t ts ------------------- --- needs to handle type contexts and coercion contexts, hence the --- generality -pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc -pprIfaceForAllPart tvs ctxt doc - = sep [ppr_tvs, pprIfaceContextArr ctxt, doc] +ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc +ppr_iface_sigma_type show_foralls_unconditionally ty + = ppr_iface_forall_part show_foralls_unconditionally tvs theta (ppr tau) where - ppr_tvs | null tvs = empty - | otherwise = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintExplicitForalls dflags - then ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot - else empty + (tvs, theta, tau) = splitIfaceSigmaTy ty +pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc + +ppr_iface_forall_part :: Outputable a + => Bool -> [IfaceTvBndr] -> [a] -> SDoc -> SDoc +ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc + = sep [ if show_foralls_unconditionally + then pprIfaceForAll tvs + else pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +pprIfaceForAll :: [IfaceTvBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot + +pprIfaceSigmaType :: IfaceType -> SDoc +pprIfaceSigmaType ty = ppr_iface_sigma_type False ty + +pprUserIfaceForAll :: [IfaceTvBndr] -> SDoc +pprUserIfaceForAll tvs + = sdocWithDynFlags $ \dflags -> + ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $ + pprIfaceForAll tvs + where + tv_has_kind_var (_,t) = not (isEmptyUniqSet (ifTyVarsOfType t)) ------------------- -ppr_tc_app :: (Int -> a -> SDoc) -> Int -> IfaceTyCon -> [a] -> SDoc -ppr_tc_app _ _ tc [] = ppr_tc tc - - -ppr_tc_app pp _ (IfaceTc n) [ty] - | n == listTyConName - = brackets (pp tOP_PREC ty) - | n == parrTyConName - = paBrackets (pp tOP_PREC ty) -ppr_tc_app pp _ (IfaceTc n) tys - | Just (ATyCon tc) <- wiredInNameTyThing_maybe n - , Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = tupleParens sort (sep (punctuate comma (map (pp tOP_PREC) tys))) -ppr_tc_app pp ctxt_prec tc tys - = maybeParen ctxt_prec tYCON_PREC - (sep [ppr_tc tc, nest 4 (sep (map (pp tYCON_PREC) tys))]) - -ppr_tc :: IfaceTyCon -> SDoc --- Wrap infix type constructors in parens -ppr_tc tc = wrap (ifaceTyConName tc) (ppr tc) + +-- See equivalent function in TypeRep.lhs +pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> char '\'' <> brackets (fsep (punctuate comma + (map (ppr_ty TopPrec) (ty1:arg_tys)))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1) + 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceType -> ([IfaceType], Maybe IfaceType) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tcname == consDataConName + , (ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil))) <- tys + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tcname == nilDataConName + = ([], Nothing) + where tcname = ifaceTyConName tc + gather ty = ([], Just ty) + +pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc +pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args) + +pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc +pprTyTcApp ctxt_prec tc tys dflags + | ifaceTyConName tc == ipClassName + , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys + = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty + + | ifaceTyConName tc == consDataConName + , not (gopt Opt_PrintExplicitKinds dflags) + , ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil)) <- tys + = pprIfaceTyList ctxt_prec ty1 ty2 + + | otherwise + = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds + where + tys_wo_kinds = tcArgsIfaceTypes $ stripKindArgs dflags tys + +pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys + +ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc +ppr_iface_tc_app pp _ tc [ty] + | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + where + n = ifaceTyConName tc + +ppr_iface_tc_app pp ctxt_prec tc tys + | Just (tup_sort, tup_args) <- is_tuple + = pprPromotionQuote tc <> + tupleParens tup_sort (sep (punctuate comma (map (pp TopPrec) tup_args))) + + | not (isSymOcc (nameOccName tc_name)) + = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys) + + | [ty1,ty2] <- tys -- Infix, two arguments; + -- we know nothing of precedence though + = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2 + + | tc_name == liftedTypeKindTyConName || tc_name == unliftedTypeKindTyConName + = ppr tc -- Do not wrap *, # in parens + + | otherwise + = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys) where - -- The kind * does not get wrapped in parens. - wrap name | name == liftedTypeKindTyConName = id - wrap name = parenSymOcc (getOccName name) + tc_name = ifaceTyConName tc + + is_tuple = case wiredInNameTyThing_maybe tc_name of + Just (ATyCon tc) + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + -> Just (sort, tys) + + | Just dc <- isPromotedDataCon_maybe tc + , let dc_tc = dataConTyCon dc + , isTupleTyCon dc_tc + , let arity = tyConArity dc_tc + ty_args = drop arity tys + , ty_args `lengthIs` arity + -> Just (tupleTyConSort tc, ty_args) + + _ -> Nothing + ppr_tylit :: IfaceTyLit -> SDoc ppr_tylit (IfaceNumTyLit n) = integer n ppr_tylit (IfaceStrTyLit n) = text (show n) pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc -pprIfaceCoercion = ppr_co tOP_PREC -pprParendIfaceCoercion = ppr_co tYCON_PREC +pprIfaceCoercion = ppr_co TopPrec +pprParendIfaceCoercion = ppr_co TyConPrec -ppr_co :: Int -> IfaceCoercion -> SDoc +ppr_co :: TyPrec -> IfaceCoercion -> SDoc ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r ppr_co ctxt_prec (IfaceFunCo r co1 co2) - = maybeParen ctxt_prec fUN_PREC $ - sep (ppr_co fUN_PREC co1 : ppr_fun_tail co2) + = maybeParen ctxt_prec FunPrec $ + sep (ppr_co FunPrec co1 : ppr_fun_tail co2) where ppr_fun_tail (IfaceFunCo r co1 co2) - = (arrow <> ppr_role r <+> ppr_co fUN_PREC co1) : ppr_fun_tail co2 + = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2 ppr_fun_tail other_co = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] ppr_co _ (IfaceTyConAppCo r tc cos) - = parens (ppr_tc_app ppr_co tOP_PREC tc cos) <> ppr_role r + = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r ppr_co ctxt_prec (IfaceAppCo co1 co2) - = maybeParen ctxt_prec tYCON_PREC $ - ppr_co fUN_PREC co1 <+> pprParendIfaceCoercion co2 + = maybeParen ctxt_prec TyConPrec $ + ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo _ _) - = maybeParen ctxt_prec fUN_PREC (sep [ppr_tvs, pprIfaceCoercion inner_co]) + = maybeParen ctxt_prec FunPrec (sep [ppr_tvs, pprIfaceCoercion inner_co]) where (tvs, inner_co) = split_co co ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot @@ -327,16 +575,16 @@ ppr_co ctxt_prec co@(IfaceForAllCo _ _) ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co ctxt_prec (IfaceUnivCo r ty1 ty2) - = maybeParen ctxt_prec tYCON_PREC $ + = maybeParen ctxt_prec TyConPrec $ ptext (sLit "UnivCo") <+> ppr r <+> pprParendIfaceType ty1 <+> pprParendIfaceType ty2 ppr_co ctxt_prec (IfaceInstCo co ty) - = maybeParen ctxt_prec tYCON_PREC $ + = maybeParen ctxt_prec TyConPrec $ ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos) - = maybeParen ctxt_prec tYCON_PREC + = maybeParen ctxt_prec TyConPrec (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))]) ppr_co ctxt_prec co @@ -351,9 +599,9 @@ ppr_co ctxt_prec co ; IfaceSubCo co -> (ptext (sLit "Sub"), [co]) ; _ -> panic "pprIfaceCo" } -ppr_special_co :: Int -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc ppr_special_co ctxt_prec doc cos - = maybeParen ctxt_prec tYCON_PREC + = maybeParen ctxt_prec TyConPrec (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) ppr_role :: Role -> SDoc @@ -365,14 +613,30 @@ ppr_role r = underscore <> pp_role ------------------- instance Outputable IfaceTyCon where - ppr = ppr . ifaceTyConName + ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote (IfacePromotedDataCon _ ) = char '\'' +pprPromotionQuote (IfacePromotedTyCon _) = ifPprDebug (char '\'') +pprPromotionQuote _ = empty instance Outputable IfaceCoercion where ppr = pprIfaceCoercion instance Binary IfaceTyCon where - put_ bh (IfaceTc ext) = put_ bh ext - get bh = liftM IfaceTc (get bh) + put_ bh tc = + case tc of + IfaceTc n -> putByte bh 0 >> put_ bh n + IfacePromotedDataCon n -> putByte bh 1 >> put_ bh n + IfacePromotedTyCon n -> putByte bh 2 >> put_ bh n + + get bh = + do tc <- getByte bh + case tc of + 0 -> get bh >>= return . IfaceTc + 1 -> get bh >>= return . IfacePromotedDataCon + 2 -> get bh >>= return . IfacePromotedTyCon + _ -> panic ("get IfaceTyCon " ++ show tc) instance Outputable IfaceTyLit where ppr = ppr_tylit @@ -390,6 +654,27 @@ instance Binary IfaceTyLit where ; return (IfaceStrTyLit n) } _ -> panic ("get IfaceTyLit " ++ show tag) +instance Binary IfaceTcArgs where + put_ bh tk = + case tk of + ITC_Type t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts + ITC_Kind t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts + ITC_Nil -> putByte bh 2 + + get bh = + do c <- getByte bh + case c of + 0 -> do + t <- get bh + ts <- get bh + return $! ITC_Type t ts + 1 -> do + t <- get bh + ts <- get bh + return $! ITC_Kind t ts + 2 -> return ITC_Nil + _ -> panic ("get IfaceTcArgs " ++ show c) + ------------------- pprIfaceContextArr :: Outputable a => [a] -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -398,7 +683,7 @@ pprIfaceContextArr theta = pprIfaceContext theta <+> darrow pprIfaceContext :: Outputable a => [a] -> SDoc pprIfaceContext [pred] = ppr pred -- No parens -pprIfaceContext preds = parens (sep (punctuate comma (map ppr preds))) +pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds))) instance Binary IfaceType where put_ bh (IfaceForAllTy aa ab) = do @@ -416,6 +701,10 @@ instance Binary IfaceType where putByte bh 3 put_ bh ag put_ bh ah + put_ bh (IfaceDFunTy ag ah) = do + putByte bh 4 + put_ bh ag + put_ bh ah put_ bh (IfaceTyConApp tc tys) = do { putByte bh 5; put_ bh tc; put_ bh tys } @@ -436,9 +725,11 @@ instance Binary IfaceType where 3 -> do ag <- get bh ah <- get bh return (IfaceFunTy ag ah) + 4 -> do ag <- get bh + ah <- get bh + return (IfaceDFunTy ag ah) 5 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } - 30 -> do n <- get bh return (IfaceLitTy n) @@ -558,7 +849,7 @@ instance Binary IfaceCoercion where b <- get bh c <- get bh return $ IfaceAxiomRuleCo a b c - _ -> panic ("get IfaceCoercion " ++ show tag) + _ -> panic ("get IfaceCoercion " ++ show tag) \end{code} @@ -590,8 +881,10 @@ toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (FunTy t1 t2) + | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) + | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys) toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) @@ -603,7 +896,11 @@ toIfaceCoVar = occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTyCon = toIfaceTyCon_name . tyConName +toIfaceTyCon tc + | isPromotedDataCon tc = IfacePromotedDataCon tc_name + | isPromotedTyCon tc = IfacePromotedTyCon tc_name + | otherwise = IfaceTc tc_name + where tc_name = tyConName tc toIfaceTyCon_name :: Name -> IfaceTyCon toIfaceTyCon_name = IfaceTc @@ -652,4 +949,3 @@ toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo (map toIfaceType ts) (map toIfaceCoercion cs) \end{code} - diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 8f02282d26..03ce53fff8 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -753,7 +753,7 @@ pprModIface iface , vcat (map pprUsage (mi_usages iface)) , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) - , vcat (map pprIfaceDecl (mi_decls iface)) + , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] , vcat (map ppr (mi_insts iface)) , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) @@ -819,10 +819,6 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, ppr_boot True = text "[boot]" ppr_boot False = empty -pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc -pprIfaceDecl (ver, decl) - = ppr ver $$ nest 2 (ppr decl) - pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities [] = empty pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index d1a8605b9c..e01097e7b0 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -80,6 +80,7 @@ import DataCon import PatSyn import Type import TcType +import TysPrim ( alphaTyVars ) import InstEnv import FamInstEnv import TcRnMonad @@ -1529,18 +1530,18 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches , ifTyCon = toIfaceTyCon tycon , ifRole = role , ifAxBranches = brListMap (coAxBranchToIfaceBranch - emptyTidyEnv - (brListMap coAxBranchLHS branches)) branches } + (brListMap coAxBranchLHS branches)) + branches } where name = getOccName ax -- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches -- to incompatible indices -- See Note [Storing compatibility] in CoAxiom -coAxBranchToIfaceBranch :: TidyEnv -> [[Type]] -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch env0 lhs_s +coAxBranchToIfaceBranch :: [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch lhs_s branch@(CoAxBranch { cab_incomps = incomps }) - = (coAxBranchToIfaceBranch' env0 branch) { ifaxbIncomps = iface_incomps } + = (coAxBranchToIfaceBranch' branch) { ifaxbIncomps = iface_incomps } where iface_incomps = map (expectJust "iface_incomps" . (flip findIndex lhs_s @@ -1548,17 +1549,16 @@ coAxBranchToIfaceBranch env0 lhs_s . coAxBranchLHS) incomps -- use this one for standalone branches without incompatibles -coAxBranchToIfaceBranch' :: TidyEnv -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch' env0 - (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs - , cab_roles = roles, cab_rhs = rhs }) +coAxBranchToIfaceBranch' :: CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch' (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs + , cab_roles = roles, cab_rhs = rhs }) = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs - , ifaxbLHS = map (tidyToIfaceType env1) lhs + , ifaxbLHS = tidyToIfaceTcArgs env1 lhs , ifaxbRoles = roles , ifaxbRHS = tidyToIfaceType env1 rhs , ifaxbIncomps = [] } where - (env1, tv_bndrs) = tidyTyClTyVarBndrs env0 tvs + (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs -- Don't re-bind in-scope tyvars -- See Note [CoAxBranch type variables] in CoAxiom @@ -1587,24 +1587,48 @@ tyConToIfaceDecl env tycon ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, ifPromotable = isJust (promotableTyCon_maybe tycon), - ifAxiom = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) } + ifParent = parent } | isForeignTyCon tycon = IfaceForeign { ifName = getOccName tycon, ifExtName = tyConExtName tycon } - | otherwise = pprPanic "toIfaceDecl" (ppr tycon) + | otherwise + -- For pretty printing purposes only. + = IfaceData { ifName = getOccName tycon, + ifCType = Nothing, + ifTyVars = funAndPrimTyVars, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon [], + ifRec = boolToRecFlag False, + ifGadtSyntax = False, + ifPromotable = False, + ifParent = IfNoParent } where (env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) - to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon - to_ifsyn_rhs (ClosedSynFamilyTyCon ax) - = IfaceClosedSynFamilyTyCon (coAxiomName ax) - to_ifsyn_rhs AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars + + parent = case tyConFamInstSig_maybe tycon of + Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) + (toIfaceTyCon tc) + (toIfaceTcArgs tc ty) + Nothing -> IfNoParent + + to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_ifsyn_rhs (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr + where defs = fromBranchList $ coAxiomBranches ax + ibr = map coAxBranchToIfaceBranch' defs + axn = coAxiomName ax + to_ifsyn_rhs AbstractClosedSynFamilyTyCon + = IfaceAbstractClosedSynFamilyTyCon + to_ifsyn_rhs (SynonymTyCon ty) = IfaceSynonymTyCon (tidyToIfaceType env1 ty) - to_ifsyn_rhs (BuiltInSynFamTyCon {}) = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon) + to_ifsyn_rhs (BuiltInSynFamTyCon {}) + = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) @@ -1665,7 +1689,7 @@ classToIfaceDecl env clas toIfaceAT :: ClassATItem -> IfaceAT toIfaceAT (tc, defs) - = IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' env1) defs) + = IfaceAT (tyConToIfaceDecl env1 tc) (map coAxBranchToIfaceBranch' defs) toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) @@ -1691,6 +1715,12 @@ classToIfaceDecl env clas tidyToIfaceType :: TidyEnv -> Type -> IfaceType tidyToIfaceType env ty = toIfaceType (tidyType env ty) +tidyToIfaceTcArgs :: TidyEnv -> [Type] -> IfaceTcArgs +tidyToIfaceTcArgs _ [] = ITC_Nil +tidyToIfaceTcArgs env (t:ts) + | isKind t = ITC_Kind (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts) + | otherwise = ITC_Type (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts) + tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext tidyToIfaceContext env theta = map (tidyToIfaceType env) theta diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2cf0cf7816..e5da3568a9 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -452,41 +452,26 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, ifPromotable = is_prom, - ifAxiom = mb_axiom_name }) + ifParent = mb_parent }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; parent' <- tc_parent tyvars mb_axiom_name + ; parent' <- tc_parent mb_parent ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta cons is_rec is_prom gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } where - tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent - tc_parent _ Nothing = return parent - tc_parent tyvars (Just ax_name) + tc_parent :: IfaceTyConParent -> IfL TyConParent + tc_parent IfNoParent = return parent + tc_parent (IfDataInstance ax_name _ arg_tys) = ASSERT( isNoParent parent ) do { ax <- tcIfaceCoAxiom ax_name - ; let fam_tc = coAxiomTyCon ax + ; let fam_tc = coAxiomTyCon ax ax_unbr = toUnbranchedAxiom ax - -- data families don't have branches: - branch = coAxiomSingleBranch ax_unbr - ax_tvs = coAxBranchTyVars branch - ax_lhs = coAxBranchLHS branch - tycon_tys = mkTyVarTys tyvars - subst = mkTopTvSubst (ax_tvs `zip` tycon_tys) - -- The subst matches the tyvar of the TyCon - -- with those from the CoAxiom. They aren't - -- necessarily the same, since the two may be - -- gotten from separate interface-file declarations - -- NB: ax_tvs may be shorter because of eta-reduction - -- See Note [Eta reduction for data family axioms] in TcInstDcls - lhs_tys = substTys subst ax_lhs `chkAppend` - dropList ax_tvs tycon_tys - -- The 'lhs_tys' should be 1-1 with the 'tyvars' - -- but ax_tvs maybe shorter because of eta-reduction + ; lhs_tys <- tcIfaceTcArgs arg_tys ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) } tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, @@ -503,7 +488,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, where mk_doc n = ptext (sLit "Type syonym") <+> ppr n tc_syn_rhs IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon - tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name) + tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name _) = do { ax <- tcIfaceCoAxiom ax_name ; return (ClosedSynFamilyTyCon ax) } tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon @@ -551,7 +536,7 @@ tc_iface_decl _parent ignore_prags tc_at cls (IfaceAT tc_decl defs_decls) = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl - defs <- forkM (mk_at_doc tc) (tc_ax_branches tc defs_decls) + defs <- forkM (mk_at_doc tc) (tc_ax_branches defs_decls) -- Must be done lazily in case the RHS of the defaults mention -- the type constructor being defined here -- e.g. type AT a; type AT b = AT [b] Trac #8002 @@ -574,7 +559,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc , ifAxBranches = branches, ifRole = role }) = do { tc_name <- lookupIfaceTop ax_occ ; tc_tycon <- tcIfaceTyCon tc - ; tc_branches <- tc_ax_branches tc_tycon branches + ; tc_branches <- tc_ax_branches branches ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name , co_ax_name = tc_name , co_ax_tc = tc_tycon @@ -614,16 +599,16 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name -tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch] -tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches +tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] +tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches -tc_ax_branch :: Kind -> [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] -tc_ax_branch tc_kind prev_branches +tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] +tc_ax_branch prev_branches (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom - { tc_lhs <- tcIfaceTcArgs tc_kind lhs -- See Note [Checking IfaceTypes vs IfaceKinds] + { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds] ; tc_rhs <- tcIfaceType rhs ; let br = CoAxBranch { cab_loc = noSrcSpan , cab_tvs = tvs @@ -963,25 +948,38 @@ tcIfaceType :: IfaceType -> IfL Type tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } -tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } +tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2 +tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2 tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc - ; tks' <- tcIfaceTcArgs (tyConKind tc') tks + ; tks' <- tcIfaceTcArgs tks ; return (mkTyConApp tc' tks') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } -tcIfaceTypes :: [IfaceType] -> IfL [Type] -tcIfaceTypes tys = mapM tcIfaceType tys - -tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type] -tcIfaceTcArgs _ [] - = return [] -tcIfaceTcArgs kind (tk:tks) - = case splitForAllTy_maybe kind of - Nothing -> tcIfaceTypes (tk:tks) - Just (_, kind') -> do { k' <- tcIfaceKind tk - ; tks' <- tcIfaceTcArgs kind' tks - ; return (k':tks') } - +tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type +tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } + +tcIfaceKind :: IfaceKind -> IfL Type +tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } +tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2 +tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2 +tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l) +tcIfaceKind k = tcIfaceType k + +tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type +tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } + +tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type] +tcIfaceTcArgs args + = case args of + ITC_Type t ts -> + do { t' <- tcIfaceType t + ; ts' <- tcIfaceTcArgs ts + ; return (t':ts') } + ITC_Kind k ks -> + do { k' <- tcIfaceKind k + ; ks' <- tcIfaceTcArgs ks + ; return (k':ks') } + ITC_Nil -> return [] ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType tcIfaceCtxt sts = mapM tcIfaceType sts @@ -990,43 +988,8 @@ tcIfaceCtxt sts = mapM tcIfaceType sts tcIfaceTyLit :: IfaceTyLit -> IfL TyLit tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) - ------------------------------------------ -tcIfaceKind :: IfaceKind -> IfL Kind -- See Note [Checking IfaceTypes vs IfaceKinds] -tcIfaceKind (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } -tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') } -tcIfaceKind (IfaceFunTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') } -tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') } -tcIfaceKind (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') } -tcIfaceKind t = pprPanic "tcIfaceKind" (ppr t) -- IfaceCoApp, IfaceLitTy - -tcIfaceKinds :: [IfaceKind] -> IfL [Kind] -tcIfaceKinds tys = mapM tcIfaceKind tys \end{code} -Note [Checking IfaceTypes vs IfaceKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to know whether we are checking a *type* or a *kind*. -Consider module M where - Proxy :: forall k. k -> * - data T = T -and consider the two IfaceTypes - M.Proxy * M.T{tc} - M.Proxy 'M.T{tc} 'M.T(d} -The first is conventional, but in the latter we use the promoted -type constructor (as a kind) and data constructor (as a type). However, -the Name of the promoted type constructor is just M.T; it's the *same name* -as the ordinary type constructor. - -We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy. -Instead we use context to distinguish, as in the source language. - - When checking a kind, we look up M.T{tc} and promote it - - When checking a type, we look up M.T{tc} and don't promote it - and M.T{d} and promote it - See tcIfaceKindCon and tcIfaceKTyCon respectively - -This context business is why we need tcIfaceTcArgs, and tcIfaceApps - %************************************************************************ %* * @@ -1192,7 +1155,7 @@ tcIfaceApps fun arg go_up fun _ [] = return fun go_up fun fun_ty (IfaceType t : args) | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty - = do { t' <- if isKindVar tv -- See Note [Checking IfaceTypes vs IfaceKinds] + = do { t' <- if isKindVar tv then tcIfaceKind t else tcIfaceType t ; let fun_ty' = substTyWith [tv] [t'] body_ty @@ -1439,26 +1402,19 @@ tcIfaceGlobal name -- emasculated form (e.g. lacking data constructors). tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon (IfaceTc name) - = do { thing <- tcIfaceGlobal name - ; case thing of -- A "type constructor" can be a promoted data constructor - -- c.f. Trac #5881 - ATyCon tc -> return tc - AConLike (RealDataCon dc) -> return (promoteDataCon dc) - _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) } - -tcIfaceKindCon :: IfaceTyCon -> IfL TyCon -tcIfaceKindCon (IfaceTc name) - = do { thing <- tcIfaceGlobal name - ; case thing of -- A "type constructor" here is a promoted type constructor - -- c.f. Trac #5881 - ATyCon tc - | isSuperKind (tyConKind tc) - -> return tc -- Mainly just '*' or 'AnyK' - | Just prom_tc <- promotableTyCon_maybe tc - -> return prom_tc - - _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) } +tcIfaceTyCon itc + = do { + ; thing <- tcIfaceGlobal (ifaceTyConName itc) + ; case itc of + IfaceTc _ -> return $ tyThingTyCon thing + IfacePromotedDataCon _ -> return $ promoteDataCon $ tyThingDataCon thing + IfacePromotedTyCon name -> + let ktycon tc + | isSuperKind (tyConKind tc) = return tc + | Just prom_tc <- promotableTyCon_maybe tc = return prom_tc + | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) + in ktycon (tyThingTyCon thing) + } tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name @@ -1522,7 +1478,7 @@ bindIfaceTyVars bndrs thing_inside (occs,kinds) = unzip bndrs isSuperIfaceKind :: IfaceKind -> Bool -isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName +isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName isSuperIfaceKind _ = False mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 5c0cbf7c4d..13d4f87009 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -262,6 +262,7 @@ import InteractiveEval import TcRnDriver ( runTcInteractive ) #endif +import PprTyThing ( pprFamInst ) import HscMain import GhcMake import DriverPipeline ( compileOne' ) @@ -284,7 +285,7 @@ import DataCon import Name hiding ( varName ) import Avail import InstEnv -import FamInstEnv +import FamInstEnv ( FamInst ) import SrcLoc import CoreSyn import TidyPgm diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 6dda9f1ba0..890502c4f6 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -6,6 +6,7 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -19,50 +20,47 @@ module PprTyThing ( pprTyThingLoc, pprTyThingInContextLoc, pprTyThingHdr, - pprTypeForUser + pprTypeForUser, + pprFamInst ) where +#include "HsVersions.h" + import TypeRep ( TyThing(..) ) -import DataCon -import Id -import TyCon -import Class -import Coercion( pprCoAxBranch ) -import CoAxiom( CoAxiom(..), brListMap ) +import CoAxiom ( coAxiomTyCon ) import HscTypes( tyThingParent_maybe ) -import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy ) -import Kind( synTyConResKind ) -import TypeRep( pprTvBndrs, pprUserForAll, suppressKinds ) -import TysPrim( alphaTyVars ) import MkIface ( tyThingToIfaceDecl ) +import Type ( tidyOpenType ) +import IfaceSyn ( pprIfaceDecl, ShowSub(..), ShowHowMuch(..) ) +import FamInstEnv( FamInst( .. ), FamFlavor(..) ) import TcType import Name import VarEnv( emptyTidyEnv ) -import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API --- This should be a good source of sample code for using the GHC API to --- inspect source code entities. - -type ShowSub = [Name] --- [] <=> print all sub-components of the current thing --- (n:ns) <=> print sub-component 'n' with ShowSub=ns --- elide other sub-components to "..." -showAll :: ShowSub -showAll = [] +-------------------- +-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. +pprFamInst :: FamInst -> SDoc +-- * For data instances we go via pprTyThing of the represntational TyCon, +-- becuase there is already much cleverness associated with printing +-- data type declarations that I don't want to duplicate +-- * For type instances we print directly here; there is no TyCon +-- to give to pprTyThing +-- +-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes -showSub :: NamedThing n => ShowSub -> n -> Bool -showSub [] _ = True -showSub (n:_) thing = n == getName thing +pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) -showSub_maybe :: NamedThing n => ShowSub -> n -> Maybe ShowSub -showSub_maybe [] _ = Just [] -showSub_maybe (n:ns) thing = if n == getName thing then Just ns - else Nothing +pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt (getName axiom)) $ + hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) ---------------------------- -- | Pretty-prints a 'TyThing' with its defining location. @@ -72,7 +70,13 @@ pprTyThingLoc tyThing -- | Pretty-prints a 'TyThing'. pprTyThing :: TyThing -> SDoc -pprTyThing thing = ppr_ty_thing (Just showAll) thing +pprTyThing = ppr_ty_thing False [] + +-- | Pretty-prints the 'TyThing' header. For functions and data constructors +-- the function is equivalent to 'pprTyThing' but for type constructors +-- and classes it prints only the header part of the declaration. +pprTyThingHdr :: TyThing -> SDoc +pprTyThingHdr = ppr_ty_thing True [] -- | Pretty-prints a 'TyThing' in context: that is, if the entity -- is a data constructor, record selector, or class method, then @@ -83,8 +87,8 @@ pprTyThingInContext thing = go [] thing where go ss thing = case tyThingParent_maybe thing of - Just parent -> go (getName thing : ss) parent - Nothing -> ppr_ty_thing (Just ss) thing + Just parent -> go (getOccName thing : ss) parent + Nothing -> ppr_ty_thing False ss thing -- | Like 'pprTyThingInContext', but adds the defining location. pprTyThingInContextLoc :: TyThing -> SDoc @@ -92,65 +96,26 @@ pprTyThingInContextLoc tyThing = showWithLoc (pprDefinedAt (getName tyThing)) (pprTyThingInContext tyThing) --- | Pretty-prints the 'TyThing' header. For functions and data constructors --- the function is equivalent to 'pprTyThing' but for type constructors --- and classes it prints only the header part of the declaration. -pprTyThingHdr :: TyThing -> SDoc -pprTyThingHdr = ppr_ty_thing Nothing - ------------------------ +ppr_ty_thing :: Bool -> [OccName] -> TyThing -> SDoc -- NOTE: We pretty-print 'TyThing' via 'IfaceDecl' so that we can reuse the -- 'TyCon' tidying happening in 'tyThingToIfaceDecl'. See #8776 for details. -ppr_ty_thing :: Maybe ShowSub -> TyThing -> SDoc -ppr_ty_thing mss tyThing = case tyThing of - AnId id -> pprId id - ATyCon tyCon -> case mss of - Nothing -> pprTyConHdr tyCon - Just ss -> pprTyCon ss tyCon - _ -> ppr $ tyThingToIfaceDecl tyThing - -pprTyConHdr :: TyCon -> SDoc -pprTyConHdr tyCon - | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon - = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys - | Just cls <- tyConClass_maybe tyCon - = pprClassHdr cls - | otherwise - = sdocWithDynFlags $ \dflags -> - ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon - <+> pprTvBndrs (suppressKinds dflags (tyConKind tyCon) vars) - where - vars | isPrimTyCon tyCon || - isFunTyCon tyCon = take (tyConArity tyCon) alphaTyVars - | otherwise = tyConTyVars tyCon - - keyword | isSynTyCon tyCon = sLit "type" - | isNewTyCon tyCon = sLit "newtype" - | otherwise = sLit "data" - - opt_family - | isFamilyTyCon tyCon = ptext (sLit "family") - | otherwise = empty - - opt_stupid -- The "stupid theta" part of the declaration - | isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon) - | otherwise = empty -- Returns 'empty' if null theta - -pprClassHdr :: Class -> SDoc -pprClassHdr cls - = sdocWithDynFlags $ \dflags -> - ptext (sLit "class") <+> - sep [ pprThetaArrowTy (classSCTheta cls) - , ppr_bndr cls - <+> pprTvBndrs (suppressKinds dflags (tyConKind (classTyCon cls)) tvs) - , pprFundeps funDeps ] +ppr_ty_thing hdr_only path ty_thing + = pprIfaceDecl (ShowSub { ss_how_much = how_much, ss_ppr_bndr = ppr_bndr }) if_decl where - (tvs, funDeps) = classTvsFds cls - -pprId :: Var -> SDoc -pprId ident - = hang (ppr_bndr ident <+> dcolon) - 2 (pprTypeForUser (idType ident)) + how_much | hdr_only = ShowHeader + | otherwise = ShowSome path + if_decl = tyThingToIfaceDecl ty_thing + name = getName ty_thing + ppr_bndr :: OccName -> SDoc + ppr_bndr | isBuiltInSyntax name + = ppr + | otherwise + = case nameModule_maybe name of + Just mod -> \ occ -> getPprStyle $ \sty -> + pprModulePrefix sty mod occ <> ppr occ + Nothing -> WARN( True, ppr name ) ppr + -- Nothing is unexpected here; TyThings have External names pprTypeForUser :: Type -> SDoc -- We do two things here. @@ -165,177 +130,15 @@ pprTypeForUser ty = pprSigmaType (mkSigmaTy tvs ctxt tau) where (tvs, ctxt, tau) = tcSplitSigmaTy tidy_ty - (_, tidy_ty) = tidyOpenType emptyTidyEnv ty + (_, tidy_ty) = tidyOpenType emptyTidyEnv ty -- Often the types/kinds we print in ghci are fully generalised -- and have no free variables, but it turns out that we sometimes -- print un-generalised kinds (eg when doing :k T), so it's -- better to use tidyOpenType here -pprTyCon :: ShowSub -> TyCon -> SDoc -pprTyCon ss tyCon - | Just syn_rhs <- synTyConRhs_maybe tyCon - = case syn_rhs of - OpenSynFamilyTyCon -> pp_tc_with_kind - BuiltInSynFamTyCon {} -> pp_tc_with_kind - - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) - -> hang closed_family_header - 2 (vcat (brListMap (pprCoAxBranch tyCon) branches)) - - AbstractClosedSynFamilyTyCon - -> closed_family_header <+> ptext (sLit "..") - - SynonymTyCon rhs_ty - -> hang (pprTyConHdr tyCon <+> equals) - 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type! - - -- e.g. type T = forall a. a->a - | Just cls <- tyConClass_maybe tyCon - = (pp_roles (== Nominal)) $$ pprClass ss cls - - | otherwise - = (pp_roles (== Representational)) $$ pprAlgTyCon ss tyCon - - where - -- if, for each role, suppress_if role is True, then suppress the role - -- output - pp_roles :: (Role -> Bool) -> SDoc - pp_roles suppress_if - = sdocWithDynFlags $ \dflags -> - let roles = suppressKinds dflags (tyConKind tyCon) (tyConRoles tyCon) - in ppUnless (isFamInstTyCon tyCon || all suppress_if roles) $ - -- Don't display roles for data family instances (yet) - -- See discussion on Trac #8672. - ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr roles) - - pp_tc_with_kind = vcat [ pp_roles (const True) - , pprTyConHdr tyCon <+> dcolon - <+> pprTypeForUser (synTyConResKind tyCon) ] - closed_family_header - = pp_tc_with_kind <+> ptext (sLit "where") - -pprAlgTyCon :: ShowSub -> TyCon -> SDoc -pprAlgTyCon ss tyCon - | gadt = pprTyConHdr tyCon <+> ptext (sLit "where") $$ - nest 2 (vcat (ppr_trim (map show_con datacons))) - | otherwise = hang (pprTyConHdr tyCon) - 2 (add_bars (ppr_trim (map show_con datacons))) - where - datacons = tyConDataCons tyCon - gadt = any (not . isVanillaDataCon) datacons - - ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc) - show_con dc - | ok_con dc = Just (pprDataConDecl ss gadt dc) - | otherwise = Nothing - -pprDataConDecl :: ShowSub -> Bool -> DataCon -> SDoc -pprDataConDecl ss gadt_style dataCon - | not gadt_style = ppr_fields tys_w_strs - | otherwise = ppr_bndr dataCon <+> dcolon <+> - sep [ pprUserForAll forall_tvs, pprThetaArrowTy theta, pp_tau ] - -- Printing out the dataCon as a type signature, in GADT style - where - (forall_tvs, theta, tau) = tcSplitSigmaTy (dataConUserType dataCon) - (arg_tys, res_ty) = tcSplitFunTys tau - labels = dataConFieldLabels dataCon - stricts = dataConStrictMarks dataCon - tys_w_strs = zip (map user_ify stricts) arg_tys - - pp_tau = foldr add (ppr res_ty) tys_w_strs - add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty - - pprParendBangTy (bang,ty) = ppr bang <> pprParendType ty - pprBangTy (bang,ty) = ppr bang <> ppr ty - - -- See Note [Printing bangs on data constructors] - user_ify :: HsBang -> HsBang - user_ify bang | opt_PprStyle_Debug = bang - user_ify HsStrict = HsUserBang Nothing True - user_ify (HsUnpack {}) = HsUserBang (Just True) True - user_ify bang = bang - - maybe_show_label (lbl,bty) - | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty) - | otherwise = Nothing - - ppr_fields [ty1, ty2] - | dataConIsInfix dataCon && null labels - = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2] - ppr_fields fields - | null labels - = ppr_bndr dataCon <+> sep (map pprParendBangTy fields) - | otherwise - = ppr_bndr dataCon - <+> (braces $ sep $ punctuate comma $ ppr_trim $ - map maybe_show_label (zip labels fields)) - -pprClass :: ShowSub -> Class -> SDoc -pprClass ss cls - | null methods && null assoc_ts - = pprClassHdr cls - | otherwise - = vcat [ pprClassHdr cls <+> ptext (sLit "where") - , nest 2 (vcat $ ppr_trim $ - map show_at assoc_ts ++ map show_meth methods)] - where - methods = classMethods cls - assoc_ts = classATs cls - show_meth id | showSub ss id = Just (pprClassMethod id) - | otherwise = Nothing - show_at tc = case showSub_maybe ss tc of - Just ss' -> Just (pprTyCon ss' tc) - Nothing -> Nothing - -pprClassMethod :: Id -> SDoc -pprClassMethod id - = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser op_ty) - where - -- Here's the magic incantation to strip off the dictionary - -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. - -- - -- It's important to tidy it *before* splitting it up, so that if - -- we have class C a b where - -- op :: forall a. a -> b - -- then the inner forall on op gets renamed to a1, and we print - -- (when dropping foralls) - -- class C a b where - -- op :: a1 -> b - - tidy_sel_ty = tidyTopType (idType id) - (_sel_tyvars, rho_ty) = splitForAllTys tidy_sel_ty - op_ty = funResultTy rho_ty - -ppr_trim :: [Maybe SDoc] -> [SDoc] --- Collapse a group of Nothings to a single "..." -ppr_trim xs - = snd (foldr go (False, []) xs) - where - go (Just doc) (_, so_far) = (False, doc : so_far) - go Nothing (True, so_far) = (True, so_far) - go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far) - -add_bars :: [SDoc] -> SDoc -add_bars [] = empty -add_bars [c] = equals <+> c -add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) - --- Wrap operators in () -ppr_bndr :: NamedThing a => a -> SDoc -ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName a)) - showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) -- The tab tries to make them line up a bit where comment = ptext (sLit "--") - -{- -Note [Printing bangs on data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For imported data constructors the dataConStrictMarks are the -representation choices (see Note [Bangs on data constructor arguments] -in DataCon.lhs). So we have to fiddle a little bit here to turn them -back into user-printable form. --} diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 58f32bc740..bdc2cdfe59 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -40,10 +40,7 @@ module RnEnv ( warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, kindSigErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext, - - -- FsEnv - FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + HsDocContext(..), docOfHsDocContext ) where #include "HsVersions.h" @@ -61,7 +58,6 @@ import NameSet import NameEnv import Avail import Module -import UniqFM import ConLike import DataCon ( dataConFieldLabels, dataConTyCon ) import TyCon ( isTupleTyCon, tyConArity ) @@ -1082,20 +1078,6 @@ deprecation declarations, and lookup of names in GHCi. \begin{code} -------------------------------- -type FastStringEnv a = UniqFM a -- Keyed by FastString - - -emptyFsEnv :: FastStringEnv a -lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a -extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a -mkFsEnv :: [(FastString,a)] -> FastStringEnv a - -emptyFsEnv = emptyUFM -lookupFsEnv = lookupUFM -extendFsEnv = addToUFM -mkFsEnv = listToUFM - --------------------------------- type MiniFixityEnv = FastStringEnv (Located Fixity) -- Mini fixity env for the names we're about -- to bind, in a single binding group diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index b6585f0878..475158ff5a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1836,8 +1836,5 @@ ppr_tydecls tycons -- Print type constructor info; sort by OccName = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons)) where - ppr_tycon tycon = vcat [ ppr (tyConName tycon) <+> dcolon <+> ppr (tyConKind tycon) - -- Temporarily print the kind signature too - , ppr (tyThingToIfaceDecl (ATyCon tycon)) ] - + ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ] \end{code} diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 525b606193..fcf7cb443f 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -10,7 +10,7 @@ FamInstEnv: Type checked family instance declarations module FamInstEnv ( FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInstHdr, pprFamInsts, + pprFamInst, pprFamInsts, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, @@ -166,12 +166,13 @@ instance Outputable FamInst where ppr = pprFamInst -- Prints the FamInst as a family instance declaration +-- NB: FamInstEnv.pprFamInst is used only for internal, debug printing +-- See pprTyThing.pprFamInst for printing for the user pprFamInst :: FamInst -> SDoc pprFamInst famInst = hang (pprFamInstHdr famInst) 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> ppr ax) - , ifPprDebug (ptext (sLit "RHS:") <+> ppr (famInstRHS famInst)) - , ptext (sLit "--") <+> pprDefinedAt (getName famInst)]) + , ifPprDebug (ptext (sLit "RHS:") <+> ppr (famInstRHS famInst)) ]) where ax = fi_axiom famInst @@ -198,6 +199,9 @@ pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) else pprTypeApp fam_tc (etad_lhs_tys ++ mkTyVarTys extra_tvs) -- Without -dppr-debug, eta-expand -- See Trac #8674 + -- (This is probably over the top now that we use this + -- only for internal debug printing; PprTyThing.pprFamInst + -- is used for user-level printing.) | otherwise = vanilla_pp_head diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 3f93972d76..53ada93126 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1494,7 +1494,7 @@ kindOfType norm str $ do (ty, kind) <- GHC.typeKind norm str printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind - , ppWhen norm $ equals <+> ppr ty ] + , ppWhen norm $ equals <+> pprTypeForUser ty ] ----------------------------------------------------------------------------- diff --git a/testsuite/tests/ghci/scripts/T4087.stdout b/testsuite/tests/ghci/scripts/T4087.stdout index 3f600bd78d..770a3e1f57 100644 --- a/testsuite/tests/ghci/scripts/T4087.stdout +++ b/testsuite/tests/ghci/scripts/T4087.stdout @@ -1,4 +1,4 @@ type role Equal nominal nominal data Equal a b where - Equal :: Equal a a + Equal :: Equal a1 a1 -- Defined at T4087.hs:5:1 diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index 1f44bd1051..29bca027ce 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -1,18 +1,18 @@ type family A a b :: * -- Defined at T4175.hs:7:1 -type instance A (B a) b -- Defined at T4175.hs:10:1 -type instance A (Maybe a) a -- Defined at T4175.hs:9:1 -type instance A Int Int -- Defined at T4175.hs:8:1 +type instance A (B a) b = () -- Defined at T4175.hs:10:1 +type instance A (Maybe a) a = a -- Defined at T4175.hs:9:1 +type instance A Int Int = () -- Defined at T4175.hs:8:1 type role B nominal data family B a -- Defined at T4175.hs:12:1 instance G B -- Defined at T4175.hs:34:10 -data instance B () -- Defined at T4175.hs:13:15 -type instance A (B a) b -- Defined at T4175.hs:10:1 +data instance B () = MkB -- Defined at T4175.hs:13:15 +type instance A (B a) b = () -- Defined at T4175.hs:10:1 class C a where type family D a b :: * -- Defined at T4175.hs:16:5 -type D () () -- Defined at T4175.hs:22:5 -type D Int () -- Defined at T4175.hs:19:5 +type instance D () () = Bool -- Defined at T4175.hs:22:5 +type instance D Int () = String -- Defined at T4175.hs:19:5 type family E a :: * where E () = Bool E Int = String @@ -25,9 +25,9 @@ instance Eq () -- Defined in ‘GHC.Classes’ instance Ord () -- Defined in ‘GHC.Classes’ instance Read () -- Defined in ‘GHC.Read’ instance Show () -- Defined in ‘GHC.Show’ -type D () () -- Defined at T4175.hs:22:5 -type D Int () -- Defined at T4175.hs:19:5 -data instance B () -- Defined at T4175.hs:13:15 +type instance D () () = Bool -- Defined at T4175.hs:22:5 +type instance D Int () = String -- Defined at T4175.hs:19:5 +data instance B () = MkB -- Defined at T4175.hs:13:15 data Maybe a = Nothing | Just a -- Defined in ‘Data.Maybe’ instance Eq a => Eq (Maybe a) -- Defined in ‘Data.Maybe’ instance Monad Maybe -- Defined in ‘Data.Maybe’ @@ -35,7 +35,7 @@ instance Functor Maybe -- Defined in ‘Data.Maybe’ instance Ord a => Ord (Maybe a) -- Defined in ‘Data.Maybe’ instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ -type instance A (Maybe a) a -- Defined at T4175.hs:9:1 +type instance A (Maybe a) a = a -- Defined at T4175.hs:9:1 data Int = I# Int# -- Defined in ‘GHC.Types’ instance C Int -- Defined at T4175.hs:18:10 instance Bounded Int -- Defined in ‘GHC.Enum’ @@ -47,7 +47,7 @@ instance Ord Int -- Defined in ‘GHC.Classes’ instance Read Int -- Defined in ‘GHC.Read’ instance Real Int -- Defined in ‘GHC.Real’ instance Show Int -- Defined in ‘GHC.Show’ -type D Int () -- Defined at T4175.hs:19:5 -type instance A Int Int -- Defined at T4175.hs:8:1 +type instance D Int () = String -- Defined at T4175.hs:19:5 +type instance A Int Int = () -- Defined at T4175.hs:8:1 class Z a -- Defined at T4175.hs:28:1 instance F (Z a) -- Defined at T4175.hs:31:10 diff --git a/testsuite/tests/ghci/scripts/T5417.stdout b/testsuite/tests/ghci/scripts/T5417.stdout index 73d1de932d..1085a1750f 100644 --- a/testsuite/tests/ghci/scripts/T5417.stdout +++ b/testsuite/tests/ghci/scripts/T5417.stdout @@ -6,4 +6,4 @@ class C.C1 a where type role C.F nominal data family C.F a -- Defined at T5417a.hs:5:5 -data C.F (B1 a) -- Defined at T5417.hs:8:10 +data instance C.F (B1 a) = B2 a -- Defined at T5417.hs:8:10 diff --git a/testsuite/tests/ghci/scripts/T7873.stdout b/testsuite/tests/ghci/scripts/T7873.stdout index 6f9f55a8af..215757bb69 100644 --- a/testsuite/tests/ghci/scripts/T7873.stdout +++ b/testsuite/tests/ghci/scripts/T7873.stdout @@ -1,6 +1,6 @@ data D1 where - MkD1 :: (forall (k :: BOX) (p :: k -> *) (a :: k). - p a -> Int) -> D1 + MkD1 :: (forall (k1 :: BOX) (p :: k1 -> *) (a :: k1). p a -> Int) + -> D1 -- Defined at <interactive>:3:1 data D2 where MkD2 :: (forall (p :: k -> *) (a :: k). p a -> Int) -> D2 diff --git a/testsuite/tests/ghci/scripts/T7939.stdout b/testsuite/tests/ghci/scripts/T7939.stdout index a4793766a6..feb890c578 100644 --- a/testsuite/tests/ghci/scripts/T7939.stdout +++ b/testsuite/tests/ghci/scripts/T7939.stdout @@ -3,21 +3,23 @@ class Foo (a :: k) where -- Defined at T7939.hs:6:4 Bar :: k -> * -> * type family F a :: * -- Defined at T7939.hs:8:1 -type instance F Int -- Defined at T7939.hs:9:1 +type instance F Int = Bool -- Defined at T7939.hs:9:1 F :: * -> * -type family G a :: * where G Int = Bool +type family G a :: * where + G Int = Bool -- Defined at T7939.hs:11:1 G :: * -> * -type family H (a :: Bool) :: Bool where H 'False = 'True +type family H (a :: Bool) :: Bool where + H 'False = 'True -- Defined at T7939.hs:14:1 H :: Bool -> Bool type family J (a :: [k]) :: Bool where - J '[] = 'False - forall (k :: BOX) (h :: k) (t :: [k]). J (h : t) = 'True + J k '[] = 'False + forall (k :: BOX) (h :: k) (t :: [k]). J k (h : t) = 'True -- Defined at T7939.hs:17:1 J :: [k] -> Bool type family K (a :: [k]) :: Maybe k where - K '[] = 'Nothing - forall (k :: BOX) (h :: k) (t :: [k]). K (h : t) = 'Just h + K k '[] = 'Nothing + forall (k :: BOX) (h :: k) (t :: [k]). K k (h : t) = 'Just h -- Defined at T7939.hs:21:1 K :: [k] -> Maybe k diff --git a/testsuite/tests/ghci/scripts/T8674.stdout b/testsuite/tests/ghci/scripts/T8674.stdout index a4f5bbff6e..6c13176e66 100644 --- a/testsuite/tests/ghci/scripts/T8674.stdout +++ b/testsuite/tests/ghci/scripts/T8674.stdout @@ -1,5 +1,5 @@ type role Sing nominal data family Sing (a :: k) -- Defined at T8674.hs:4:1 -data instance Sing Bool -- Defined at T8674.hs:6:15 -data instance Sing a -- Defined at T8674.hs:5:15 +data instance Sing Bool = SBool -- Defined at T8674.hs:6:15 +data instance Sing a = SNil -- Defined at T8674.hs:5:15 diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index 5918e13082..1b5c47003b 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -147,6 +147,7 @@ test('T7627', normal, ghci_script, ['T7627.script']) test('T7627b', normal, ghci_script, ['T7627b.script']) test('T7586', normal, ghci_script, ['T7586.script']) test('T4175', normal, ghci_script, ['T4175.script']) +test('T7730', combined_output, ghci_script, ['T7730.script']) test('T7872', normal, ghci_script, ['T7872.script']) test('T7873', normal, ghci_script, ['T7873.script']) test('T7939', normal, ghci_script, ['T7939.script']) diff --git a/testsuite/tests/ghci/scripts/ghci025.stdout b/testsuite/tests/ghci/scripts/ghci025.stdout index 9308dd3f39..9cc88b8a07 100644 --- a/testsuite/tests/ghci/scripts/ghci025.stdout +++ b/testsuite/tests/ghci/scripts/ghci025.stdout @@ -11,7 +11,7 @@ class C a b where c4 :: a1 -> b c1 :: (C a b, N b) => a -> b c2 :: (C a b, N b, S b) => a -> b -c3 :: C a b => forall a1. a1 -> b +c3 :: C a b => forall a. a -> b c4 :: C a b => forall a1. a1 -> b -- imported via Control.Monad class Monad m => MonadPlus (m :: * -> *) where @@ -69,7 +69,7 @@ class C a b where c4 :: a1 -> b c1 :: (C a b, N b) => a -> b c2 :: (C a b, N b, S b) => a -> b -c3 :: C a b => forall a1. a1 -> b +c3 :: C a b => forall a. a -> b c4 :: C a b => forall a1. a1 -> b :browse! T -- with -fprint-explicit-foralls -- defined locally @@ -83,7 +83,7 @@ class C a b where c4 :: forall a1. a1 -> b c1 :: forall a b. (C a b, N b) => a -> b c2 :: forall a b. (C a b, N b, S b) => a -> b -c3 :: forall a b. C a b => forall a1. a1 -> b +c3 :: forall a b. C a b => forall a. a -> b c4 :: forall a b. C a b => forall a1. a1 -> b -- test :browse! <target> relative to different contexts :browse! Ghci025C -- from *Ghci025C> diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index 20190471ae..a6c744a177 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -3,24 +3,17 @@ TYPE SIGNATURES test2 :: forall c t t1. (Coll c, Num t1, Num t, Elem c ~ (t, t1)) => c -> c TYPE CONSTRUCTORS - Coll :: * -> Constraint - class Coll c - Roles: [nominal] - RecFlag NonRecursive - type family Elem c :: * (open) - empty :: c insert :: Elem c -> c -> c - ListColl :: * -> * - data ListColl a - No C type associated - Roles: [representational] - RecFlag NonRecursive, Promotable - = L :: [a] -> ListColl a Stricts: _ - FamilyInstance: none + class Coll c where + type family Elem c :: * open + empty :: c + insert :: Elem c -> c -> c + data ListColl a = L [a] + Promotable COERCION AXIOMS axiom Foo.TFCo:R:ElemListColl :: Elem (ListColl a) = a INSTANCES instance Coll (ListColl a) -- Defined at T3017.hs:12:11 FAMILY INSTANCES - type Elem (ListColl a) -- Defined at T3017.hs:13:4 + type Elem (ListColl a) Dependent modules: [] Dependent packages: [base, ghc-prim, integer-gmp] diff --git a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr index 107f5ffec3..04435ba962 100644 --- a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr +++ b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr @@ -5,7 +5,8 @@ ClosedFam3.hs-boot:5:1: Main module: type family Foo a :: * where Foo Int = Bool Foo Double = Char - Boot file: type family Foo a :: * where Foo Int = Bool + Boot file: type family Foo a :: * where + Foo Int = Bool ClosedFam3.hs-boot:8:1: Type constructor ‘Bar’ has conflicting definitions in the module @@ -20,5 +21,7 @@ ClosedFam3.hs-boot:8:1: ClosedFam3.hs-boot:12:1: Type constructor ‘Baz’ has conflicting definitions in the module and its hs-boot file - Main module: type family Baz a :: * where Baz Int = Bool - Boot file: type family Baz (a :: k) :: * where Baz Int = Bool + Main module: type family Baz a :: * where + Baz Int = Bool + Boot file: type family Baz (a :: k) :: * where + Baz * Int = Bool diff --git a/testsuite/tests/rename/should_fail/rnfail055.stderr b/testsuite/tests/rename/should_fail/rnfail055.stderr index 99ed2d6f12..c7b51a1d1f 100644 --- a/testsuite/tests/rename/should_fail/rnfail055.stderr +++ b/testsuite/tests/rename/should_fail/rnfail055.stderr @@ -20,8 +20,8 @@ RnFail055.hs-boot:6:1: RnFail055.hs-boot:8:1: Type constructor ‘S2’ has conflicting definitions in the module and its hs-boot file - Main module: type S2 a b = forall a. (a, b) - Boot file: type S2 a b = forall b. (a, b) + Main module: type S2 a b = forall a1. (a1, b) + Boot file: type S2 a b = forall b1. (a, b1) RnFail055.hs-boot:12:1: Type constructor ‘T1’ has conflicting definitions in the module @@ -33,9 +33,11 @@ RnFail055.hs-boot:14:1: Type constructor ‘T2’ has conflicting definitions in the module and its hs-boot file Main module: type role T2 representational nominal - data Eq b => T2 a b = T2 a + data Eq b => T2 a b + = T2 a Boot file: type role T2 nominal representational - data Eq a => T2 a b = T2 a + data Eq a => T2 a b + = T2 a RnFail055.hs-boot:16:11: T3 is exported by the hs-boot file, but not exported by the module @@ -60,7 +62,7 @@ RnFail055.hs-boot:25:1: and its hs-boot file Main module: type role T7 phantom data T7 a where - T7 :: a -> T7 a + T7 :: a1 -> T7 a Boot file: data T7 a = T7 a RnFail055.hs-boot:27:22: diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr index de4ecf36e2..96d5603bbf 100644 --- a/testsuite/tests/roles/should_compile/Roles1.stderr +++ b/testsuite/tests/roles/should_compile/Roles1.stderr @@ -1,54 +1,20 @@ TYPE SIGNATURES TYPE CONSTRUCTORS - T1 :: * -> * - data T1 a - No C type associated - Roles: [nominal] - RecFlag NonRecursive, Promotable - = K1 :: forall a. a -> T1 a Stricts: _ - FamilyInstance: none - T2 :: * -> * - data T2 a - No C type associated - Roles: [representational] - RecFlag NonRecursive, Promotable - = K2 :: forall a. a -> T2 a Stricts: _ - FamilyInstance: none - T3 :: forall (k :: BOX). k -> * - data T3 (k::BOX) (a::k) - No C type associated - Roles: [nominal, phantom] - RecFlag NonRecursive, Not promotable - = K3 :: forall (k::BOX) (a::k). T3 k a - FamilyInstance: none - T4 :: (* -> *) -> * -> * - data T4 (a::* -> *) b - No C type associated - Roles: [nominal, nominal] - RecFlag NonRecursive, Not promotable - = K4 :: forall (a::* -> *) b. (a b) -> T4 a b Stricts: _ - FamilyInstance: none - T5 :: * -> * - data T5 a - No C type associated - Roles: [representational] - RecFlag NonRecursive, Promotable - = K5 :: forall a. a -> T5 a Stricts: _ - FamilyInstance: none - T6 :: forall (k :: BOX). k -> * - data T6 (k::BOX) (a::k) - No C type associated - Roles: [nominal, phantom] - RecFlag NonRecursive, Not promotable - = K6 :: forall (k::BOX) (a::k). T6 k a - FamilyInstance: none - T7 :: forall (k :: BOX). k -> * -> * - data T7 (k::BOX) (a::k) b - No C type associated - Roles: [nominal, phantom, representational] - RecFlag NonRecursive, Not promotable - = K7 :: forall (k::BOX) (a::k) b. b -> T7 k a b Stricts: _ - FamilyInstance: none + type role T1 nominal + data T1 a = K1 a + Promotable + data T2 a = K2 a + Promotable + type role T3 phantom + data T3 (a :: k) = K3 + type role T4 nominal nominal + data T4 (a :: * -> *) b = K4 (a b) + data T5 a = K5 a + Promotable + type role T6 phantom + data T6 (a :: k) = K6 + type role T7 phantom representational + data T7 (a :: k) b = K7 b COERCION AXIOMS Dependent modules: [] Dependent packages: [base, ghc-prim, integer-gmp] diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr index 13231931e3..e0f26a14d3 100644 --- a/testsuite/tests/roles/should_compile/Roles14.stderr +++ b/testsuite/tests/roles/should_compile/Roles14.stderr @@ -1,9 +1,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS - C2 :: * -> Constraint - class C2 a - Roles: [representational] - RecFlag NonRecursive + type role C2 representational + class C2 a where meth2 :: a -> a COERCION AXIOMS axiom Roles12.NTCo:C2 :: C2 a = a -> a diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr index f5bcbe6829..e6f9bcd8d0 100644 --- a/testsuite/tests/roles/should_compile/Roles2.stderr +++ b/testsuite/tests/roles/should_compile/Roles2.stderr @@ -1,19 +1,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS - T1 :: * -> * - data T1 a - No C type associated - Roles: [representational] - RecFlag NonRecursive, Not promotable - = K1 :: forall a. (IO a) -> T1 a Stricts: _ - FamilyInstance: none - T2 :: * -> * - data T2 a - No C type associated - Roles: [representational] - RecFlag NonRecursive, Not promotable - = K2 :: forall a. (FunPtr a) -> T2 a Stricts: _ - FamilyInstance: none + data T1 a = K1 (IO a) + data T2 a = K2 (FunPtr a) COERCION AXIOMS Dependent modules: [] Dependent packages: [base, ghc-prim, integer-gmp] diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index 62eb2a9474..270afca9cd 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -1,31 +1,16 @@ TYPE SIGNATURES TYPE CONSTRUCTORS - C1 :: * -> Constraint - class C1 a - Roles: [nominal] - RecFlag NonRecursive + class C1 a where meth1 :: a -> a - C2 :: * -> * -> Constraint - class C2 a b - Roles: [nominal, nominal] - RecFlag NonRecursive - meth2 :: (~) * a b -> a -> b - C3 :: * -> * -> Constraint - class C3 a b - Roles: [nominal, nominal] - RecFlag NonRecursive - type family F3 b :: * (open) + class C2 a b where + meth2 :: a ~ b => a -> b + class C3 a b where + type family F3 b :: * open meth3 :: a -> F3 b -> F3 b - C4 :: * -> * -> Constraint - class C4 a b - Roles: [nominal, nominal] - RecFlag NonRecursive + class C4 a b where meth4 :: a -> F4 b -> F4 b - F4 :: * -> * - type family F4 a :: * (open) - Syn1 :: * -> * + type family F4 a :: * open type Syn1 a = F4 a - Syn2 :: * -> * type Syn2 a = [a] COERCION AXIOMS axiom Roles3.NTCo:C1 :: C1 a = a -> a diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr index 32862ea073..f2b590fadd 100644 --- a/testsuite/tests/roles/should_compile/Roles4.stderr +++ b/testsuite/tests/roles/should_compile/Roles4.stderr @@ -1,16 +1,9 @@ TYPE SIGNATURES TYPE CONSTRUCTORS - C1 :: * -> Constraint - class C1 a - Roles: [nominal] - RecFlag NonRecursive + class C1 a where meth1 :: a -> a - C3 :: * -> Constraint - class C3 a - Roles: [nominal] - RecFlag NonRecursive + class C3 a where meth3 :: a -> Syn1 a - Syn1 :: * -> * type Syn1 a = [a] COERCION AXIOMS axiom Roles4.NTCo:C1 :: C1 a = a -> a diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index 919530bb03..d400b9190c 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -1,49 +1,40 @@ -
-T8958.hs:1:31: Warning:
- -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
-TYPE SIGNATURES
-TYPE CONSTRUCTORS
- Map :: * -> * -> *
- newtype (Nominal k, Representational v) => Map k v
- No C type associated
- Roles: [nominal, representational]
- RecFlag NonRecursive, Promotable
- = MkMap :: [(k, v)] -> Map k v Stricts: _
- FamilyInstance: none
- Nominal :: * -> Constraint
- class Nominal a
- Roles: [nominal]
- RecFlag NonRecursive
- Representational :: * -> Constraint
- class Representational a
- Roles: [representational]
- RecFlag NonRecursive
-COERCION AXIOMS
- axiom T8958.NTCo:Map :: Map k v = [(k, v)]
-INSTANCES
- instance [incoherent] Representational a
- -- Defined at T8958.hs:10:10
- instance [incoherent] Nominal a -- Defined at T8958.hs:7:10
-Dependent modules: []
-Dependent packages: [base, ghc-prim, integer-gmp]
-
-==================== Typechecker ====================
-AbsBinds [a] []
- {Exports: [T8958.$fRepresentationala <= $dRepresentational
- <>]
- Exported types: T8958.$fRepresentationala [InlPrag=[ALWAYS] CONLIKE]
- :: forall a. Representational a
- [LclIdX[DFunId],
- Str=DmdType,
- Unf=DFun: \ (@ a) -> T8958.D:Representational TYPE a]
- Binds: $dRepresentational = T8958.D:Representational}
-AbsBinds [a] []
- {Exports: [T8958.$fNominala <= $dNominal
- <>]
- Exported types: T8958.$fNominala [InlPrag=[ALWAYS] CONLIKE]
- :: forall a. Nominal a
- [LclIdX[DFunId],
- Str=DmdType,
- Unf=DFun: \ (@ a) -> T8958.D:Nominal TYPE a]
- Binds: $dNominal = T8958.D:Nominal}
-
+ +T8958.hs:1:31: Warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. +TYPE SIGNATURES +TYPE CONSTRUCTORS + type role Map nominal representational + newtype (Nominal k, Representational v) => Map k v = MkMap [(k, v)] + Promotable + class Nominal a + type role Representational representational + class Representational a +COERCION AXIOMS + axiom T8958.NTCo:Map :: Map k v = [(k, v)] +INSTANCES + instance [incoherent] Representational a + -- Defined at T8958.hs:10:10 + instance [incoherent] Nominal a -- Defined at T8958.hs:7:10 +Dependent modules: [] +Dependent packages: [base, ghc-prim, integer-gmp] + +==================== Typechecker ==================== +AbsBinds [a] [] + {Exports: [T8958.$fRepresentationala <= $dRepresentational + <>] + Exported types: T8958.$fRepresentationala [InlPrag=[ALWAYS] CONLIKE] + :: forall a. Representational a + [LclIdX[DFunId], + Str=DmdType, + Unf=DFun: \ (@ a) -> T8958.D:Representational TYPE a] + Binds: $dRepresentational = T8958.D:Representational} +AbsBinds [a] [] + {Exports: [T8958.$fNominala <= $dNominal + <>] + Exported types: T8958.$fNominala [InlPrag=[ALWAYS] CONLIKE] + :: forall a. Nominal a + [LclIdX[DFunId], + Str=DmdType, + Unf=DFun: \ (@ a) -> T8958.D:Nominal TYPE a] + Binds: $dNominal = T8958.D:Nominal} + diff --git a/testsuite/tests/roles/should_fail/Roles12.stderr b/testsuite/tests/roles/should_fail/Roles12.stderr index bb830beae3..9b0f2cfdb5 100644 --- a/testsuite/tests/roles/should_fail/Roles12.stderr +++ b/testsuite/tests/roles/should_fail/Roles12.stderr @@ -4,4 +4,4 @@ Roles12.hs:5:1: and its hs-boot file Main module: type role T phantom data T a - Boot file: data T a + Boot file: abstract T a diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index ed519ed02f..6ff4692854 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/testsuite/tests/simplCore/should_compile/T4201.stdout @@ -1,3 +1,3 @@ - {- Arity: 1, HasNoCafRefs, Strictness: <S,1*U()>m, - Unfolding: InlineRule (0, True, True) - Eta.bof `cast` (Sym (Eta.NTCo:Foo[0]) ->_R <Eta.T>_R) -} + {- Arity: 1, HasNoCafRefs, Strictness: <S,1*U()>m, + Unfolding: InlineRule (0, True, True) + Eta.bof `cast` (Sym (Eta.NTCo:Foo[0]) ->_R <Eta.T>_R) -} diff --git a/testsuite/tests/simplCore/should_compile/T4918.stdout b/testsuite/tests/simplCore/should_compile/T4918.stdout index c79b116f03..708be353c4 100644 --- a/testsuite/tests/simplCore/should_compile/T4918.stdout +++ b/testsuite/tests/simplCore/should_compile/T4918.stdout @@ -1,2 +1,2 @@ - {- HasNoCafRefs, Strictness: m, Unfolding: (GHC.Types.C# 'p') -} - {- HasNoCafRefs, Strictness: m, Unfolding: (GHC.Types.C# 'q') -} + {- HasNoCafRefs, Strictness: m, Unfolding: (GHC.Types.C# 'p') -} + {- HasNoCafRefs, Strictness: m, Unfolding: (GHC.Types.C# 'q') -} diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr index 334d09dfd2..ab61060000 100644 --- a/testsuite/tests/th/TH_Roles2.stderr +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -1,12 +1,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS - T :: forall (k :: BOX). k -> * - data T (k::BOX) (a::k) - No C type associated - Roles: [nominal, representational] - RecFlag NonRecursive, Not promotable - = - FamilyInstance: none + type role T representational + data T (a :: k) COERCION AXIOMS Dependent modules: [] Dependent packages: [base, ghc-prim, integer-gmp, pretty-1.1.1.1, diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr index 16ddddac09..4421e8aba3 100644 --- a/testsuite/tests/typecheck/should_compile/tc231.stderr +++ b/testsuite/tests/typecheck/should_compile/tc231.stderr @@ -5,24 +5,11 @@ TYPE SIGNATURES Q s (Z [Char]) chain -> ST s () s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1 TYPE CONSTRUCTORS - Q :: * -> * -> * -> * - data Q s a chain - No C type associated - Roles: [representational, representational, representational] - RecFlag NonRecursive, Promotable - = Node :: s -> a -> chain -> Q s a chain Stricts: _ _ _ - FamilyInstance: none - Z :: * -> * - data Z a - No C type associated - Roles: [representational] - RecFlag NonRecursive, Promotable - = Z :: a -> Z a Stricts: _ - FamilyInstance: none - Zork :: * -> * -> * -> Constraint - class Zork s a b | a -> b - Roles: [nominal, nominal, nominal] - RecFlag NonRecursive + data Q s a chain = Node s a chain + Promotable + data Z a = Z a + Promotable + class Zork s a b | a -> b where huh :: Q s a chain -> ST s () COERCION AXIOMS axiom ShouldCompile.NTCo:Zork :: diff --git a/testsuite/tests/typecheck/should_fail/T3468.stderr b/testsuite/tests/typecheck/should_fail/T3468.stderr index 17bc7fba01..26ec1920a6 100644 --- a/testsuite/tests/typecheck/should_fail/T3468.stderr +++ b/testsuite/tests/typecheck/should_fail/T3468.stderr @@ -5,4 +5,4 @@ T3468.hs-boot:3:1: Main module: type role Tool phantom data Tool d where F :: a -> Tool d - Boot file: data Tool + Boot file: abstract Tool |