Commit ec8a188a authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactoring on IdInfo and system derived names

Some modest refactoring, triggered in part by Trac #11051

* Kill off PatSynId, ReflectionId in IdDetails
  They were barely used, and only for pretty-printing

* Add helper function Id.mkExportedVanillaId, and use it

* Polish up OccName.isDerivedOccName, as a predicate for
  definitions generated internally by GHC, which we
  might not want to show to the user.

* Kill off unused OccName.mkDerivedTyConOcc

* Shorten the derived OccNames for newtype and data
  instance axioms

* A bit of related refactoring around newFamInstAxiomName
parent 6e0c0fd2
...@@ -32,7 +32,7 @@ module Id ( ...@@ -32,7 +32,7 @@ module Id (
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,
mkLocalIdOrCoVarWithInfo, mkLocalIdOrCoVarWithInfo,
mkLocalIdWithInfo, mkExportedLocalId, mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,
mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,
mkUserLocal, mkUserLocalCoVar, mkUserLocalOrCoVar, mkUserLocal, mkUserLocalCoVar, mkUserLocalOrCoVar,
mkDerivedLocalCoVarM, mkDerivedLocalCoVarM,
...@@ -288,6 +288,10 @@ mkExportedLocalId :: IdDetails -> Name -> Type -> Id ...@@ -288,6 +288,10 @@ mkExportedLocalId :: IdDetails -> Name -> Type -> Id
mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo
-- Note [Free type variables] -- Note [Free type variables]
mkExportedVanillaId :: Name -> Type -> Id
mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
-- Note [Free type variables]
-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") -- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal")
-- that are created by the compiler out of thin air -- that are created by the compiler out of thin air
......
...@@ -137,17 +137,6 @@ data IdDetails ...@@ -137,17 +137,6 @@ data IdDetails
| CoVarId -- ^ A coercion variable | CoVarId -- ^ A coercion variable
-- The rest are distinguished only for debugging reasons
-- e.g. to suppress them in -ddump-types
-- Currently we don't persist these through interface file
-- (see MkIface.toIfaceIdDetails), but we easily could if it mattered
| ReflectionId -- ^ A top-level Id to support runtime reflection
-- e.g. $trModule, or $tcT
| PatSynId -- ^ A top-level Id to support pattern synonyms;
-- the builder or matcher for the pattern synonym
data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq
-- Either `TyCon` or `PatSyn` depending -- Either `TyCon` or `PatSyn` depending
-- on the origin of the record selector. -- on the origin of the record selector.
...@@ -177,8 +166,6 @@ pprIdDetails VanillaId = empty ...@@ -177,8 +166,6 @@ pprIdDetails VanillaId = empty
pprIdDetails other = brackets (pp other) pprIdDetails other = brackets (pp other)
where where
pp VanillaId = panic "pprIdDetails" pp VanillaId = panic "pprIdDetails"
pp ReflectionId = ptext (sLit "ReflectionId")
pp PatSynId = ptext (sLit "PatSynId")
pp (DataConWorkId _) = ptext (sLit "DataCon") pp (DataConWorkId _) = ptext (sLit "DataCon")
pp (DataConWrapId _) = ptext (sLit "DataConWrapper") pp (DataConWrapId _) = ptext (sLit "DataConWrapper")
pp (ClassOpId {}) = ptext (sLit "ClassOp") pp (ClassOpId {}) = ptext (sLit "ClassOp")
......
...@@ -56,7 +56,7 @@ module OccName ( ...@@ -56,7 +56,7 @@ module OccName (
mkDataConWrapperOcc, mkWorkerOcc, mkDataConWrapperOcc, mkWorkerOcc,
mkMatcherOcc, mkBuilderOcc, mkMatcherOcc, mkBuilderOcc,
mkDefaultMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassDataConOcc, mkDictOcc, mkIPOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,
...@@ -551,10 +551,9 @@ a user-written type or function name ...@@ -551,10 +551,9 @@ a user-written type or function name
$pnC n'th superclass selector for class C $pnC n'th superclass selector for class C
$wf Worker for function 'f' $wf Worker for function 'f'
$sf.. Specialised version of f $sf.. Specialised version of f
T:C Tycon for dictionary for class C
D:C Data constructor for dictionary for class C D:C Data constructor for dictionary for class C
NTCo:T Coercion connecting newtype T with its representation type NTCo:T Coercion connecting newtype T with its representation type
TFCo:R Coercion connecting a data family to its respresentation type R TFCo:R Coercion connecting a data family to its representation type R
In encoded form these appear as Zdfxxx etc In encoded form these appear as Zdfxxx etc
...@@ -575,16 +574,18 @@ mk_deriv :: NameSpace ...@@ -575,16 +574,18 @@ mk_deriv :: NameSpace
mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str)
isDerivedOccName :: OccName -> Bool isDerivedOccName :: OccName -> Bool
-- ^ Test for definitions internally generated by GHC. This predicte
-- is used to suppress printing of internal definitions in some debug prints
isDerivedOccName occ = isDerivedOccName occ =
case occNameString occ of case occNameString occ of
'$':c:_ | isAlphaNum c -> True '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo
':':c:_ | isAlphaNum c -> True c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions
_other -> False _other -> False
mkDataConWrapperOcc, mkWorkerOcc, mkDataConWrapperOcc, mkWorkerOcc,
mkMatcherOcc, mkBuilderOcc, mkMatcherOcc, mkBuilderOcc,
mkDefaultMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,
mkGenR, mkGen1R, mkGenRCo, mkGenR, mkGen1R, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
...@@ -600,16 +601,14 @@ mkMatcherOcc = mk_simple_deriv varName "$m" ...@@ -600,16 +601,14 @@ mkMatcherOcc = mk_simple_deriv varName "$m"
mkBuilderOcc = mk_simple_deriv varName "$b" mkBuilderOcc = mk_simple_deriv varName "$b"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm" mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies as a tycon/datacon
mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con
-- for datacons from classes
mkDictOcc = mk_simple_deriv varName "$d" mkDictOcc = mk_simple_deriv varName "$d"
mkIPOcc = mk_simple_deriv varName "$i" mkIPOcc = mk_simple_deriv varName "$i"
mkSpecOcc = mk_simple_deriv varName "$s" mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f" mkForeignExportOcc = mk_simple_deriv varName "$f"
mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible
mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class
mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes
mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions
mkEqPredCoOcc = mk_simple_deriv tcName "$co" mkEqPredCoOcc = mk_simple_deriv tcName "$co"
-- Used in derived instances -- Used in derived instances
......
...@@ -59,7 +59,6 @@ import FastString ...@@ -59,7 +59,6 @@ import FastString
import PatSyn import PatSyn
import IfaceEnv import IfaceEnv
import IdInfo
import Data.IORef ( atomicModifyIORef', modifyIORef ) import Data.IORef ( atomicModifyIORef', modifyIORef )
import Control.Monad import Control.Monad
...@@ -461,7 +460,7 @@ dsExpr (HsStatic expr@(L loc _)) = do ...@@ -461,7 +460,7 @@ dsExpr (HsStatic expr@(L loc _)) = do
let tvars = tyCoVarsOfTypeWellScoped ty let tvars = tyCoVarsOfTypeWellScoped ty
speTy = ASSERT( all isTyVar tvars ) -- ty is top-level, so this is OK speTy = ASSERT( all isTyVar tvars ) -- ty is top-level, so this is OK
mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty] mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
speId = mkExportedLocalId VanillaId n' speTy speId = mkExportedVanillaId n' speTy
fp@(Fingerprint w0 w1) = fingerprintName $ idName speId fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
fp_core = mkConApp fingerprintDataCon fp_core = mkConApp fingerprintDataCon
[ mkWord64LitWordRep dflags w0 [ mkWord64LitWordRep dflags w0
......
...@@ -1649,11 +1649,6 @@ toIfaceIdDetails (RecSelId { sel_naughty = n ...@@ -1649,11 +1649,6 @@ toIfaceIdDetails (RecSelId { sel_naughty = n
RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)
in IfRecSelId iface n in IfRecSelId iface n
-- Currently we don't persist these three "advisory" IdInfos
-- through interface files. We easily could if it mattered
toIfaceIdDetails PatSynId = IfVanillaId
toIfaceIdDetails ReflectionId = IfVanillaId
-- The remaining cases are all "implicit Ids" which don't -- The remaining cases are all "implicit Ids" which don't
-- appear in interface files at all -- appear in interface files at all
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
......
...@@ -74,7 +74,6 @@ import LoadIface ...@@ -74,7 +74,6 @@ import LoadIface
import PrelNames import PrelNames
import TysWiredIn import TysWiredIn
import Id import Id
import IdInfo( IdDetails(VanillaId) )
import Var import Var
import VarSet import VarSet
import RdrName import RdrName
...@@ -871,9 +870,9 @@ newGlobalBinder. ...@@ -871,9 +870,9 @@ newGlobalBinder.
newFamInstTyConName :: Located Name -> [Type] -> TcM Name newFamInstTyConName :: Located Name -> [Type] -> TcM Name
newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
newFamInstAxiomName :: SrcSpan -> Name -> [CoAxBranch] -> TcM Name newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
newFamInstAxiomName loc name branches newFamInstAxiomName (L loc name) branches
= mk_fam_inst_name mkInstTyCoOcc loc name (map coAxBranchLHS branches) = mk_fam_inst_name mkInstTyCoOcc loc name branches
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name adaptOcc loc tc_name tyss mk_fam_inst_name adaptOcc loc tc_name tyss
...@@ -901,7 +900,7 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do ...@@ -901,7 +900,7 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do
name <- mkWrapperName "stable" str name <- mkWrapperName "stable" str
let occ = mkVarOccFS name :: OccName let occ = mkVarOccFS name :: OccName
gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
id = mkExportedLocalId VanillaId gnm sig_ty :: Id id = mkExportedVanillaId gnm sig_ty :: Id
return id return id
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
......
...@@ -623,8 +623,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ...@@ -623,8 +623,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
-- (3) construct coercion axiom -- (3) construct coercion axiom
; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname) ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
[co_ax_branch]
; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
; newFamInst SynFamilyInst axiom } ; newFamInst SynFamilyInst axiom }
...@@ -667,7 +666,7 @@ tcDataFamInstDecl mb_clsinfo ...@@ -667,7 +666,7 @@ tcDataFamInstDecl mb_clsinfo
-- Construct representation tycon -- Construct representation tycon
; rep_tc_name <- newFamInstTyConName fam_tc_name pats' ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc ; axiom_name <- newFamInstAxiomName fam_tc_name [pats']
; let (eta_pats, etad_tvs) = eta_reduce pats' ; let (eta_pats, etad_tvs) = eta_reduce pats'
eta_tvs = filterOut (`elem` etad_tvs) tvs' eta_tvs = filterOut (`elem` etad_tvs) tvs'
full_tvs = eta_tvs ++ etad_tvs full_tvs = eta_tvs ++ etad_tvs
......
...@@ -828,7 +828,7 @@ checkHiBootIface' ...@@ -828,7 +828,7 @@ checkHiBootIface'
; return Nothing } ; return Nothing }
(dfun:_) -> return (Just (local_boot_dfun, dfun)) (dfun:_) -> return (Just (local_boot_dfun, dfun))
where where
local_boot_dfun = Id.mkExportedLocalId VanillaId boot_dfun_name (idType dfun) local_boot_dfun = Id.mkExportedVanillaId boot_dfun_name (idType dfun)
-- Name from the /boot-file/ ClsInst, but type from the dfun -- Name from the /boot-file/ ClsInst, but type from the dfun
-- defined in /this module/. That ensures that the TyCon etc -- defined in /this module/. That ensures that the TyCon etc
-- inside the type are the ones defined in this module, not -- inside the type are the ones defined in this module, not
...@@ -1484,8 +1484,8 @@ check_main dflags tcg_env explicit_mod_hdr ...@@ -1484,8 +1484,8 @@ check_main dflags tcg_env explicit_mod_hdr
; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
(mkVarOccFS (fsLit "main")) (mkVarOccFS (fsLit "main"))
(getSrcSpan main_name) (getSrcSpan main_name)
; root_main_id = Id.mkExportedLocalId VanillaId root_main_name ; root_main_id = Id.mkExportedVanillaId root_main_name
(mkTyConApp ioTyCon [res_ty]) (mkTyConApp ioTyCon [res_ty])
; co = mkWpTyApps [res_ty] ; co = mkWpTyApps [res_ty]
; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
; main_bind = mkVarBind root_main_id rhs } ; main_bind = mkVarBind root_main_id rhs }
...@@ -2414,10 +2414,9 @@ ppr_types type_env ...@@ -2414,10 +2414,9 @@ ppr_types type_env
= True = True
| otherwise | otherwise
= isExternalName (idName id) && = isExternalName (idName id) &&
(case idDetails id of { VanillaId -> True; _ -> False }) (not (isDerivedOccName (getOccName id)))
-- Looking for VanillaId ignores data constructors, records selectors etc. -- Top-level user-defined things have External names.
-- The isExternalName ignores local evidence bindings that the type checker -- Suppress internally-generated things unless -dppr-debug
-- has invented. Top-level user-defined things have External names.
ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
ppr_tycons fam_insts type_env ppr_tycons fam_insts type_env
......
...@@ -712,9 +712,23 @@ tcTyClDecl1 _parent rec_info ...@@ -712,9 +712,23 @@ tcTyClDecl1 _parent rec_info
; return (tvs1', tvs2') } ; return (tvs1', tvs2') }
tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM TyCon tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM TyCon
tcFamDecl1 parent (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name)
, fdTyVars = tvs, fdResultSig = L _ sig , fdTyVars = tvs, fdResultSig = L _ sig
, fdInjectivityAnn = inj }) , fdInjectivityAnn = inj })
| DataFamily <- fam_info
= tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
; extra_tvs <- tcDataKindSig res_kind
; tc_rep_name <- newTyConRepName tc_name
; let final_tvs = (kvs' ++ tvs') `chkAppend` extra_tvs -- we may not need these
tycon = mkFamilyTyCon tc_name tycon_kind final_tvs
(resultVariableName sig)
(DataFamilyTyCon tc_rep_name)
parent NotInjective
; return tycon }
| OpenTypeFamily <- fam_info
= tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind _res_kind -> do = tcTyClTyVars tc_name tvs $ \ kvs' tvs' full_kind _res_kind -> do
{ traceTc "open type family:" (ppr tc_name) { traceTc "open type family:" (ppr tc_name)
; checkFamFlag tc_name ; checkFamFlag tc_name
...@@ -725,13 +739,10 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name ...@@ -725,13 +739,10 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name
parent inj' parent inj'
; return tycon } ; return tycon }
tcFamDecl1 parent | ClosedTypeFamily mb_eqns <- fam_info
(FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns = -- Closed type families are a little tricky, because they contain the definition
, fdLName = L _ tc_name, fdTyVars = tvs -- of both the type family and the equations for a CoAxiom.
, fdResultSig = L _ sig, fdInjectivityAnn = inj }) do { traceTc "Closed type family:" (ppr tc_name)
-- Closed type families are a little tricky, because they contain the definition
-- of both the type family and the equations for a CoAxiom.
= do { traceTc "Closed type family:" (ppr tc_name)
-- the variables in the header scope only over the injectivity -- the variables in the header scope only over the injectivity
-- declaration but this is not involved here -- declaration but this is not involved here
; (tvs', inj', kind) <- tcTyClTyVars tc_name tvs ; (tvs', inj', kind) <- tcTyClTyVars tc_name tvs
...@@ -769,8 +780,7 @@ tcFamDecl1 parent ...@@ -769,8 +780,7 @@ tcFamDecl1 parent
-- because there will only be one axiom, so we don't need to -- because there will only be one axiom, so we don't need to
-- differentiate names. -- differentiate names.
-- See [Zonking inside the knot] in TcHsType -- See [Zonking inside the knot] in TcHsType
; loc <- getSrcSpanM ; co_ax_name <- newFamInstAxiomName tc_lname []
; co_ax_name <- newFamInstAxiomName loc tc_name []
; let mb_co_ax ; let mb_co_ax
| null eqns = Nothing -- mkBranchedCoAxiom fails on empty list | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list
...@@ -779,26 +789,13 @@ tcFamDecl1 parent ...@@ -779,26 +789,13 @@ tcFamDecl1 parent
fam_tc = mkFamilyTyCon tc_name kind tvs' (resultVariableName sig) fam_tc = mkFamilyTyCon tc_name kind tvs' (resultVariableName sig)
(ClosedSynFamilyTyCon mb_co_ax) parent inj' (ClosedSynFamilyTyCon mb_co_ax) parent inj'
-- We check for instance validity later, when doing validity
-- checking for the tycon. Exception: checking equations
-- overlap done by dropDominatedAxioms
; return fam_tc } } ; return fam_tc } }
-- We check for instance validity later, when doing validity checking for | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker
-- the tycon. Exception: checking equations overlap done by dropDominatedAxioms
tcFamDecl1 parent
(FamilyDecl { fdInfo = DataFamily, fdLName = L _ tc_name
, fdTyVars = tvs, fdResultSig = L _ sig })
= tcTyClTyVars tc_name tvs $ \ kvs' tvs' tycon_kind res_kind -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
; extra_tvs <- tcDataKindSig res_kind
; tc_rep_name <- newTyConRepName tc_name
; let final_tvs = (kvs' ++ tvs') `chkAppend` extra_tvs -- we may not need these
tycon = mkFamilyTyCon tc_name tycon_kind final_tvs
(resultVariableName sig)
(DataFamilyTyCon tc_rep_name)
parent NotInjective
; return tycon }
-- | Maybe return a list of Bools that say whether a type family was declared -- | Maybe return a list of Bools that say whether a type family was declared
-- injective in the corresponding type arguments. Length of the list is equal to -- injective in the corresponding type arguments. Length of the list is equal to
......
...@@ -877,7 +877,7 @@ mkDefaultMethodIds :: [TyCon] -> [Id] ...@@ -877,7 +877,7 @@ mkDefaultMethodIds :: [TyCon] -> [Id]
-- the filled-in default methods of each instance declaration -- the filled-in default methods of each instance declaration
-- See Note [Default method Ids and Template Haskell] -- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds tycons mkDefaultMethodIds tycons
= [ mkExportedLocalId VanillaId dm_name (mk_dm_ty cls sel_id dm_spec) = [ mkExportedVanillaId dm_name (mk_dm_ty cls sel_id dm_spec)
| tc <- tycons | tc <- tycons
, Just cls <- [tyConClass_maybe tc] , Just cls <- [tyConClass_maybe tc]
, (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ] , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]
......
...@@ -14,7 +14,6 @@ import TcEnv ...@@ -14,7 +14,6 @@ import TcEnv
import TcRnMonad import TcRnMonad
import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName ) import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
import Id import Id
import IdInfo( IdDetails(..) )
import Type import Type
import TyCon import TyCon
import DataCon import DataCon
...@@ -113,8 +112,8 @@ mkModIdBindings ...@@ -113,8 +112,8 @@ mkModIdBindings
; tr_mod_dc <- tcLookupDataCon trModuleDataConName ; tr_mod_dc <- tcLookupDataCon trModuleDataConName
; tr_name_dc <- tcLookupDataCon trNameSDataConName ; tr_name_dc <- tcLookupDataCon trNameSDataConName
; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
; let mod_id = mkExportedLocalId ReflectionId mod_nm ; let mod_ty = mkTyConApp (dataConTyCon tr_mod_dc) []
(mkTyConApp (dataConTyCon tr_mod_dc) []) mod_id = mkExportedVanillaId mod_nm mod_ty
mod_bind = mkVarBind mod_id mod_rhs mod_bind = mkVarBind mod_id mod_rhs
mod_rhs = nlHsApps (dataConWrapId tr_mod_dc) mod_rhs = nlHsApps (dataConWrapId tr_mod_dc)
[ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod)) [ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
...@@ -178,7 +177,7 @@ mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) ty ...@@ -178,7 +177,7 @@ mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) ty
= case tyConRepName_maybe tycon of = case tyConRepName_maybe tycon of
Just rep_name -> unitBag (mkVarBind rep_id rep_rhs) Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
where where
rep_id = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon []) rep_id = mkExportedVanillaId rep_name (mkTyConApp tr_tycon [])
_ -> emptyBag _ -> emptyBag
where where
tr_tycon = dataConTyCon tr_datacon tr_tycon = dataConTyCon tr_datacon
......
...@@ -26,7 +26,7 @@ a1 = GHC.Types.TrNameS "T2431"# ...@@ -26,7 +26,7 @@ a1 = GHC.Types.TrNameS "T2431"#
-- RHS size: {terms: 3, types: 0, coercions: 0} -- RHS size: {terms: 3, types: 0, coercions: 0}
T2431.$trModule :: GHC.Types.Module T2431.$trModule :: GHC.Types.Module
[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] [GblId, Caf=NoCafRefs, Str=DmdType]
T2431.$trModule = GHC.Types.Module a a1 T2431.$trModule = GHC.Types.Module a a1
-- RHS size: {terms: 2, types: 0, coercions: 0} -- RHS size: {terms: 2, types: 0, coercions: 0}
...@@ -36,7 +36,7 @@ a2 = GHC.Types.TrNameS "'Refl"# ...@@ -36,7 +36,7 @@ a2 = GHC.Types.TrNameS "'Refl"#
-- RHS size: {terms: 5, types: 0, coercions: 0} -- RHS size: {terms: 5, types: 0, coercions: 0}
T2431.$tc'Refl :: GHC.Types.TyCon T2431.$tc'Refl :: GHC.Types.TyCon
[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] [GblId, Caf=NoCafRefs, Str=DmdType]
T2431.$tc'Refl = T2431.$tc'Refl =
GHC.Types.TyCon GHC.Types.TyCon
15026191172322750497## 3898273167927206410## T2431.$trModule a2 15026191172322750497## 3898273167927206410## T2431.$trModule a2
...@@ -48,7 +48,7 @@ a3 = GHC.Types.TrNameS ":~:"# ...@@ -48,7 +48,7 @@ a3 = GHC.Types.TrNameS ":~:"#
-- RHS size: {terms: 5, types: 0, coercions: 0} -- RHS size: {terms: 5, types: 0, coercions: 0}
T2431.$tc:~: :: GHC.Types.TyCon T2431.$tc:~: :: GHC.Types.TyCon
[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] [GblId, Caf=NoCafRefs, Str=DmdType]
T2431.$tc:~: = T2431.$tc:~: =
GHC.Types.TyCon GHC.Types.TyCon
9759653149176674453## 12942818337407067047## T2431.$trModule a3 9759653149176674453## 12942818337407067047## T2431.$trModule a3
......
type family A a b type family A a b
Kind: * -> * -> * Kind: * -> * -> *
-- Defined at T4175.hs:7:1 -- Defined at T4175.hs:7:1
type instance A (B a) b = () -- Defined at T4175.hs:10:1 type instance A (B a) b = () -- Defined at T4175.hs:10:15
type instance A (Maybe a) a = a -- Defined at T4175.hs:9:1 type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15
type instance A Int Int = () -- Defined at T4175.hs:8:1 type instance A Int Int = () -- Defined at T4175.hs:8:15
data family B a -- Defined at T4175.hs:12:1 data family B a -- Defined at T4175.hs:12:1
instance G B -- Defined at T4175.hs:34:10 instance G B -- Defined at T4175.hs:34:10
data instance B () = MkB -- Defined at T4175.hs:13:15 data instance B () = MkB -- Defined at T4175.hs:13:15
type instance A (B a) b = () -- Defined at T4175.hs:10:1 type instance A (B a) b = () -- Defined at T4175.hs:10:15
class C a where class C a where
type family D a b type family D a b
Kind: * -> * -> * Kind: * -> * -> *
-- Defined at T4175.hs:16:5 -- Defined at T4175.hs:16:5
type instance D () () = Bool -- Defined at T4175.hs:22:5 type instance D () () = Bool -- Defined at T4175.hs:22:10
type instance D Int () = String -- Defined at T4175.hs:19:5 type instance D Int () = String -- Defined at T4175.hs:19:10
type family E a type family E a
Kind: * -> * Kind: * -> *
where where
...@@ -29,8 +29,8 @@ instance Ord () -- Defined in ‘GHC.Classes’ ...@@ -29,8 +29,8 @@ instance Ord () -- Defined in ‘GHC.Classes’
instance Read () -- Defined in ‘GHC.Read’ instance Read () -- Defined in ‘GHC.Read’
instance Show () -- Defined in ‘GHC.Show’ instance Show () -- Defined in ‘GHC.Show’
instance Monoid () -- Defined in ‘GHC.Base’ instance Monoid () -- Defined in ‘GHC.Base’
type instance D () () = Bool -- Defined at T4175.hs:22:5 type instance D () () = Bool -- Defined at T4175.hs:22:10
type instance D Int () = String -- Defined at T4175.hs:19:5 type instance D Int () = String -- Defined at T4175.hs:19:10
data instance B () = MkB -- Defined at T4175.hs:13:15 data instance B () = MkB -- Defined at T4175.hs:13:15
data Maybe a = Nothing | Just a -- Defined in ‘GHC.Base’ data Maybe a = Nothing | Just a -- Defined in ‘GHC.Base’
instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base’ instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base’
...@@ -43,7 +43,7 @@ instance Applicative Maybe -- Defined in ‘GHC.Base’ ...@@ -43,7 +43,7 @@ instance Applicative Maybe -- Defined in ‘GHC.Base’
instance Foldable Maybe -- Defined in ‘Data.Foldable’ instance Foldable Maybe -- Defined in ‘Data.Foldable’
instance Traversable Maybe -- Defined in ‘Data.Traversable’ instance Traversable Maybe -- Defined in ‘Data.Traversable’
instance Monoid a => Monoid (Maybe a) -- Defined in ‘GHC.Base’ instance Monoid a => Monoid (Maybe a) -- Defined in ‘GHC.Base’
type instance A (Maybe a) a = a -- Defined at T4175.hs:9:1 type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15
data Int = I# Int# -- Defined in ‘GHC.Types’ data Int = I# Int# -- Defined in ‘GHC.Types’
instance C Int -- Defined at T4175.hs:18:10 instance C Int -- Defined at T4175.hs:18:10
instance Bounded Int -- Defined in ‘GHC.Enum’ instance Bounded Int -- Defined in ‘GHC.Enum’
...@@ -55,7 +55,7 @@ instance Ord Int -- Defined in ‘GHC.Classes’ ...@@ -55,7 +55,7 @@ instance Ord Int -- Defined in ‘GHC.Classes’
instance Read Int -- Defined in ‘GHC.Read’ instance Read Int -- Defined in ‘GHC.Read’
instance Real Int -- Defined in ‘GHC.Real’ instance Real Int -- Defined in ‘GHC.Real’
instance Show Int -- Defined in ‘GHC.Show’ instance Show Int -- Defined in ‘GHC.Show’
type instance D Int () = String -- Defined at T4175.hs:19:5 type instance D Int () = String -- Defined at T4175.hs:19:10