summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2015-10-29 17:41:34 +0100
committerBen Gamari <ben@smart-cactus.org>2015-10-29 17:42:26 +0100
commitbbaf76f949426c91d6abbbc5eced1f705530087b (patch)
tree3c25529a062e94493d874349d55f71cfaa3e6dea
parentbef2f03e4d56d88a7e9752a7afd6a0a35616da6c (diff)
downloadhaskell-bbaf76f949426c91d6abbbc5eced1f705530087b.tar.gz
Revert "Generate Typeable info at definition sites"
This reverts commit bef2f03e4d56d88a7e9752a7afd6a0a35616da6c. This merge was botched Also reverts haddock submodule.
-rw-r--r--compiler/basicTypes/DataCon.hs222
-rw-r--r--compiler/basicTypes/OccName.hs19
-rw-r--r--compiler/basicTypes/Unique.hs51
-rw-r--r--compiler/coreSyn/MkCore.hs8
-rw-r--r--compiler/deSugar/DsBinds.hs281
-rw-r--r--compiler/deSugar/DsExpr.hs14
-rw-r--r--compiler/deSugar/DsUtils.hs14
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/hsSyn/HsUtils.hs6
-rw-r--r--compiler/iface/BuildTyCl.hs42
-rw-r--r--compiler/iface/IfaceSyn.hs101
-rw-r--r--compiler/iface/MkIface.hs10
-rw-r--r--compiler/iface/TcIface.hs89
-rw-r--r--compiler/main/HscMain.hs13
-rw-r--r--compiler/main/HscTypes.hs13
-rw-r--r--compiler/prelude/PrelInfo.hs111
-rw-r--r--compiler/prelude/PrelNames.hs88
-rw-r--r--compiler/prelude/THNames.hs105
-rw-r--r--compiler/prelude/TysPrim.hs38
-rw-r--r--compiler/prelude/TysWiredIn.hs55
-rw-r--r--compiler/simplCore/FloatIn.hs4
-rw-r--r--compiler/typecheck/TcBinds.hs35
-rw-r--r--compiler/typecheck/TcEnv.hs5
-rw-r--r--compiler/typecheck/TcEvidence.hs69
-rw-r--r--compiler/typecheck/TcGenGenerics.hs41
-rw-r--r--compiler/typecheck/TcHsSyn.hs27
-rw-r--r--compiler/typecheck/TcHsType.hs8
-rw-r--r--compiler/typecheck/TcInstDcls.hs19
-rw-r--r--compiler/typecheck/TcInteract.hs440
-rw-r--r--compiler/typecheck/TcPatSyn.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs40
-rw-r--r--compiler/typecheck/TcRnMonad.hs2
-rw-r--r--compiler/typecheck/TcRnTypes.hs7
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs18
-rw-r--r--compiler/typecheck/TcTyDecls.hs166
-rw-r--r--compiler/typecheck/TcTypeNats.hs12
-rw-r--r--compiler/typecheck/TcTypeable.hs206
-rw-r--r--compiler/types/TyCon.hs412
-rw-r--r--compiler/types/Type.hs9
-rw-r--r--compiler/utils/Binary.hs11
-rw-r--r--compiler/vectorise/Vectorise/Generic/PData.hs4
-rw-r--r--compiler/vectorise/Vectorise/Type/Env.hs4
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs7
-rw-r--r--ghc/InteractiveUI.hs4
-rw-r--r--libraries/base/Data/Typeable.hs5
-rw-r--r--libraries/base/Data/Typeable/Internal.hs330
-rw-r--r--libraries/base/GHC/Show.hs10
-rw-r--r--libraries/base/GHC/Stack/Types.hs13
-rw-r--r--libraries/ghc-prim/GHC/Classes.hs36
-rw-r--r--libraries/ghc-prim/GHC/Magic.hs2
-rw-r--r--libraries/ghc-prim/GHC/Tuple.hs3
-rw-r--r--libraries/ghc-prim/GHC/Types.hs60
-rw-r--r--testsuite/tests/codeGen/should_run/cgrun057.stderr2
-rw-r--r--testsuite/tests/deSugar/should_compile/T2431.stderr29
-rw-r--r--testsuite/tests/deriving/should_fail/T9687.stderr4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/T2740.stdout2
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break006.stderr4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break009.stdout4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break010.stdout4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break011.stdout8
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break012.stdout16
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break018.stdout4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break022/break022.stdout2
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break028.stdout6
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print018.stdout6
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print019.stderr4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print031.stdout2
-rw-r--r--testsuite/tests/ghci/scripts/T4175.stdout4
-rw-r--r--testsuite/tests/ghci/scripts/T5417.stdout16
-rw-r--r--testsuite/tests/ghci/scripts/T8674.stdout4
-rw-r--r--testsuite/tests/indexed-types/should_compile/T3017.stderr42
-rw-r--r--testsuite/tests/numeric/should_compile/T7116.stdout29
-rw-r--r--testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr4
-rw-r--r--testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr2
-rw-r--r--testsuite/tests/perf/compiler/all.T52
-rw-r--r--testsuite/tests/perf/should_run/all.T3
-rw-r--r--testsuite/tests/polykinds/T8132.stderr4
-rw-r--r--testsuite/tests/quasiquotation/T7918.stdout3
-rw-r--r--testsuite/tests/roles/should_compile/Roles1.stderr61
-rw-r--r--testsuite/tests/roles/should_compile/Roles13.stderr53
-rw-r--r--testsuite/tests/roles/should_compile/Roles14.stderr7
-rw-r--r--testsuite/tests/roles/should_compile/Roles2.stderr13
-rw-r--r--testsuite/tests/roles/should_compile/Roles3.stderr25
-rw-r--r--testsuite/tests/roles/should_compile/Roles4.stderr13
-rw-r--r--testsuite/tests/roles/should_compile/T8958.stderr9
-rw-r--r--testsuite/tests/simplCore/should_compile/T3234.stderr4
-rw-r--r--testsuite/tests/simplCore/should_compile/T3717.stderr29
-rw-r--r--testsuite/tests/simplCore/should_compile/T3772.stdout29
-rw-r--r--testsuite/tests/simplCore/should_compile/T4908.stderr29
-rw-r--r--testsuite/tests/simplCore/should_compile/T4930.stderr29
-rw-r--r--testsuite/tests/simplCore/should_compile/T7360.stderr47
-rw-r--r--testsuite/tests/simplCore/should_compile/T8274.stdout8
-rw-r--r--testsuite/tests/simplCore/should_compile/T9400.stderr17
-rw-r--r--testsuite/tests/simplCore/should_compile/rule2.stderr3
-rw-r--r--testsuite/tests/simplCore/should_compile/spec-inline.stderr29
-rw-r--r--testsuite/tests/stranal/should_compile/T10694.stdout3
-rw-r--r--testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr1
-rw-r--r--testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr2
-rw-r--r--testsuite/tests/stranal/sigs/HyperStrUse.stderr1
-rw-r--r--testsuite/tests/stranal/sigs/StrAnalExample.stderr1
-rw-r--r--testsuite/tests/stranal/sigs/T8569.stderr2
-rw-r--r--testsuite/tests/stranal/sigs/T8598.stderr1
-rw-r--r--testsuite/tests/stranal/sigs/UnsatFun.stderr1
-rw-r--r--testsuite/tests/th/TH_Roles2.stderr8
-rw-r--r--testsuite/tests/typecheck/should_compile/holes2.stderr6
-rw-r--r--testsuite/tests/typecheck/should_fail/T5095.stderr2
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail072.stderr4
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail133.stderr7
m---------utils/haddock0
109 files changed, 1359 insertions, 2637 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 9a827e03ee..76bdaa0a80 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -35,8 +35,7 @@ module DataCon (
dataConSrcBangs,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
- dataConWorkId, dataConWrapId, dataConWrapId_maybe,
- dataConImplicitTyThings,
+ dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness, dataConImplBangs, dataConBoxer,
splitDataProductType_maybe,
@@ -47,18 +46,16 @@ module DataCon (
isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
-- ** Promotion related functions
- promoteDataCon, promoteDataCon_maybe,
- promoteType, promoteKind,
- isPromotableType, computeTyConPromotability,
+ promoteKind, promoteDataCon, promoteDataCon_maybe
) where
#include "HsVersions.h"
import {-# SOURCE #-} MkId( DataConBoxer )
import Type
-import ForeignCall( CType )
import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
+import ForeignCall( CType )
import Coercion
import Kind
import Unify
@@ -75,11 +72,11 @@ import BasicTypes
import FastString
import Module
import VarEnv
-import NameSet
import Binary
import qualified Data.Data as Data
import qualified Data.Typeable
+import Data.Maybe
import Data.Char
import Data.Word
import Data.List( mapAccumL, find )
@@ -402,8 +399,8 @@ data DataCon
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
- dcPromoted :: Promoted TyCon -- The promoted TyCon if this DataCon is promotable
- -- See Note [Promoted data constructors] in TyCon
+ dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable
+ -- See Note [Promoted data constructors] in TyCon
}
deriving Data.Typeable.Typeable
@@ -674,9 +671,7 @@ isMarkedStrict _ = True -- All others are strict
-- | Build a new data constructor
mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
- -> Promoted TyConRepName -- ^ Whether promoted, and if so the TyConRepName
- -- for the promoted TyCon
- -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
+ -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
@@ -693,7 +688,7 @@ mkDataCon :: Name
-> DataCon
-- Can get the tag from the TyCon
-mkDataCon name declared_infix prom_info
+mkDataCon name declared_infix
arg_stricts -- Must match orig_arg_tys 1-1
fields
univ_tvs ex_tvs
@@ -738,12 +733,15 @@ mkDataCon name declared_infix prom_info
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted -- See Note [Promoted data constructors] in TyCon
- = case prom_info of
- NotPromoted -> NotPromoted
- Promoted rep_nm -> Promoted (mkPromotedDataCon con name rep_nm prom_kind prom_roles)
- prom_kind = promoteType (dataConUserType con)
- prom_roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
- map (const Representational) orig_arg_tys
+ | isJust (promotableTyCon_maybe rep_tycon)
+ -- The TyCon is promotable only if all its datacons
+ -- are, so the promoteType for prom_kind should succeed
+ = Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
+ | otherwise
+ = Nothing
+ prom_kind = promoteType (dataConUserType con)
+ roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
+ map (const Representational) orig_arg_tys
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
@@ -826,13 +824,11 @@ dataConWrapId dc = case dcRep dc of
-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
-- the union of the 'dataConWorkId' and the 'dataConWrapId'
-dataConImplicitTyThings :: DataCon -> [TyThing]
-dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })
- = [AnId work] ++ wrap_ids
- where
- wrap_ids = case rep of
- NoDataConRep -> []
- DCR { dcr_wrap_id = wrap } -> [AnId wrap]
+dataConImplicitIds :: DataCon -> [Id]
+dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
+ = case rep of
+ NoDataConRep -> [work]
+ DCR { dcr_wrap_id = wrap } -> [wrap,work]
-- | The labels for the fields of this particular 'DataCon'
dataConFieldLabels :: DataCon -> [FieldLabel]
@@ -1077,112 +1073,60 @@ dataConCannotMatch tys con
{-
************************************************************************
* *
- Promotion
-
- These functions are here becuase
- - isPromotableTyCon calls dataConFullSig
- - mkDataCon calls promoteType
- - It's nice to keep the promotion stuff together
+ Building an algebraic data type
* *
************************************************************************
-Note [The overall promotion story]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is the overall plan.
-
-* Compared to a TyCon T, the promoted 'T has
- same Name (and hence Unique)
- same TyConRepName
- In future the two will collapse into one anyhow.
-
-* Compared to a DataCon K, the promoted 'K (a type constructor) has
- same Name (and hence Unique)
- But it has a fresh TyConRepName; after all, the DataCon doesn't have
- a TyConRepName at all. (See Note [Grand plan for Typeable] in TcTypeable
- for TyConRepName.)
-
- Why does 'K have the same unique as K? It's acceptable because we don't
- mix types and terms, so we won't get them confused. And it's helpful mainly
- so that we know when to print 'K as a qualified name in error message. The
- PrintUnqualified stuff depends on whether K is lexically in scope.. but 'K
- never is!
-
-* It follows that the tick-mark (eg 'K) is not part of the Occ name of
- either promoted data constructors or type constructors. Instead,
- pretty-printing: the pretty-printer prints a tick in front of
- - promoted DataCons (always)
- - promoted TyCons (with -dppr-debug)
- See TyCon.pprPromotionQuote
-
-* For a promoted data constructor K, the pipeline goes like this:
- User writes (in a type): K or 'K
- Parser produces OccName: K{tc} or K{d}, respectively
- Renamer makes Name: M.K{d}_r62 (i.e. same unique as DataCon K)
- and K{tc} has been turned into K{d}
- provided it was unambiguous
- Typechecker makes TyCon: PromotedDataCon MK{d}_r62
-
-
-Note [Checking whether a group is promotable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We only want to promote a TyCon if all its data constructors
-are promotable; it'd be very odd to promote some but not others.
+buildAlgTyCon is here because it is called from TysWiredIn, which in turn
+depends on DataCon, but not on BuildTyCl.
+-}
+
+buildAlgTyCon :: Name
+ -> [TyVar] -- ^ Kind variables and type variables
+ -> [Role]
+ -> Maybe CType
+ -> ThetaType -- ^ Stupid theta
+ -> AlgTyConRhs
+ -> RecFlag
+ -> Bool -- ^ True <=> this TyCon is promotable
+ -> Bool -- ^ True <=> was declared in GADT syntax
+ -> TyConParent
+ -> TyCon
+
+buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
+ is_rec is_promotable gadt_syn parent
+ = tc
+ where
+ kind = mkPiKinds ktvs liftedTypeKind
+
+ -- tc and mb_promoted_tc are mutually recursive
+ tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
+ rhs parent is_rec gadt_syn
+ mb_promoted_tc
-But the data constructors may mention this or other TyCons.
+ mb_promoted_tc
+ | is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
+ | otherwise = Nothing
-So we treat the recursive uses as all OK (ie promotable) and
-do one pass to check that each TyCon is promotable.
+{-
+************************************************************************
+* *
+ Promoting of data types to the kind level
+* *
+************************************************************************
-Currently type synonyms are not promotable, though that
-could change.
+These two 'promoted..' functions are here because
+ * They belong together
+ * 'promoteDataCon' depends on DataCon stuff
-}
promoteDataCon :: DataCon -> TyCon
-promoteDataCon (MkData { dcPromoted = Promoted tc }) = tc
+promoteDataCon (MkData { dcPromoted = Just tc }) = tc
promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
-promoteDataCon_maybe :: DataCon -> Promoted TyCon
+promoteDataCon_maybe :: DataCon -> Maybe TyCon
promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
-computeTyConPromotability :: NameSet -> TyCon -> Bool
-computeTyConPromotability rec_tycons tc
- = isAlgTyCon tc -- Only algebraic; not even synonyms
- -- (we could reconsider the latter)
- && ok_kind (tyConKind tc)
- && case algTyConRhs tc of
- DataTyCon { data_cons = cs } -> all ok_con cs
- TupleTyCon { data_con = c } -> ok_con c
- NewTyCon { data_con = c } -> ok_con c
- AbstractTyCon {} -> False
- where
- ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
- where -- Checks for * -> ... -> * -> *
- (args, res) = splitKindFunTys kind
-
- -- See Note [Promoted data constructors] in TyCon
- ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
- && null eq_spec -- No constraints
- && null theta
- && all (isPromotableType rec_tycons) orig_arg_tys
- where
- (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
-
-
-isPromotableType :: NameSet -> Type -> Bool
--- Must line up with promoteType
--- But the function lives here because we must treat the
--- *recursive* tycons as promotable
-isPromotableType rec_tcs con_arg_ty
- = go con_arg_ty
- where
- go (TyConApp tc tys) = tys `lengthIs` tyConArity tc
- && (tyConName tc `elemNameSet` rec_tcs
- || isPromotableTyCon tc)
- && all go tys
- go (FunTy arg res) = go arg && go res
- go (TyVarTy {}) = True
- go _ = False
-
{-
Note [Promoting a Type to a Kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1212,7 +1156,7 @@ promoteType ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
- go (TyConApp tc tys) | Promoted prom_tc <- promotableTyCon_maybe tc
+ go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc
= mkTyConApp prom_tc (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
@@ -1264,41 +1208,3 @@ splitDataProductType_maybe ty
= Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
| otherwise
= Nothing
-
-{-
-************************************************************************
-* *
- Building an algebraic data type
-* *
-************************************************************************
-
-buildAlgTyCon is here because it is called from TysWiredIn, which can
-depend on this module, but not on BuildTyCl.
--}
-
-buildAlgTyCon :: Name
- -> [TyVar] -- ^ Kind variables and type variables
- -> [Role]
- -> Maybe CType
- -> ThetaType -- ^ Stupid theta
- -> AlgTyConRhs
- -> RecFlag
- -> Bool -- ^ True <=> this TyCon is promotable
- -> Bool -- ^ True <=> was declared in GADT syntax
- -> AlgTyConFlav
- -> TyCon
-
-buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
- is_rec is_promotable gadt_syn parent
- = tc
- where
- kind = mkPiKinds ktvs liftedTypeKind
-
- -- tc and mb_promoted_tc are mutually recursive
- tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
- rhs parent is_rec gadt_syn
- mb_promoted_tc
-
- mb_promoted_tc
- | is_promotable = Promoted (mkPromotedTyCon tc (promoteKind kind))
- | otherwise = NotPromoted
diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index e2997096aa..67942df518 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -72,7 +72,6 @@ module OccName (
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc,
- mkTyConRepUserOcc, mkTyConRepSysOcc,
-- ** Deconstruction
occNameFS, occNameString, occNameSpace,
@@ -587,8 +586,7 @@ mkDataConWrapperOcc, mkWorkerOcc,
mkGenR, mkGen1R, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
- mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
- mkTyConRepUserOcc, mkTyConRepSysOcc
+ mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
@@ -611,24 +609,11 @@ mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes
mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions
mkEqPredCoOcc = mk_simple_deriv tcName "$co"
--- Used in derived instances
+-- used in derived instances
mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
--- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable
--- incluing the wrinkle about mkSpecialTyConRepName
-mkTyConRepSysOcc occ = mk_simple_deriv varName prefix occ
- where
- prefix | isDataOcc occ = "$tc'"
- | otherwise = "$tc"
-
-mkTyConRepUserOcc occ = mk_simple_deriv varName prefix occ
- where
- -- *User-writable* prefix, for types in gHC_TYPES
- prefix | isDataOcc occ = "tc'"
- | otherwise = "tc"
-
-- Generic deriving mechanism
-- | Generate a module-unique name, to be used e.g. while generating new names
diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index 5705c6fbaf..12629ff91a 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -48,13 +48,10 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
- mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
+ mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkCostCentreUnique,
- tyConRepNameUnique,
- dataConWorkerUnique, dataConRepNameUnique,
-
mkBuiltinUnique,
mkPseudoUniqueD,
mkPseudoUniqueE,
@@ -102,10 +99,9 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int -- for Var
-incrUnique :: Unique -> Unique
-stepUnique :: Unique -> Int -> Unique
-deriveUnique :: Unique -> Int -> Unique
-newTagUnique :: Unique -> Char -> Unique
+incrUnique :: Unique -> Unique
+deriveUnique :: Unique -> Int -> Unique
+newTagUnique :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
@@ -113,11 +109,9 @@ mkUniqueGrimily = MkUnique
getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i + 1)
-stepUnique (MkUnique i) n = MkUnique (i + n)
-- deriveUnique uses an 'X' tag so that it won't clash with
-- any of the uniques produced any other way
--- SPJ says: this looks terribly smelly to me!
deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
-- newTagUnique changes the "domain" of a unique to a different char
@@ -311,19 +305,14 @@ mkPArrDataConUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
---------------------------------------------------
--- Wired-in data constructor keys occupy *three* slots:
--- * u: the DataCon itself
--- * u+1: its worker Id
--- * u+2: the TyConRepName of the promoted TyCon
--- Prelude data constructors are too simple to need wrappers.
-mkPreludeTyConUnique i = mkUnique '3' (3*i)
-mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
-mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
-mkCTupleTyConUnique a = mkUnique 'k' (3*a)
+-- Prelude type constructors occupy *three* slots.
+-- The first is for the tycon itself; the latter two
+-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
-tyConRepNameUnique :: Unique -> Unique
-tyConRepNameUnique u = incrUnique u
+mkPreludeTyConUnique i = mkUnique '3' (3*i)
+mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
+mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
+mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
@@ -331,22 +320,10 @@ tyConRepNameUnique u = incrUnique u
-- used for the worker function (the function that builds the constructor
-- representation).
---------------------------------------------------
--- Wired-in data constructor keys occupy *three* slots:
--- * u: the DataCon itself
--- * u+1: its worker Id
--- * u+2: the TyConRepName of the promoted TyCon
--- Prelude data constructors are too simple to need wrappers.
-
-mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
-mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels)
-mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a)
-
-dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
-dataConWorkerUnique u = incrUnique u
-dataConRepNameUnique u = stepUnique u 2
+mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
+mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
+mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
---------------------------------------------------
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 8670e2104e..fb797f11ce 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -126,12 +126,12 @@ mkCoreLets binds body = foldr mkCoreLet body binds
-- | Construct an expression which represents the application of one expression
-- to the other
-mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
+mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
-- Respects the let/app invariant by building a case expression where necessary
-- See CoreSyn Note [CoreSyn let/app invariant]
-mkCoreApp _ fun (Type ty) = App fun (Type ty)
-mkCoreApp _ fun (Coercion co) = App fun (Coercion co)
-mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
+mkCoreApp fun (Type ty) = App fun (Type ty)
+mkCoreApp fun (Coercion co) = App fun (Coercion co)
+mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
mk_val_app fun arg arg_ty res_ty
where
fun_ty = exprType fun
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 93b50dfc7c..4fa09cb42a 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -44,11 +44,10 @@ import TyCon
import TcEvidence
import TcType
import Type
-import Kind( isKind )
+import Kind (returnsConstraintKind)
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
- , mkBoxedTupleTy, charTy
- , typeNatKind, typeSymbolKind )
+ , mkBoxedTupleTy, charTy, typeNatKind, typeSymbolKind )
import Id
import MkId(proxyHashId)
import Class
@@ -71,12 +70,15 @@ import FastString
import Util
import MonadUtils
import Control.Monad(liftM,when)
+import Fingerprint(Fingerprint(..), fingerprintString)
-{-**********************************************************************
+{-
+************************************************************************
* *
- Desugaring a MonoBinds
+\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
* *
-**********************************************************************-}
+************************************************************************
+-}
dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds binds = ds_lhs_binds binds
@@ -813,7 +815,7 @@ dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
; dsHsWrapper c1 e1 }
dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
; e1 <- dsHsWrapper c1 (Var x)
- ; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
+ ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
; return (Lam x e2) }
dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
dsTcCoercion co (mkCastDs e)
@@ -851,145 +853,154 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
= (b, var, varSetElems (evVarsOfTerm term))
-{-**********************************************************************
-* *
- Desugaring EvTerms
-* *
-**********************************************************************-}
-
+---------------------------------------
dsEvTerm :: EvTerm -> DsM CoreExpr
-dsEvTerm (EvId v) = return (Var v)
-dsEvTerm (EvCallStack cs) = dsEvCallStack cs
-dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
-dsEvTerm (EvLit (EvNum n)) = mkIntegerExpr n
-dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s
+dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCastDs tm' }
- -- 'v' is always a lifted evidence variable so it is
- -- unnecessary to call varToCoreExpr v here.
-
-dsEvTerm (EvDFunApp df tys tms)
- = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
+ -- 'v' is always a lifted evidence variable so it is
+ -- unnecessary to call varToCoreExpr v here.
+dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
-
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
-dsEvTerm (EvDelayedError ty msg)
- = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
+dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
-{-**********************************************************************
-* *
- Desugaring Typeable dictionaries
-* *
-**********************************************************************-}
-
-dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
--- Return a CoreExpr :: Typeable ty
--- This code is tightly coupled to the representation
--- of TypeRep, in base library Data.Typeable.Internals
-dsEvTypeable ty ev
- = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable
- ; let kind = typeKind ty
- Just typeable_data_con
- = tyConSingleDataCon_maybe tyCl -- "Data constructor"
- -- for Typeable
-
- ; rep_expr <- ds_ev_typeable ty ev
-
- -- Build Core for (let r::TypeRep = rep in \proxy. rep)
- -- See Note [Memoising typeOf]
- ; repName <- newSysLocalDs (exprType rep_expr)
- ; let proxyT = mkProxyPrimTy kind ty
- method = bindNonRec repName rep_expr
- $ mkLams [mkWildValBinder proxyT] (Var repName)
-
- -- Package up the method as `Typeable` dictionary
- ; return $ mkConApp typeable_data_con [Type kind, Type ty, method] }
-
-
-ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
--- Returns a CoreExpr :: TypeRep ty
-ds_ev_typeable ty EvTypeableTyCon
- | Just (tc, ks) <- splitTyConApp_maybe ty
- = ASSERT( all isKind ks )
- do { ctr <- dsLookupGlobalId mkPolyTyConAppName
- -- mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
- ; tyRepTc <- dsLookupTyCon typeRepTyConName -- TypeRep (the TyCon)
- ; let tyRepType = mkTyConApp tyRepTc [] -- TypeRep (the Type)
- mkRep cRep kReps tReps
- = mkApps (Var ctr) [ cRep
- , mkListExpr tyRepType kReps
- , mkListExpr tyRepType tReps ]
-
- kindRep k -- Returns CoreExpr :: TypeRep for that kind k
- = case splitTyConApp_maybe k of
- Nothing -> panic "dsEvTypeable: not a kind constructor"
- Just (kc,ks) -> do { kcRep <- tyConRep kc
- ; reps <- mapM kindRep ks
- ; return (mkRep kcRep [] reps) }
-
- ; tcRep <- tyConRep tc
- ; kReps <- mapM kindRep ks
- ; return (mkRep tcRep kReps []) }
-
-ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
- | Just (t1,t2) <- splitAppTy_maybe ty
- = do { e1 <- getRep ev1 t1
- ; e2 <- getRep ev2 t2
- ; ctr <- dsLookupGlobalId mkAppTyName
- ; return ( mkApps (Var ctr) [ e1, e2 ] ) }
-
-ds_ev_typeable ty (EvTypeableTyLit ev)
- = do { fun <- dsLookupGlobalId tr_fun
- ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSym
- ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
- ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
+dsEvTerm (EvLit l) =
+ case l of
+ EvNum n -> mkIntegerExpr n
+ EvStr s -> mkStringExprFS s
+
+dsEvTerm (EvCallStack cs) = dsEvCallStack cs
+
+dsEvTerm (EvTypeable ev) = dsEvTypeable ev
+
+dsEvTypeable :: EvTypeable -> DsM CoreExpr
+dsEvTypeable ev =
+ do tyCl <- dsLookupTyCon typeableClassName
+ typeRepTc <- dsLookupTyCon typeRepTyConName
+ let tyRepType = mkTyConApp typeRepTc []
+
+ (ty, rep) <-
+ case ev of
+
+ EvTypeableTyCon tc ks ->
+ do ctr <- dsLookupGlobalId mkPolyTyConAppName
+ mkTyCon <- dsLookupGlobalId mkTyConName
+ dflags <- getDynFlags
+ let mkRep cRep kReps tReps =
+ mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps
+ , mkListExpr tyRepType tReps ]
+
+ let kindRep k =
+ case splitTyConApp_maybe k of
+ Nothing -> panic "dsEvTypeable: not a kind constructor"
+ Just (kc,ks) ->
+ do kcRep <- tyConRep dflags mkTyCon kc
+ reps <- mapM kindRep ks
+ return (mkRep kcRep [] reps)
+
+ tcRep <- tyConRep dflags mkTyCon tc
+
+ kReps <- mapM kindRep ks
+
+ return ( mkTyConApp tc ks
+ , mkRep tcRep kReps []
+ )
+
+ EvTypeableTyApp t1 t2 ->
+ do e1 <- getRep tyCl t1
+ e2 <- getRep tyCl t2
+ ctr <- dsLookupGlobalId mkAppTyName
+
+ return ( mkAppTy (snd t1) (snd t2)
+ , mkApps (Var ctr) [ e1, e2 ]
+ )
+
+ EvTypeableTyLit t ->
+ do e <- tyLitRep t
+ return (snd t, e)
+
+ -- TyRep -> Typeable t
+ -- see also: Note [Memoising typeOf]
+ repName <- newSysLocalDs tyRepType
+ let proxyT = mkProxyPrimTy (typeKind ty) ty
+ method = bindNonRec repName rep
+ $ mkLams [mkWildValBinder proxyT] (Var repName)
+
+ -- package up the method as `Typeable` dictionary
+ return $ mkCastDs method $ mkSymCo $ getTypeableCo tyCl ty
+
where
- ty_kind = typeKind ty
-
- -- tr_fun is the Name of
- -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
- -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
- tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName
- | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
- | otherwise = panic "dsEvTypeable: unknown type lit kind"
-
-
-ds_ev_typeable ty ev
- = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
-
-getRep :: EvTerm -> Type -- EvTerm for Typeable ty, and ty
- -> DsM CoreExpr -- Return CoreExpr :: TypeRep (of ty)
- -- namely (typeRep# dict proxy)
--- Remember that
--- typeRep# :: forall k (a::k). Typeable k a -> Proxy k a -> TypeRep
-getRep ev ty
- = do { typeable_expr <- dsEvTerm ev
- ; typeRepId <- dsLookupGlobalId typeRepIdName
- ; let ty_args = [typeKind ty, ty]
- ; return (mkApps (mkTyApps (Var typeRepId) ty_args)
- [ typeable_expr
- , mkTyApps (Var proxyHashId) ty_args ]) }
-
-tyConRep :: TyCon -> DsM CoreExpr
--- Returns CoreExpr :: TyCon
-tyConRep tc
- | Just tc_rep_nm <- tyConRepName_maybe tc
- = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
- ; return (Var tc_rep_id) }
- | otherwise
- = pprPanic "tyConRep" (ppr tc)
+ -- co: method -> Typeable k t
+ getTypeableCo tc t =
+ case instNewTyCon_maybe tc [typeKind t, t] of
+ Just (_,co) -> co
+ _ -> panic "Class `Typeable` is not a `newtype`."
+
+ -- Typeable t -> TyRep
+ getRep tc (ev,t) =
+ do typeableExpr <- dsEvTerm ev
+ let co = getTypeableCo tc t
+ method = mkCastDs typeableExpr co
+ proxy = mkTyApps (Var proxyHashId) [typeKind t, t]
+ return (mkApps method [proxy])
+
+ -- KnownNat t -> TyRep (also used for KnownSymbol)
+ tyLitRep (ev,t) =
+ do dict <- dsEvTerm ev
+ fun <- dsLookupGlobalId $
+ case typeKind t of
+ k | eqType k typeNatKind -> typeNatTypeRepName
+ | eqType k typeSymbolKind -> typeSymbolTypeRepName
+ | otherwise -> panic "dsEvTypeable: unknown type lit kind"
+ let finst = mkTyApps (Var fun) [t]
+ proxy = mkTyApps (Var proxyHashId) [typeKind t, t]
+ return (mkApps finst [ dict, proxy ])
+
+ -- This part could be cached
+ tyConRep dflags mkTyCon tc =
+ do pkgStr <- mkStringExprFS pkg_fs
+ modStr <- mkStringExprFS modl_fs
+ nameStr <- mkStringExprFS name_fs
+ return (mkApps (Var mkTyCon) [ int64 high, int64 low
+ , pkgStr, modStr, nameStr
+ ])
+ where
+ tycon_name = tyConName tc
+ modl = nameModule tycon_name
+ pkg = moduleUnitId modl
+
+ modl_fs = moduleNameFS (moduleName modl)
+ pkg_fs = unitIdFS pkg
+ name_fs = occNameFS (nameOccName tycon_name)
+ hash_name_fs
+ | isPromotedTyCon tc = appendFS (mkFastString "$k") name_fs
+ | isPromotedDataCon tc = appendFS (mkFastString "$c") name_fs
+ | isTupleTyCon tc &&
+ returnsConstraintKind (tyConKind tc)
+ = appendFS (mkFastString "$p") name_fs
+ | otherwise = name_fs
+
+ hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]
+ Fingerprint high low = fingerprintString hashThis
+
+ int64
+ | wORD_SIZE dflags == 4 = mkWord64LitWord64
+ | otherwise = mkWordLit dflags . fromIntegral
+
+
{- Note [Memoising typeOf]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1001,11 +1012,8 @@ help GHC by manually keeping the 'rep' *outside* the lambda.
-}
-{-**********************************************************************
-* *
- Desugaring EvCallStack evidence
-* *
-**********************************************************************-}
+
+
dsEvCallStack :: EvCallStack -> DsM CoreExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
@@ -1017,7 +1025,7 @@ dsEvCallStack cs = do
let srcLocTy = mkTyConTy srcLocTyCon
let mkSrcLoc l =
liftM (mkCoreConApps srcLocDataCon)
- (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
+ (sequence [ mkStringExpr (showPpr df $ moduleUnitId m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt df (srcSpanStartLine l)
@@ -1063,12 +1071,7 @@ dsEvCallStack cs = do
EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
EvCsEmpty -> panic "Cannot have an empty CallStack"
-{-**********************************************************************
-* *
- Desugaring Coercions
-* *
-**********************************************************************-}
-
+---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- This is the crucial function that moves
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 6e415d7b4c..f47843aa06 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -217,8 +217,8 @@ dsExpr (HsLamCase arg matches)
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
-dsExpr e@(HsApp fun arg)
- = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
+dsExpr (HsApp fun arg)
+ = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
{-
@@ -260,15 +260,15 @@ If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
-}
-dsExpr e@(OpApp e1 op _ e2)
+dsExpr (OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
- mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+ mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
- = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
+ = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
-dsExpr e@(SectionR op expr) = do
+dsExpr (SectionR op expr) = do
core_op <- dsLExpr op
-- for the type of x, we need the type of op's 2nd argument
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
@@ -277,7 +277,7 @@ dsExpr e@(SectionR op expr) = do
x_id <- newSysLocalDs x_ty
y_id <- newSysLocalDs y_ty
return (bindNonRec y_id y_core $
- Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
+ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing ty))
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index 503e29de46..bce5186f08 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -241,7 +241,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr var =
- adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var))))
+ adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
@@ -343,7 +343,7 @@ mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
let MatchResult _ mkCont = match_result
cont <- mkCoreLams bndrs <$> mkCont fail
- return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+ return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
where
MkCaseAlt{ alt_pat = psyn,
alt_bndrs = bndrs,
@@ -536,8 +536,8 @@ into
which stupidly tries to bind the datacon 'True'.
-}
-mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
| f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
= Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
where
@@ -545,10 +545,10 @@ mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
_ -> mkWildValBinder ty1
-mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
+mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
-mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
+mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
-- We define a desugarer-specific verison of CoreUtils.mkCast,
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 5506078004..e31d848a08 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -414,7 +414,6 @@ Library
TcErrors
TcTyClsDecls
TcTyDecls
- TcTypeable
TcType
TcEvidence
TcUnify
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index a2ed9488b8..be01baa4ea 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -41,7 +41,7 @@ module HsUtils(
mkPatSynBind,
-- Literals
- mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
+ mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
-- Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
@@ -319,10 +319,6 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString s (mkFastString s)
-mkHsStringPrimLit :: FastString -> HsLit
-mkHsStringPrimLit fs
- = HsStringPrim (unpackFS fs) (fastStringToByteString fs)
-
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 6085b0cc3c..11873077ce 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -14,7 +14,7 @@ module BuildTyCl (
TcMethInfo, buildClass,
distinctAbstractTyConRhs, totallyAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs,
- newImplicitBinder, newTyConRepName
+ newImplicitBinder
) where
#include "HsVersions.h"
@@ -22,7 +22,6 @@ module BuildTyCl (
import IfaceEnv
import FamInstEnv( FamInstEnvs )
import TysWiredIn( isCTupleTyConName )
-import PrelNames( tyConRepModOcc )
import DataCon
import PatSyn
import Var
@@ -37,7 +36,6 @@ import Id
import Coercion
import TcType
-import SrcLoc( noSrcSpan )
import DynFlags
import TcRnMonad
import UniqSupply
@@ -51,8 +49,7 @@ buildSynonymTyCon :: Name -> [TyVar] -> [Role]
-> TyCon
buildSynonymTyCon tc_name tvs roles rhs rhs_kind
= mkSynonymTyCon tc_name kind tvs roles rhs
- where
- kind = mkPiKinds tvs rhs_kind
+ where kind = mkPiKinds tvs rhs_kind
buildFamilyTyCon :: Name -- ^ Type family name
@@ -60,7 +57,7 @@ buildFamilyTyCon :: Name -- ^ Type family name
-> Maybe Name -- ^ Result variable name
-> FamTyConFlav -- ^ Open, closed or in a boot file?
-> Kind -- ^ Kind of the RHS
- -> Maybe Class -- ^ Parent, if exists
+ -> TyConParent -- ^ Parent, if exists
-> Injectivity -- ^ Injectivity annotation
-- See [Injectivity annotation] in HsDecls
-> TyCon
@@ -135,9 +132,7 @@ mkNewTyConRhs tycon_name tycon con
------------------------------------------------------
buildDataCon :: FamInstEnvs
- -> Name
- -> Bool -- Declared infix
- -> Promoted TyConRepName -- Promotable
+ -> Name -> Bool
-> [HsSrcBang]
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
@@ -153,7 +148,7 @@ buildDataCon :: FamInstEnvs
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
-buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
+buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
@@ -161,12 +156,11 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
-- code, which (for Haskell source anyway) will be in the DataName name
-- space, and puts it into the VarName name space
- ; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; dflags <- getDynFlags
; let
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
- data_con = mkDataCon src_name declared_infix prom_info
+ data_con = mkDataCon src_name declared_infix
src_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
@@ -175,7 +169,6 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
impl_bangs data_con)
- ; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
@@ -234,8 +227,7 @@ type TcMethInfo = (Name, DefMethSpec, Type)
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
-buildClass :: Name -- Name of the class/tycon (they have the same Name)
- -> [TyVar] -> [Role] -> ThetaType
+buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
@@ -248,7 +240,10 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
do { traceIf (text "buildClass")
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
- ; tc_rep_name <- newTyConRepName tycon_name
+ -- The class name is the 'parent' for this datacon, not its tycon,
+ -- because one should import the class to get the binding for
+ -- the datacon
+
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-- Build the selector id and default method id
@@ -287,7 +282,6 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False -- Not declared infix
- NotPromoted -- Class tycons are not promoted
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
@@ -306,8 +300,9 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
else return (mkDataTyConRhs [dict_con])
; let { clas_kind = mkPiKinds tvs constraintKind
- ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
- rhs rec_clas tc_isrec tc_rep_name
+
+ ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
+ rhs rec_clas tc_isrec
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
-- class C a where { op :: C b => a -> b -> Int }
@@ -371,12 +366,3 @@ newImplicitBinder base_name mk_sys_occ
where
occ = mk_sys_occ (nameOccName base_name)
loc = nameSrcSpan base_name
-
--- | Make the 'TyConRepName' for this 'TyCon'
-newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
-newTyConRepName tc_name
- | Just mod <- nameModule_maybe tc_name
- , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
- = newGlobalBinder mod occ noSrcSpan
- | otherwise
- = newImplicitBinder tc_name mkTyConRepUserOcc
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 3911786594..8bf744f0c7 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -165,8 +165,7 @@ data IfaceTyConParent
IfaceTcArgs
data IfaceFamTyConFlav
- = IfaceDataFamilyTyCon -- Data family
- | IfaceOpenSynFamilyTyCon
+ = IfaceOpenSynFamilyTyCon
| IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
-- ^ Name of associated axiom and branches for pretty printing purposes,
-- or 'Nothing' for an empty closed family without an axiom
@@ -193,6 +192,7 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
data IfaceConDecls
= IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon
+ | IfDataFamTyCon -- Data family
| IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
| IfNewTyCon IfaceConDecl Bool [FieldLabelString] -- Newtype decls
@@ -343,12 +343,14 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
+visibleIfConDecls IfDataFamTyCon = []
visibleIfConDecls (IfDataTyCon cs _ _) = cs
visibleIfConDecls (IfNewTyCon c _ _) = [c]
ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
ifaceConDeclFields x = case x of
IfAbstractTyCon {} -> []
+ IfDataFamTyCon {} -> []
IfDataTyCon cons is_over labels -> map (help cons is_over) labels
IfNewTyCon con is_over labels -> map (help [con] is_over) labels
where
@@ -366,15 +368,35 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
-- TyThing.getOccName should define a bijection between the two lists.
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
-
-ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = cons })
- = case cons of
- IfAbstractTyCon {} -> []
- IfNewTyCon cd _ _ -> mkNewTyCoOcc tc_occ : ifaceConDeclImplicitBndrs cd
- IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds
-
-ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ
- , ifSigs = sigs, ifATs = ats })
+ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = []
+
+-- Newtype
+ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
+ ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _})
+ = -- implicit newtype coercion
+ (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
+ -- data constructor and worker (newtypes don't have a wrapper)
+ [con_occ, mkDataConWorkerOcc con_occ]
+
+
+ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
+ ifCons = IfDataTyCon cons _ _ })
+ = -- for each data constructor in order,
+ -- data constructor, worker, and (possibly) wrapper
+ concatMap dc_occs cons
+ where
+ dc_occs con_decl
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ con_occ = ifConOcc con_decl -- DataCon namespace
+ wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
+ work_occ = mkDataConWorkerOcc con_occ -- Id namespace
+ has_wrapper = ifConWrapper con_decl -- This is the reason for
+ -- having the ifConWrapper field!
+
+ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
+ ifSigs = sigs, ifATs = ats })
= -- (possibly) newtype coercion
co_occs ++
-- data constructor (DataCon namespace)
@@ -398,14 +420,6 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ
ifaceDeclImplicitBndrs _ = []
-ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]
-ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConOcc = con_occ })
- = [con_occ, work_occ] ++ wrap_occs
- where
- work_occ = mkDataConWorkerOcc con_occ -- Id namespace
- wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace
- | otherwise = []
-
-- -----------------------------------------------------------------------------
-- The fingerprints of an IfaceDecl
@@ -671,6 +685,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
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")
@@ -679,7 +694,6 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_prom | is_prom = ptext (sLit "Promotable")
| otherwise = Outputable.empty
-
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
, ifCtxt = context, ifName = clas
, ifTyVars = tyvars, ifRoles = roles
@@ -724,12 +738,7 @@ pprIfaceDecl ss (IfaceSynonym { ifName = tc
pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, ifFamFlav = rhs, ifFamKind = kind
, ifResVar = res_var, ifFamInj = inj })
- | IfaceDataFamilyTyCon <- rhs
- = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon tyvars
-
- | otherwise
- = vcat [ hang (ptext (sLit "type family")
- <+> pprIfaceDeclHead [] ss tycon tyvars)
+ = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars)
2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
, ppShowRhs ss (nest 2 (pp_branches rhs)) ]
where
@@ -743,13 +752,11 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
[] -> empty
tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)]
- pp_rhs IfaceDataFamilyTyCon
- = ppShowIface ss (ptext (sLit "data"))
pp_rhs IfaceOpenSynFamilyTyCon
= ppShowIface ss (ptext (sLit "open"))
pp_rhs IfaceAbstractClosedSynFamilyTyCon
= ppShowIface ss (ptext (sLit "closed, abstract"))
- pp_rhs (IfaceClosedSynFamilyTyCon {})
+ pp_rhs (IfaceClosedSynFamilyTyCon _)
= ptext (sLit "where")
pp_rhs IfaceBuiltInSynFamTyCon
= ppShowIface ss (ptext (sLit "built-in"))
@@ -1163,13 +1170,12 @@ freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon
freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
-freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
-freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
+freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
= unitNameSet ax &&& fnList freeNamesIfAxBranch br
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
-freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
-freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
+freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
+freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
@@ -1520,22 +1526,18 @@ instance Binary IfaceDecl where
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
instance Binary IfaceFamTyConFlav where
- put_ bh IfaceDataFamilyTyCon = putByte bh 0
- put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1
- put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb
- put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3
+ put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
+ put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 1 >> put_ bh mb
+ put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ _ IfaceBuiltInSynFamTyCon
= pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
get bh = do { h <- getByte bh
; case h of
- 0 -> return IfaceDataFamilyTyCon
- 1 -> return IfaceOpenSynFamilyTyCon
- 2 -> do { mb <- get bh
+ 0 -> return IfaceOpenSynFamilyTyCon
+ 1 -> do { mb <- get bh
; return (IfaceClosedSynFamilyTyCon mb) }
- 3 -> return IfaceAbstractClosedSynFamilyTyCon
- _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag"
- (ppr (fromIntegral h :: Int)) }
+ _ -> return IfaceAbstractClosedSynFamilyTyCon }
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
@@ -1574,16 +1576,17 @@ instance Binary IfaceAxBranch where
return (IfaceAxBranch a1 a2 a3 a4 a5)
instance Binary IfaceConDecls where
- put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
- put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs
- put_ bh (IfNewTyCon c b fs) = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs
+ put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
+ put_ bh IfDataFamTyCon = putByte bh 1
+ put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs
+ put_ bh (IfNewTyCon c b fs) = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs
get bh = do
h <- getByte bh
case h of
0 -> liftM IfAbstractTyCon $ get bh
- 1 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
- 2 -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
- _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
+ 1 -> return IfDataFamTyCon
+ 2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
+ _ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
instance Binary IfaceConDecl where
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index b7bdc38ae5..df96f6a4af 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1611,7 +1611,7 @@ tyConToIfaceDecl env tycon
ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifPromotable = isPromotableTyCon tycon,
+ ifPromotable = isJust (promotableTyCon_maybe tycon),
ifParent = parent })
| otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
@@ -1649,14 +1649,16 @@ tyConToIfaceDecl env tycon
axn = coAxiomName ax
to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
= IfaceClosedSynFamilyTyCon Nothing
- to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
- to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
- to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
+ to_if_fam_flav AbstractClosedSynFamilyTyCon
+ = IfaceAbstractClosedSynFamilyTyCon
+ to_if_fam_flav (BuiltInSynFamTyCon {})
+ = IfaceBuiltInSynFamTyCon
ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
+ ifaceConDecls (DataFamilyTyCon {}) _ = IfDataFamTyCon
ifaceConDecls (TupleTyCon { data_con = con }) _ = IfDataTyCon [ifaceConDecl con] False []
ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct
-- The AbstractTyCon case happens when a TyCon has been trimmed
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 80de36e82d..1328b3c002 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -297,13 +297,13 @@ What this means is that the implicitTyThings MUST NOT DEPEND on any of
the forkM stuff.
-}
-tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings
+tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
-> IfaceDecl
-> IfL TyThing
-tcIfaceDecl = tc_iface_decl Nothing
+tcIfaceDecl = tc_iface_decl NoParentTyCon
-tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations
- -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings
+tc_iface_decl :: TyConParent -- For nested declarations
+ -> Bool -- True <=> discard IdInfo on IfaceId bindings
-> IfaceDecl
-> IfL TyThing
tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
@@ -314,7 +314,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
; info <- tcIdInfo ignore_prags name ty info
; return (AnId (mkGlobalId details name ty info)) }
-tc_iface_decl _ _ (IfaceData {ifName = occ_name,
+tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifCType = cType,
ifTyVars = tv_bndrs,
ifRoles = roles,
@@ -326,23 +326,22 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name,
{ tc_name <- lookupIfaceTop occ_name
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; parent' <- tc_parent tc_name mb_parent
- ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons is_prom
+ ; 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 :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
- tc_parent tc_name IfNoParent
- = do { tc_rep_name <- newTyConRepName tc_name
- ; return (VanillaAlgTyCon tc_rep_name) }
- tc_parent _ (IfDataInstance ax_name _ arg_tys)
- = do { ax <- tcIfaceCoAxiom 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
ax_unbr = toUnbranchedAxiom ax
; lhs_tys <- tcIfaceTcArgs arg_tys
- ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
+ ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
ifRoles = roles,
@@ -366,25 +365,20 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
{ tc_name <- lookupIfaceTop occ_name
; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
- tc_fam_flav tc_name fam_flav
+ tc_fam_flav fam_flav
; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind
parent inj
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type synonym") <+> ppr n
-
- tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
- tc_fam_flav tc_name IfaceDataFamilyTyCon
- = do { tc_rep_name <- newTyConRepName tc_name
- ; return (DataFamilyTyCon tc_rep_name) }
- tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
- tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
+ tc_fam_flav IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon
+ tc_fam_flav (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
= do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
; return (ClosedSynFamilyTyCon ax) }
- tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
+ tc_fam_flav IfaceAbstractClosedSynFamilyTyCon
= return AbstractClosedSynFamilyTyCon
- tc_fam_flav _ IfaceBuiltInSynFamTyCon
+ tc_fam_flav IfaceBuiltInSynFamTyCon
= pprPanic "tc_iface_decl"
(text "IfaceBuiltInSynFamTyCon in interface file")
@@ -428,7 +422,7 @@ tc_iface_decl _parent ignore_prags
; return (op_name, dm, op_ty) }
tc_at cls (IfaceAT tc_decl if_def)
- = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
+ = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
mb_def <- case if_def of
Nothing -> return Nothing
Just def -> forkM (mk_at_doc tc) $
@@ -512,10 +506,11 @@ tc_ax_branch prev_branches
, cab_incomps = map (prev_branches !!) incomps }
; return (prev_branches ++ [br]) }
-tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> Bool -> IfL AlgTyConRhs
-tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
+tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
IfAbstractTyCon dis -> return (AbstractTyCon dis)
+ IfDataFamTyCon -> return DataFamilyTyCon
IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
; data_cons <- mapM (tc_con_decl field_lbls) cons
; return (mkDataTyConRhs data_cons) }
@@ -533,14 +528,14 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
-- parent TyCon, and are alrady in scope
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
- ; dc_name <- lookupIfaceTop occ
+ ; name <- lookupIfaceTop occ
-- Read the context and argument types, but lazily for two reasons
-- (a) to avoid looking tugging on a recursive use of
-- the type itself, which is knot-tied
-- (b) to avoid faulting in the component types unless
-- they are really needed
- ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
+ ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc name) $
do { eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt
; arg_tys <- mapM tcIfaceType args
@@ -560,24 +555,20 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
; let orig_res_ty = mkFamilyTyConApp tycon
(substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
- ; prom_info <- if is_prom then do { n <- newTyConRepName dc_name
- ; return (Promoted n) }
- else return NotPromoted
-
- ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
- dc_name is_infix prom_info
- (map src_strict if_src_stricts)
- (Just stricts)
- -- Pass the HsImplBangs (i.e. final
- -- decisions) to buildDataCon; it'll use
- -- these to guide the construction of a
- -- worker.
- -- See Note [Bangs on imported data constructors] in MkId
- lbl_names
- tc_tyvars ex_tyvars
- eq_spec theta
- arg_tys orig_res_ty tycon
- ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
+ ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
+ name is_infix
+ (map src_strict if_src_stricts)
+ (Just stricts)
+ -- Pass the HsImplBangs (i.e. final
+ -- decisions) to buildDataCon; it'll use
+ -- these to guide the construction of a
+ -- worker.
+ -- See Note [Bangs on imported data constructors] in MkId
+ lbl_names
+ tc_tyvars ex_tyvars
+ eq_spec theta
+ arg_tys orig_res_ty tycon
+ ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name)
; return con }
mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
@@ -898,7 +889,7 @@ tcIfaceTupleTy sort info args
-> return (mkTyConApp base_tc args')
IfacePromotedTyCon
- | Promoted tc <- promotableTyCon_maybe base_tc
+ | Just tc <- promotableTyCon_maybe base_tc
-> return (mkTyConApp tc args')
| otherwise
-> panic "tcIfaceTupleTy" (ppr base_tc)
@@ -1375,7 +1366,7 @@ tcIfaceTyCon (IfaceTyCon name info)
-- Same Name as its underlying TyCon
where
promote_tc tc
- | Promoted prom_tc <- promotableTyCon_maybe tc = prom_tc
+ | Just prom_tc <- promotableTyCon_maybe tc = prom_tc
| isSuperKind (tyConKind tc) = tc
| otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc)
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 95cb5f222f..64143e0c03 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -94,11 +94,9 @@ import BasicTypes ( HValue )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker
import CoreTidy ( tidyExpr )
-import Type ( Type )
-import {- Kind parts of -} Type ( Kind )
+import Type ( Type, Kind )
import CoreLint ( lintInteractiveExpr )
import VarEnv ( emptyTidyEnv )
-import THNames ( templateHaskellNames )
import ConLike
import GHC.Exts
@@ -183,7 +181,7 @@ newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags = do
eps_var <- newIORef initExternalPackageState
us <- mkSplitUniqSupply 'r'
- nc_var <- newIORef (initNameCache us allKnownKeyNames)
+ nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyModuleEnv
return HscEnv { hsc_dflags = dflags,
hsc_targets = [],
@@ -196,13 +194,6 @@ newHscEnv dflags = do
hsc_type_env_var = Nothing }
-allKnownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
-allKnownKeyNames = -- where templateHaskellNames are defined
- knownKeyNames
-#ifdef GHCI
- ++ templateHaskellNames
-#endif
-
-- -----------------------------------------------------------------------------
getWarnings :: Hsc WarningMessages
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index b711ffea51..fb65a67e6e 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1689,8 +1689,8 @@ implicitTyThings (AConLike cl) = implicitConLikeThings cl
implicitConLikeThings :: ConLike -> [TyThing]
implicitConLikeThings (RealDataCon dc)
- = dataConImplicitTyThings dc
-
+ = map AnId (dataConImplicitIds dc)
+ -- For data cons add the worker and (possibly) wrapper
implicitConLikeThings (PatSynCon {})
= [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher
-- are not "implicit"; they are simply new top-level bindings,
@@ -1705,7 +1705,7 @@ implicitClassThings cl
= -- Does not include default methods, because those Ids may have
-- their own pragmas, unfoldings etc, not derived from the Class object
-- associated types
- -- No recursive call for the classATs, because they
+ -- No extras_plus (recursive call) for the classATs, because they
-- are only the family decls; they have no implicit things
map ATyCon (classATs cl) ++
-- superclass and operation selectors
@@ -1721,8 +1721,7 @@ implicitTyConThings tc
-- for each data constructor in order,
-- the contructor, worker, and (possibly) wrapper
- [ thing | dc <- tyConDataCons tc
- , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ]
+ concatMap (extras_plus . AConLike . RealDataCon) (tyConDataCons tc)
-- NB. record selectors are *not* implicit, they have fully-fledged
-- bindings that pass through the compilation pipeline as normal.
where
@@ -1730,6 +1729,10 @@ implicitTyConThings tc
Nothing -> []
Just cl -> implicitClassThings cl
+-- add a thing and recursive call
+extras_plus :: TyThing -> [TyThing]
+extras_plus thing = thing : implicitTyThings thing
+
-- For newtypes and closed type families (only) add the implicit coercion tycon
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index f76b62ee00..f79b6b1e7f 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -10,7 +10,7 @@ module PrelInfo (
primOpRules, builtinRules,
ghcPrimExports,
- knownKeyNames,
+ wiredInThings, knownKeyNames,
primOpId,
-- Random other things
@@ -23,31 +23,56 @@ module PrelInfo (
#include "HsVersions.h"
-import Constants ( mAX_TUPLE_SIZE )
-import BasicTypes ( Boxity(..) )
-import ConLike ( ConLike(..) )
import PrelNames
import PrelRules
import Avail
import PrimOp
import DataCon
import Id
-import Name
import MkId
+import Name( Name, getName )
import TysPrim
import TysWiredIn
import HscTypes
import Class
import TyCon
+import Outputable
+import UniqFM
import Util
import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
+#ifdef GHCI
+import THNames
+#endif
+
import Data.Array
-{-
-************************************************************************
+
+{- *********************************************************************
+* *
+ Known key things
+* *
+********************************************************************* -}
+
+knownKeyNames :: [Name]
+knownKeyNames =
+ ASSERT2( isNullUFM badNamesUFM, text "badknownKeyNames" <+> ppr badNamesUFM )
+ names
+ where
+ badNamesUFM = filterUFM (\ns -> length ns > 1) namesUFM
+ namesUFM = foldl (\m n -> addToUFM_Acc (:) singleton m n n) emptyUFM names
+ names = concat
+ [ map getName wiredInThings
+ , cTupleTyConNames
+ , basicKnownKeyNames
+#ifdef GHCI
+ , templateHaskellNames
+#endif
+ ]
+
+{- *********************************************************************
* *
-\subsection[builtinNameInfo]{Lookup built-in names}
+ Wired in things
* *
************************************************************************
@@ -62,61 +87,33 @@ Notes about wired in things
* The name cache is initialised with (the names of) all wired-in things
-* The type environment itself contains no wired in things. The type
- checker sees if the Name is wired in before looking up the name in
- the type environment.
+* The type checker sees if the Name is wired in before looking up
+ the name in the type environment. So the type envt itself contains
+ no wired in things.
* MkIface prunes out wired-in things before putting them in an interface file.
So interface files never contain wired-in things.
-}
-
-knownKeyNames :: [Name]
--- This list is used to ensure that when you say "Prelude.map"
--- in your source code, or in an interface file,
--- you get a Name with the correct known key
--- (See Note [Known-key names] in PrelNames)
-knownKeyNames
- = concat [ tycon_kk_names funTyCon
- , concatMap tycon_kk_names primTyCons
-
- , concatMap tycon_kk_names wiredInTyCons
- -- Does not include tuples
-
- , concatMap tycon_kk_names typeNatTyCons
-
- , concatMap (rep_names . tupleTyCon Boxed) [2..mAX_TUPLE_SIZE] -- Yuk
-
- , cTupleTyConNames
- -- Constraint tuples are known-key but not wired-in
- -- They can't show up in source code, but can appear
- -- in intreface files
-
- , map idName wiredInIds
- , map (idName . primOpId) allThePrimOps
- , basicKnownKeyNames ]
+wiredInThings :: [TyThing]
+-- This list is used only to initialise HscMain.knownKeyNames
+-- to ensure that when you say "Prelude.map" in your source code, you
+-- get a Name with the correct known key (See Note [Known-key names])
+wiredInThings
+ = concat
+ [ -- Wired in TyCons and their implicit Ids
+ tycon_things
+ , concatMap implicitTyThings tycon_things
+
+ -- Wired in Ids
+ , map AnId wiredInIds
+
+ -- PrimOps
+ , map (AnId . primOpId) allThePrimOps
+ ]
where
- -- "kk" short for "known-key"
- tycon_kk_names :: TyCon -> [Name]
- tycon_kk_names tc = tyConName tc : (rep_names tc ++ concatMap thing_kk_names (implicitTyConThings tc))
-
- datacon_kk_names dc
- | Promoted tc <- promoteDataCon_maybe dc = dataConName dc : rep_names tc
- | otherwise = [dataConName dc]
-
- thing_kk_names :: TyThing -> [Name]
- thing_kk_names (ATyCon tc) = tycon_kk_names tc
- thing_kk_names (AConLike (RealDataCon dc)) = datacon_kk_names dc
- thing_kk_names thing = [getName thing]
-
- -- The TyConRepName for a known-key TyCon has a known key,
- -- but isn't itself an implicit thing. Yurgh.
- -- NB: if any of the wired-in TyCons had record fields, the record
- -- field names would be in a similar situation. Ditto class ops.
- -- But it happens that there aren't any
- rep_names tc = case tyConRepName_maybe tc of
- Just n -> [n]
- Nothing -> []
+ tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons
+ ++ typeNatTyCons)
{-
We let a lot of "non-standard" values be visible, so that we can make
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 05a38ffec9..30d11fef59 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -206,13 +206,11 @@ basicKnownKeyNames
-- Typeable
typeableClassName,
typeRepTyConName,
- trTyConDataConName,
- trModuleDataConName,
- trNameSDataConName,
- typeRepIdName,
+ mkTyConName,
mkPolyTyConAppName,
mkAppTyName,
- typeSymbolTypeRepName, typeNatTypeRepName,
+ typeNatTypeRepName,
+ typeSymbolTypeRepName,
-- Dynamic
toDynName,
@@ -228,6 +226,7 @@ basicKnownKeyNames
fromIntegralName, realToFracName,
-- String stuff
+ stringTyConName,
fromStringName,
-- Enum stuff
@@ -608,8 +607,7 @@ toInteger_RDR = nameRdrName toIntegerName
toRational_RDR = nameRdrName toRationalName
fromIntegral_RDR = nameRdrName fromIntegralName
-stringTy_RDR, fromString_RDR :: RdrName
-stringTy_RDR = tcQual_RDR gHC_BASE (fsLit "String")
+fromString_RDR :: RdrName
fromString_RDR = nameRdrName fromStringName
fromList_RDR, fromListN_RDR, toList_RDR :: RdrName
@@ -670,6 +668,11 @@ showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString")
showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace")
showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen")
+typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName
+typeRep_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeRep#")
+mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon")
+mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp")
+
undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
@@ -779,39 +782,6 @@ and it's convenient to write them all down in one place.
-- guys as well (perhaps) e.g. see trueDataConName below
-}
--- | Build a 'Name' for the 'Typeable' representation of the given special 'TyCon'.
--- Special 'TyCon's include @(->)@, @BOX@, @Constraint@, etc. See 'TysPrim'.
-mkSpecialTyConRepName :: FastString -> Name -> Name
--- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
-mkSpecialTyConRepName fs tc_name
- = mkExternalName (tyConRepNameUnique (nameUnique tc_name))
- tYPEABLE_INTERNAL
- (mkVarOccFS fs)
- wiredInSrcSpan
-
--- | Make a 'Name' for the 'Typeable' representation of the given wired-in type
-mkPrelTyConRepName :: Name -> Name
--- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
-mkPrelTyConRepName tc_name -- Prelude tc_name is always External,
- -- so nameModule will work
- = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)
- where
- name_occ = nameOccName tc_name
- name_mod = nameModule tc_name
- name_uniq = nameUnique tc_name
- rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq
- | otherwise = dataConRepNameUnique name_uniq
- (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ
-
--- | TODO
--- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable.
-tyConRepModOcc :: Module -> OccName -> (Module, OccName)
-tyConRepModOcc tc_module tc_occ
- | tc_module == gHC_TYPES
- = (tYPEABLE_INTERNAL, mkTyConRepUserOcc tc_occ)
- | otherwise
- = (tc_module, mkTyConRepSysOcc tc_occ)
-
wildCardName :: Name
wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
@@ -879,11 +849,12 @@ uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
- unpackCStringUtf8Name, eqStringName :: Name
+ unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey
+stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey
-- The 'inline' function
inlineIdName :: Name
@@ -1082,21 +1053,15 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey
-- Class Typeable, and functions for constructing `Typeable` dictionaries
typeableClassName
, typeRepTyConName
- , trTyConDataConName
- , trModuleDataConName
- , trNameSDataConName
+ , mkTyConName
, mkPolyTyConAppName
, mkAppTyName
- , typeRepIdName
, typeNatTypeRepName
, typeSymbolTypeRepName
:: Name
typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey
-trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey
-trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey
-trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey
-typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey
+mkTyConName = varQual tYPEABLE_INTERNAL (fsLit "mkTyCon") mkTyConKey
mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey
typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
@@ -1377,7 +1342,7 @@ ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44
---------------- Template Haskell -------------------
--- THNames.hs: USES ClassUniques 200-299
+-- USES ClassUniques 200-299
-----------------------------------------------------
{-
@@ -1524,6 +1489,9 @@ unknown2TyConKey = mkPreludeTyConUnique 131
unknown3TyConKey = mkPreludeTyConUnique 132
opaqueTyConKey = mkPreludeTyConUnique 133
+stringTyConKey :: Unique
+stringTyConKey = mkPreludeTyConUnique 134
+
-- Generics (Unique keys)
v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
@@ -1621,7 +1589,7 @@ ipCoNameKey = mkPreludeTyConUnique 185
---------------- Template Haskell -------------------
--- THNames.hs: USES TyConUniques 200-299
+-- USES TyConUniques 200-299
-----------------------------------------------------
----------------------- SIMD ------------------------
@@ -1700,16 +1668,6 @@ srcLocDataConKey = mkPreludeDataConUnique 37
ipDataConKey :: Unique
ipDataConKey = mkPreludeDataConUnique 38
-trTyConDataConKey, trModuleDataConKey, trNameSDataConKey :: Unique
-trTyConDataConKey = mkPreludeDataConUnique 40
-trModuleDataConKey = mkPreludeDataConUnique 41
-trNameSDataConKey = mkPreludeDataConUnique 42
-
----------------- Template Haskell -------------------
--- THNames.hs: USES DataUniques 100-150
------------------------------------------------------
-
-
{-
************************************************************************
* *
@@ -1964,7 +1922,7 @@ proxyHashKey :: Unique
proxyHashKey = mkPreludeMiscIdUnique 502
---------------- Template Haskell -------------------
--- THNames.hs: USES IdUniques 200-499
+-- USES IdUniques 200-499
-----------------------------------------------------
-- Used to make `Typeable` dictionaries
@@ -1973,21 +1931,19 @@ mkTyConKey
, mkAppTyKey
, typeNatTypeRepKey
, typeSymbolTypeRepKey
- , typeRepIdKey
:: Unique
mkTyConKey = mkPreludeMiscIdUnique 503
mkPolyTyConAppKey = mkPreludeMiscIdUnique 504
mkAppTyKey = mkPreludeMiscIdUnique 505
typeNatTypeRepKey = mkPreludeMiscIdUnique 506
typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507
-typeRepIdKey = mkPreludeMiscIdUnique 508
-- Dynamic
toDynIdKey :: Unique
-toDynIdKey = mkPreludeMiscIdUnique 509
+toDynIdKey = mkPreludeMiscIdUnique 508
bitIntegerIdKey :: Unique
-bitIntegerIdKey = mkPreludeMiscIdUnique 510
+bitIntegerIdKey = mkPreludeMiscIdUnique 509
{-
************************************************************************
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 571487a274..062f9577e7 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -448,6 +448,23 @@ unsafeName = libFun (fsLit "unsafe") unsafeIdKey
safeName = libFun (fsLit "safe") safeIdKey
interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
+-- data Inline = ...
+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
+noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
+inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
+
+-- data RuleMatch = ...
+conLikeDataConName, funLikeDataConName :: Name
+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
+
+-- data Phases = ...
+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
+allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
+fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
+
-- newtype TExp a = ...
tExpDataConName :: Name
tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
@@ -506,42 +523,12 @@ quotePatName = qqFun (fsLit "quotePat") quotePatKey
quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
--- data Inline = ...
-noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
-noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
-inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
-inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
-
--- data RuleMatch = ...
-conLikeDataConName, funLikeDataConName :: Name
-conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
-funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
-
--- data Phases = ...
-allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
-allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
-fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
-beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
-
-
-{- *********************************************************************
-* *
- Class keys
-* *
-********************************************************************* -}
-
-- ClassUniques available: 200-299
-- Check in PrelNames if you want to change this
liftClassKey :: Unique
liftClassKey = mkPreludeClassUnique 200
-{- *********************************************************************
-* *
- TyCon keys
-* *
-********************************************************************* -}
-
-- TyConUniques available: 200-299
-- Check in PrelNames if you want to change this
@@ -587,43 +574,6 @@ tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231
kindTyConKey = mkPreludeTyConUnique 232
-{- *********************************************************************
-* *
- DataCon keys
-* *
-********************************************************************* -}
-
--- DataConUniques available: 100-150
--- If you want to change this, make sure you check in PrelNames
-
--- data Inline = ...
-noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
-noInlineDataConKey = mkPreludeDataConUnique 100
-inlineDataConKey = mkPreludeDataConUnique 101
-inlinableDataConKey = mkPreludeDataConUnique 102
-
--- data RuleMatch = ...
-conLikeDataConKey, funLikeDataConKey :: Unique
-conLikeDataConKey = mkPreludeDataConUnique 103
-funLikeDataConKey = mkPreludeDataConUnique 104
-
--- data Phases = ...
-allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
-allPhasesDataConKey = mkPreludeDataConUnique 105
-fromPhaseDataConKey = mkPreludeDataConUnique 106
-beforePhaseDataConKey = mkPreludeDataConUnique 107
-
--- newtype TExp a = ...
-tExpDataConKey :: Unique
-tExpDataConKey = mkPreludeDataConUnique 108
-
-
-{- *********************************************************************
-* *
- Id keys
-* *
-********************************************************************* -}
-
-- IdUniques available: 200-499
-- If you want to change this, make sure you check in PrelNames
@@ -893,6 +843,27 @@ unsafeIdKey = mkPreludeMiscIdUnique 430
safeIdKey = mkPreludeMiscIdUnique 431
interruptibleIdKey = mkPreludeMiscIdUnique 432
+-- data Inline = ...
+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
+noInlineDataConKey = mkPreludeDataConUnique 40
+inlineDataConKey = mkPreludeDataConUnique 41
+inlinableDataConKey = mkPreludeDataConUnique 42
+
+-- data RuleMatch = ...
+conLikeDataConKey, funLikeDataConKey :: Unique
+conLikeDataConKey = mkPreludeDataConUnique 43
+funLikeDataConKey = mkPreludeDataConUnique 44
+
+-- data Phases = ...
+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
+allPhasesDataConKey = mkPreludeDataConUnique 45
+fromPhaseDataConKey = mkPreludeDataConUnique 46
+beforePhaseDataConKey = mkPreludeDataConUnique 47
+
+-- newtype TExp a = ...
+tExpDataConKey :: Unique
+tExpDataConKey = mkPreludeDataConUnique 48
+
-- data FunDep = ...
funDepIdKey :: Unique
funDepIdKey = mkPreludeMiscIdUnique 440
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 3a6dd0341e..d66b48e3b7 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -10,8 +10,6 @@
-- | This module defines TyCons that can't be expressed in Haskell.
-- They are all, therefore, wired-in TyCons. C.f module TysWiredIn
module TysPrim(
- mkPrimTyConName, -- For implicit parameters in TysWiredIn only
-
mkTemplateTyVars,
alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
alphaTy, betaTy, gammaTy, deltaTy,
@@ -83,11 +81,12 @@ module TysPrim(
#include "HsVersions.h"
import Var ( TyVar, KindVar, mkTyVar )
-import Name
+import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
+import OccName ( mkTyVarOccFS, mkTcOccFS )
import TyCon
import TypeRep
import SrcLoc
-import Unique
+import Unique ( mkAlphaTyVarUnique )
import PrelNames
import FastString
@@ -259,9 +258,8 @@ funTyConName :: Name
funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
funTyCon :: TyCon
-funTyCon = mkFunTyCon funTyConName kind tc_rep_nm
- where
- kind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
+funTyCon = mkFunTyCon funTyConName $
+ mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
-- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-- But if we do that we get kind errors when saying
-- instance Control.Arrow (->)
@@ -271,8 +269,6 @@ funTyCon = mkFunTyCon funTyConName kind tc_rep_nm
-- a prefix way, thus: (->) Int# Int#. And this is unusual.
-- because they are never in scope in the source
- tc_rep_nm = mkSpecialTyConRepName (fsLit "tcFun") funTyConName
-
-- One step to remove subkinding.
-- (->) :: * -> * -> *
-- but we should have (and want) the following typing rule for fully applied arrows
@@ -322,21 +318,14 @@ superKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
constraintKindTyConName
:: Name
-mk_kind_tycon :: Name -- ^ Name of the kind constructor, e.g. @*@
- -> FastString -- ^ Name of the 'TyConRepName' function,
- -- e.g. @tcLiftedKind :: TyCon@
- -> TyCon -- ^ The kind constructor
-mk_kind_tycon tc_name rep_fs
- = mkKindTyCon tc_name superKind (mkSpecialTyConRepName rep_fs tc_name)
-
-superKindTyCon = mk_kind_tycon superKindTyConName (fsLit "tcBOX")
- -- See Note [SuperKind (BOX)]
+superKindTyCon = mkKindTyCon superKindTyConName superKind
+ -- See Note [SuperKind (BOX)]
-anyKindTyCon = mk_kind_tycon anyKindTyConName (fsLit "tcAnyK")
-constraintKindTyCon = mk_kind_tycon constraintKindTyConName (fsLit "tcConstraint")
-liftedTypeKindTyCon = mk_kind_tycon liftedTypeKindTyConName (fsLit "tcLiftedKind")
-openTypeKindTyCon = mk_kind_tycon openTypeKindTyConName (fsLit "tcOpenKind")
-unliftedTypeKindTyCon = mk_kind_tycon unliftedTypeKindTyConName (fsLit "tcUnliftedKind")
+anyKindTyCon = mkKindTyCon anyKindTyConName superKind
+liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind
+openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind
+unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind
+constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind
--------------------------
-- ... and now their names
@@ -747,7 +736,6 @@ variables with no constraints on them. It appears in similar circumstances to
Any, but at the kind level. For example:
type family Length (l :: [k]) :: Nat
- type instance Length [] = Zero
f :: Proxy (Length []) -> Int
f = ....
@@ -788,7 +776,7 @@ anyTy = mkTyConTy anyTyCon
anyTyCon :: TyCon
anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing
(ClosedSynFamilyTyCon Nothing)
- Nothing
+ NoParentTyCon
NotInjective
where
kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 067700f120..e8a06e7ad4 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -99,7 +99,6 @@ import TysPrim
-- others:
import CoAxiom
import Coercion
-import Id
import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
import Module ( Module )
import Type ( mkTyConApp )
@@ -290,7 +289,7 @@ pcTyCon is_enum is_rec is_prom name cType tyvars cons
is_rec
is_prom
False -- Not in GADT syntax
- (VanillaAlgTyCon (mkPrelTyConRepName name))
+ NoParentTyCon
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon = pcDataConWithFixity False
@@ -311,7 +310,7 @@ pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon ->
pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
= data_con
where
- data_con = mkDataCon dc_name declared_infix prom_info
+ data_con = mkDataCon dc_name declared_infix
(map (const no_bang) arg_tys)
[] -- No labelled fields
tyvars
@@ -328,16 +327,10 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
modu = ASSERT( isExternalName dc_name )
nameModule dc_name
- dc_occ = nameOccName dc_name
- wrk_occ = mkDataConWorkerOcc dc_occ
+ wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)
wrk_name = mkWiredInName modu wrk_occ wrk_key
(AnId (dataConWorkId data_con)) UserSyntax
- prom_info | Promoted {} <- promotableTyCon_maybe tycon -- Knot-tied
- = Promoted (mkPrelTyConRepName dc_name)
- | otherwise
- = NotPromoted
-
{-
************************************************************************
* *
@@ -505,19 +498,15 @@ mk_tuple boxity arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con
tup_sort
- prom_tc flavour
-
- flavour = case boxity of
- Boxed -> VanillaAlgTyCon (mkPrelTyConRepName tc_name)
- Unboxed -> UnboxedAlgTyCon
+ prom_tc NoParentTyCon
tup_sort = case boxity of
Boxed -> BoxedTuple
Unboxed -> UnboxedTuple
prom_tc = case boxity of
- Boxed -> Promoted (mkPromotedTyCon tycon (promoteKind tc_kind))
- Unboxed -> NotPromoted
+ Boxed -> Just (mkPromotedTyCon tycon (promoteKind tc_kind))
+ Unboxed -> Nothing
modu = case boxity of
Boxed -> gHC_TUPLE
@@ -743,11 +732,8 @@ mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
listTyCon :: TyCon
-listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational]
- Nothing []
- (DataTyCon [nilDataCon, consDataCon] False )
- Recursive True False
- (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcList") listTyConName))
+listTyCon = pcTyCon False Recursive True
+ listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon]
mkPromotedListTy :: Type -> Type
mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty]
@@ -944,10 +930,10 @@ eqTyCon = mkAlgTyCon eqTyConName
Nothing
[] -- No stupid theta
(DataTyCon [eqBoxDataCon] False)
- (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcEq") eqTyConName))
+ NoParentTyCon
NonRecursive
False
- NotPromoted
+ Nothing -- No parent for constraint-kinded types
where
kv = kKiVar
k = mkTyVarTy kv
@@ -963,17 +949,15 @@ eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVa
coercibleTyCon :: TyCon
-coercibleTyCon = mkClassTyCon coercibleTyConName kind tvs
- [Nominal, Representational, Representational]
- rhs coercibleClass NonRecursive
- (mkPrelTyConRepName coercibleTyConName)
- where
- kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
- kv = kKiVar
- k = mkTyVarTy kv
- [a,b] = mkTemplateTyVars [k,k]
- tvs = [kv, a, b]
- rhs = DataTyCon [coercibleDataCon] False
+coercibleTyCon = mkClassTyCon
+ coercibleTyConName kind tvs [Nominal, Representational, Representational]
+ rhs coercibleClass NonRecursive
+ where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind)
+ kv = kKiVar
+ k = mkTyVarTy kv
+ [a,b] = mkTemplateTyVars [k,k]
+ tvs = [kv, a, b]
+ rhs = DataTyCon [coercibleDataCon] False
coercibleDataCon :: DataCon
coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon (map mkTyVarTy args)] coercibleTyCon
@@ -1010,7 +994,6 @@ ipCoName = mkWiredInCoAxiomName BuiltInSyntax gHC_CLASSES (fsLit "NTCo:IP")
-- See Note [The Implicit Parameter class]
ipTyCon :: TyCon
ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive
- (mkPrelTyConRepName ipTyConName)
where
kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind
[ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind]
diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs
index 412125ae3e..5390c48dd3 100644
--- a/compiler/simplCore/FloatIn.hs
+++ b/compiler/simplCore/FloatIn.hs
@@ -25,7 +25,7 @@ import CoreUtils ( exprIsDupable, exprIsExpandable, exprType,
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
import Id ( isOneShotBndr, idType )
import Var
-import Type ( Type, isUnLiftedType, isFunTy, splitFunTy, applyTy )
+import Type ( Type, isUnLiftedType, splitFunTy, applyTy )
import VarSet
import Util
import UniqFM
@@ -168,7 +168,7 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
= ((applyTy fun_ty ty, extra_fvs), emptyVarSet)
mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg)
- | ASSERT( isFunTy fun_ty ) noFloatIntoRhs ann_arg arg_ty
+ | noFloatIntoRhs ann_arg arg_ty
= ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet)
| otherwise
= ((res_ty, extra_fvs), arg_fvs)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index d8c0350096..217739201b 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -8,9 +8,9 @@
{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
- tcValBinds, tcHsBootSigs, tcPolyCheck,
+ tcHsBootSigs, tcPolyCheck,
tcSpecPrags, tcSpecWrapper,
- tcVectDecls, addTypecheckedBinds,
+ tcVectDecls,
TcSigInfo(..), TcSigFun,
TcPragEnv, mkPragEnv,
instTcTySig, instTcTySigFromId, findScopedTyVars,
@@ -66,21 +66,6 @@ import Data.List (partition)
#include "HsVersions.h"
-{- *********************************************************************
-* *
- A useful helper function
-* *
-********************************************************************* -}
-
-addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv
-addTypecheckedBinds tcg_env binds
- | isHsBoot (tcg_src tcg_env) = tcg_env
- -- Do not add the code for record-selector bindings
- -- when compiling hs-boot files
- | otherwise = tcg_env { tcg_binds = foldr unionBags
- (tcg_binds tcg_env)
- binds }
-
{-
************************************************************************
* *
@@ -184,8 +169,10 @@ tcTopBinds (ValBindsOut binds sigs)
; return (gbl, lcl) }
; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
- ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env }
- `addTypecheckedBinds` map snd binds' }
+ ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd)
+ (tcg_binds tcg_env)
+ binds'
+ , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } }
; return (tcg_env', tcl_env) }
-- The top level bindings are flattened into a giant
@@ -195,17 +182,15 @@ tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
tcRecSelBinds (ValBindsOut binds sigs)
- = -- tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
- -- this envt extension happens in tcValBinds
- do { (rec_sel_binds, tcg_env) <- discardWarnings $
- tcValBinds TopLevel binds sigs getGblEnv
+ = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
+ do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
; let tcg_env'
| isHsBoot (tcg_src tcg_env) = tcg_env
| otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
(tcg_binds tcg_env)
rec_sel_binds }
- -- Do not add the code for record-selector bindings
- -- when compiling hs-boot files
+ -- Do not add the code for record-selector bindings when
+ -- compiling hs-boot files
; return tcg_env' }
tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 3bb2703104..5d1c1be3ad 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -631,12 +631,13 @@ tcGetDefaultTys
-- No use-supplied default
-- Use [Integer, Double], plus modifications
{ integer_ty <- tcMetaTy integerTyConName
- ; list_ty <- tcMetaTy listTyConName
; checkWiredInTyCon doubleTyCon
+ ; string_ty <- tcMetaTy stringTyConName
+ ; list_ty <- tcMetaTy listTyConName
; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
-- Note [Extended defaults]
++ [integer_ty, doubleTy]
- ++ opt_deflt ovl_strings [stringTy]
+ ++ opt_deflt ovl_strings [string_ty]
; return (deflt_tys, flags) } } }
where
opt_deflt True xs = xs
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 1cfa351125..83bbcca1b7 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -730,27 +730,24 @@ data EvTerm
| EvLit EvLit -- Dictionary for KnownNat and KnownSymbol classes.
-- Note [KnownNat & KnownSymbol and EvLit]
- | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters
+ | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters
- | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty)
+ | EvTypeable EvTypeable -- Dictionary for `Typeable`
deriving( Data.Data, Data.Typeable )
-- | Instructions on how to make a 'Typeable' dictionary.
--- See Note [Typeable evidence terms]
data EvTypeable
- = EvTypeableTyCon -- ^ Dictionary for @Typeable (T k1..kn)@
+ = EvTypeableTyCon TyCon [Kind]
+ -- ^ Dictionary for concrete type constructors.
- | EvTypeableTyApp EvTerm EvTerm
- -- ^ Dictionary for @Typeable (s t)@,
- -- given a dictionaries for @s@ and @t@
+ | EvTypeableTyApp (EvTerm,Type) (EvTerm,Type)
+ -- ^ Dictionary for type applications; this is used when we have
+ -- a type expression starting with a type variable (e.g., @Typeable (f a)@)
- | EvTypeableTyLit EvTerm
- -- ^ Dictionary for a type literal,
- -- e.g. @Typeable "foo"@ or @Typeable 3@
- -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@
- -- (see Trac #10348)
+ | EvTypeableTyLit (EvTerm,Type)
+ -- ^ Dictionary for a type literal.
deriving ( Data.Data, Data.Typeable )
@@ -772,20 +769,6 @@ data EvCallStack
deriving( Data.Data, Data.Typeable )
{-
-Note [Typeable evidence terms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The EvTypeable data type looks isomorphic to Type, but the EvTerms
-inside can be EvIds. Eg
- f :: forall a. Typeable a => a -> TypeRep
- f x = typeRep (undefined :: Proxy [a])
-Here for the (Typeable [a]) dictionary passed to typeRep we make
-evidence
- dl :: Typeable [a] = EvTypeable [a]
- (EvTypeableTyApp EvTypeableTyCon (EvId d))
-where
- d :: Typable a
-is the lambda-bound dictionary passed into f.
-
Note [Coercion evidence terms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A "coercion evidence term" takes one of these forms
@@ -1026,7 +1009,7 @@ evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo c
evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
evVarsOfTerm (EvLit _) = emptyVarSet
evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs
-evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev
+evVarsOfTerm (EvTypeable ev) = evVarsOfTypeable ev
evVarsOfTerms :: [EvTerm] -> VarSet
evVarsOfTerms = mapUnionVarSet evVarsOfTerm
@@ -1040,9 +1023,9 @@ evVarsOfCallStack cs = case cs of
evVarsOfTypeable :: EvTypeable -> VarSet
evVarsOfTypeable ev =
case ev of
- EvTypeableTyCon -> emptyVarSet
- EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2]
- EvTypeableTyLit e -> evVarsOfTerm e
+ EvTypeableTyCon _ _ -> emptyVarSet
+ EvTypeableTyApp e1 e2 -> evVarsOfTerms (map fst [e1,e2])
+ EvTypeableTyLit e -> evVarsOfTerm (fst e)
{-
************************************************************************
@@ -1099,16 +1082,16 @@ instance Outputable EvBind where
-- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
instance Outputable EvTerm where
- ppr (EvId v) = ppr v
- ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
- ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
- ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
- ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
- ppr (EvLit l) = ppr l
- ppr (EvCallStack cs) = ppr cs
- ppr (EvDelayedError ty msg) = ptext (sLit "error")
+ ppr (EvId v) = ppr v
+ ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
+ ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
+ ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
+ ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
+ ppr (EvLit l) = ppr l
+ ppr (EvCallStack cs) = ppr cs
+ ppr (EvDelayedError ty msg) = ptext (sLit "error")
<+> sep [ char '@' <> ppr ty, ppr msg ]
- ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> ptext (sLit "Typeable") <+> ppr ty
+ ppr (EvTypeable ev) = ppr ev
instance Outputable EvLit where
ppr (EvNum n) = integer n
@@ -1123,9 +1106,11 @@ instance Outputable EvCallStack where
= angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm
instance Outputable EvTypeable where
- ppr EvTypeableTyCon = ptext (sLit "TC")
- ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2)
- ppr (EvTypeableTyLit t1) = ptext (sLit "TyLit") <> ppr t1
+ ppr ev =
+ case ev of
+ EvTypeableTyCon tc ks -> parens (ppr tc <+> sep (map ppr ks))
+ EvTypeableTyApp t1 t2 -> parens (ppr (fst t1) <+> ppr (fst t2))
+ EvTypeableTyLit x -> ppr (fst x)
----------------------------------------------------------------------
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 9a1c506b33..f69c137762 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -73,23 +73,23 @@ gen_Generic_binds gk tc metaTyCons mod = do
genGenericMetaTyCons :: TyCon -> TcM (MetaTyCons, BagDerivStuff)
genGenericMetaTyCons tc =
- do let tc_name = tyConName tc
- ty_rep_name <- newTyConRepName tc_name
- let mod = nameModule tc_name
- tc_cons = tyConDataCons tc
- tc_arits = map dataConSourceArity tc_cons
-
- tc_occ = nameOccName tc_name
- d_occ = mkGenD mod tc_occ
- c_occ m = mkGenC mod tc_occ m
- s_occ m n = mkGenS mod tc_occ m n
-
- mkTyCon name = ASSERT( isExternalName name )
- buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
- NonRecursive
- False -- Not promotable
- False -- Not GADT syntax
- (VanillaAlgTyCon ty_rep_name)
+ do let
+ tc_name = tyConName tc
+ mod = nameModule tc_name
+ tc_cons = tyConDataCons tc
+ tc_arits = map dataConSourceArity tc_cons
+
+ tc_occ = nameOccName tc_name
+ d_occ = mkGenD mod tc_occ
+ c_occ m = mkGenC mod tc_occ m
+ s_occ m n = mkGenS mod tc_occ m n
+
+ mkTyCon name = ASSERT( isExternalName name )
+ buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
+ NonRecursive
+ False -- Not promotable
+ False -- Not GADT syntax
+ NoParentTyCon
loc <- getSrcSpanM
-- we generate new names in current module
@@ -265,9 +265,10 @@ canDoGenerics tc tc_args
where
-- The tc can be a representation tycon. When we want to display it to the
-- user (in an error message) we should print its parent
- (tc_name, tc_tys) = case tyConFamInst_maybe tc of
- Just (ptc, tys) -> (ppr ptc, hsep (map ppr (tys ++ drop (length tys) tc_args)))
- _ -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
+ (tc_name, tc_tys) = case tyConParent tc of
+ FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr
+ (tys ++ drop (length tys) tc_args)))
+ _ -> (ppr tc, hsep (map ppr (tyConTyVars tc)))
-- Check (d) from Note [Requirements for deriving Generic and Rep].
--
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index ddf9c4ff36..5aa797c4c2 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1282,10 +1282,19 @@ zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm
; return (mkEvCast tm' co') }
zonkEvTerm _ (EvLit l) = return (EvLit l)
-zonkEvTerm env (EvTypeable ty ev) =
- do { ev' <- zonkEvTypeable env ev
- ; ty' <- zonkTcTypeToType env ty
- ; return (EvTypeable ty' ev') }
+zonkEvTerm env (EvTypeable ev) =
+ fmap EvTypeable $
+ case ev of
+ EvTypeableTyCon tc ks -> return (EvTypeableTyCon tc ks)
+ EvTypeableTyApp t1 t2 -> do e1 <- zonk t1
+ e2 <- zonk t2
+ return (EvTypeableTyApp e1 e2)
+ EvTypeableTyLit t -> EvTypeableTyLit `fmap` zonk t
+ where
+ zonk (ev,t) = do ev' <- zonkEvTerm env ev
+ t' <- zonkTcTypeToType env t
+ return (ev',t')
+
zonkEvTerm env (EvCallStack cs)
= case cs of
EvCsEmpty -> return (EvCallStack cs)
@@ -1303,16 +1312,6 @@ zonkEvTerm env (EvDelayedError ty msg)
= do { ty' <- zonkTcTypeToType env ty
; return (EvDelayedError ty' msg) }
-zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
-zonkEvTypeable _ EvTypeableTyCon
- = return EvTypeableTyCon
-zonkEvTypeable env (EvTypeableTyApp t1 t2)
- = do { t1' <- zonkEvTerm env t1
- ; t2' <- zonkEvTerm env t2
- ; return (EvTypeableTyApp t1' t2') }
-zonkEvTypeable _ (EvTypeableTyLit t1)
- = return (EvTypeableTyLit t1)
-
zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
; return (env, [EvBinds (unionManyBags bs')]) }
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 191756ac7a..2f427916b4 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -659,7 +659,7 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon
AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc)
AGlobal (AConLike (RealDataCon dc))
- | Promoted tc <- promoteDataCon_maybe dc
+ | Just tc <- promoteDataCon_maybe dc
-> do { data_kinds <- xoptM Opt_DataKinds
; unless data_kinds $ promotionErr name NoDataKinds
; inst_tycon (mkTyConApp tc) (tyConKind tc) }
@@ -1619,10 +1619,10 @@ tc_kind_var_app name arg_kis
-> do { data_kinds <- xoptM Opt_DataKinds
; unless data_kinds $ addErr (dataKindsErr name)
; case promotableTyCon_maybe tc of
- Promoted prom_tc | arg_kis `lengthIs` tyConArity prom_tc
+ Just prom_tc | arg_kis `lengthIs` tyConArity prom_tc
-> return (mkTyConApp prom_tc arg_kis)
- Promoted _ -> tycon_err tc "is not fully applied"
- NotPromoted -> tycon_err tc "is not promotable" }
+ Just _ -> tycon_err tc "is not fully applied"
+ Nothing -> tycon_err tc "is not promotable" }
-- A lexically scoped kind variable
ATyVar _ kind_var
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index ef0c4b6c8f..c97e4e128c 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -434,7 +434,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
ptext (sLit "Replace the following instance:"))
2 (pprInstanceHdr (iSpec i))
- -- Report an error or a warning for a Typeable instances.
+ -- Report an error or a warning for a `Typeable` instances.
-- If we are working on an .hs-boot file, we just report a warning,
-- and ignore the instance. We do this, to give users a chance to fix
-- their code.
@@ -445,13 +445,10 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
then
do warn <- woptM Opt_WarnDerivingTypeable
when warn $ addWarnTc $ vcat
- [ ppTypeable <+> ptext (sLit "instances in .hs-boot files are ignored")
- , ptext (sLit "This warning will become an error in future versions of the compiler")
+ [ ptext (sLit "`Typeable` instances in .hs-boot files are ignored.")
+ , ptext (sLit "This warning will become an error in future versions of the compiler.")
]
- else addErrTc $ ptext (sLit "Class") <+> ppTypeable
- <+> ptext (sLit "does not support user-specified instances")
- ppTypeable :: SDoc
- ppTypeable = quotes (ppr typeableClassName)
+ else addErrTc $ ptext (sLit "Class `Typeable` does not support user-specified instances.")
addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
addClsInsts infos thing_inside
@@ -636,7 +633,7 @@ tcDataFamInstDecl mb_clsinfo
-- Check that the family declaration is for the right kind
; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
- ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+ ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
-- Kind check type patterns
; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats
@@ -662,9 +659,7 @@ tcDataFamInstDecl mb_clsinfo
; let orig_res_ty = mkTyConApp fam_tc pats'
; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
- do { data_cons <- tcConDecls new_or_data
- False -- Not promotable
- rec_rep_tc
+ do { data_cons <- tcConDecls new_or_data rec_rep_tc
(tvs', orig_res_ty) cons
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
@@ -675,7 +670,7 @@ tcDataFamInstDecl mb_clsinfo
axiom = mkSingleCoAxiom Representational
axiom_name eta_tvs fam_tc eta_pats
(mkTyConApp rep_tc (mkTyVarTys eta_tvs))
- parent = DataFamInstTyCon axiom fam_tc pats'
+ parent = FamInstTyCon axiom fam_tc pats'
roles = map (const Nominal) tvs'
-- NB: Use the tvs' from the pats. See bullet toward
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 47147d7a4d..49a5d4cc09 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -16,11 +16,10 @@ import VarSet
import Type
import Kind ( isKind )
import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
-import CoAxiom( sfInteractTop, sfInteractInert )
+import CoAxiom(sfInteractTop, sfInteractInert)
import Var
import TcType
-import Name
import PrelNames ( knownNatClassName, knownSymbolClassName,
callStackTyConKey, typeableClassName )
import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind )
@@ -744,11 +743,11 @@ addFunDepWork inerts work_ev cls
inert_pred inert_loc }
{-
-**********************************************************************
-* *
+*********************************************************************************
+* *
Implicit parameters
-* *
-**********************************************************************
+* *
+*********************************************************************************
-}
interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
@@ -771,26 +770,6 @@ interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
--- | Is the constraint for an implicit CallStack parameter?
--- i.e. (IP "name" CallStack)
-isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack)
-isCallStackIP loc cls tys
- | cls == ipClass
- , [_ip_name, ty] <- tys
- , Just (tc, _) <- splitTyConApp_maybe ty
- , tc `hasKey` callStackTyConKey
- = occOrigin (ctLocOrigin loc)
- | otherwise
- = Nothing
- where
- locSpan = ctLocSpan loc
-
- -- We only want to grab constraints that arose due to the use of an IP or a
- -- function call. See Note [Overview of implicit CallStacks]
- occOrigin (OccurrenceOf n) = Just (EvCsPushCall n locSpan)
- occOrigin (IPOccOrigin n) = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan)
- occOrigin _ = Nothing
-
{-
Note [Shadowing of Implicit Parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -842,11 +821,11 @@ I can think of two ways to fix this:
error if we get multiple givens for the same implicit parameter.
-**********************************************************************
-* *
+*********************************************************************************
+* *
interactFunEq
-* *
-**********************************************************************
+* *
+*********************************************************************************
-}
interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
@@ -1077,11 +1056,11 @@ The second is the right thing to do. Hence the isMetaTyVarTy
test when solving pairwise CFunEqCan.
-**********************************************************************
-* *
+*********************************************************************************
+* *
interactTyVarEq
-* *
-**********************************************************************
+* *
+*********************************************************************************
-}
interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
@@ -1254,11 +1233,11 @@ emitFunDepDeriveds fd_eqns
Pair (Type.substTy subst ty1) (Type.substTy subst ty2)
{-
-**********************************************************************
-* *
+*********************************************************************************
+* *
The top-reaction Stage
-* *
-**********************************************************************
+* *
+*********************************************************************************
-}
topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
@@ -1737,12 +1716,6 @@ So the inner binding for ?x::Bool *overrides* the outer one.
Hence a work-item Given overrides an inert-item Given.
-}
-{- *******************************************************************
-* *
- Class lookup
-* *
-**********************************************************************-}
-
-- | Indicates if Instance met the Safe Haskell overlapping instances safety
-- check.
--
@@ -1760,36 +1733,116 @@ instance Outputable LookupInstResult where
where ss = text $ if s then "[safe]" else "[unsafe]"
-matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
+matchClassInst, match_class_inst
+ :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
+
matchClassInst dflags inerts clas tys loc
+ = do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr (mkClassPred clas tys) ]
+ ; res <- match_class_inst dflags inerts clas tys loc
+ ; traceTcS "matchClassInst result" $ ppr res
+ ; return res }
+
-- First check whether there is an in-scope Given that could
-- match this constraint. In that case, do not use top-level
-- instances. See Note [Instance and Given overlap]
+match_class_inst dflags inerts clas tys loc
| not (xopt Opt_IncoherentInstances dflags)
, let matchable_givens = matchableGivens loc pred inerts
, not (isEmptyBag matchable_givens)
= do { traceTcS "Delaying instance application" $
- vcat [ text "Work item=" <+> pprClassPred clas tys
+ vcat [ text "Work item=" <+> pprType pred
, text "Potential matching givens:" <+> ppr matchable_givens ]
; return NoInstance }
where
pred = mkClassPred clas tys
-matchClassInst dflags _ clas tys loc
- = do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr (mkClassPred clas tys) ]
- ; res <- match_class_inst dflags clas tys loc
- ; traceTcS "matchClassInst result" $ ppr res
- ; return res }
+match_class_inst _ _ clas [ ty ] _
+ | className clas == knownNatClassName
+ , Just n <- isNumLitTy ty = makeDict (EvNum n)
+
+ | className clas == knownSymbolClassName
+ , Just s <- isStrLitTy ty = makeDict (EvStr s)
-match_class_inst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
-match_class_inst dflags clas tys loc
- | cls_name == knownNatClassName = matchKnownNat clas tys
- | cls_name == knownSymbolClassName = matchKnownSymbol clas tys
- | isCTupleClass clas = matchCTuple clas tys
- | cls_name == typeableClassName = matchTypeable clas tys
- | otherwise = matchInstEnv dflags clas tys loc
where
- cls_name = className clas
+ {- This adds a coercion that will convert the literal into a dictionary
+ of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit]
+ in TcEvidence. The coercion happens in 2 steps:
+
+ Integer -> SNat n -- representation of literal to singleton
+ SNat n -> KnownNat n -- singleton to dictionary
+
+ The process is mirrored for Symbols:
+ String -> SSymbol n
+ SSymbol n -> KnownSymbol n
+ -}
+ makeDict evLit
+ | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
+ -- co_dict :: KnownNat n ~ SNat n
+ , [ meth ] <- classMethods clas
+ , Just tcRep <- tyConAppTyCon_maybe -- SNat
+ $ funResultTy -- SNat n
+ $ dropForAlls -- KnownNat n => SNat n
+ $ idType meth -- forall n. KnownNat n => SNat n
+ , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
+ -- SNat n ~ Integer
+ , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))
+ = return $ GenInst [] (\_ -> ev_tm) True
+
+ | otherwise
+ = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
+ $$ vcat (map (ppr . idType) (classMethods clas)))
+
+match_class_inst _ _ clas ts _
+ | isCTupleClass clas
+ , let data_con = tyConSingleDataCon (classTyCon clas)
+ tuple_ev = EvDFunApp (dataConWrapId data_con) ts
+ = return (GenInst ts tuple_ev True)
+ -- The dfun is the data constructor!
+
+match_class_inst _ _ clas [k,t] _
+ | className clas == typeableClassName
+ = matchTypeableClass clas k t
+
+match_class_inst dflags _ clas tys loc
+ = do { instEnvs <- getInstEnvs
+ ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
+ (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
+ safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
+ ; case (matches, unify, safeHaskFail) of
+
+ -- Nothing matches
+ ([], _, _)
+ -> do { traceTcS "matchClass not matching" $
+ vcat [ text "dict" <+> ppr pred ]
+ ; return NoInstance }
+
+ -- A single match (& no safe haskell failure)
+ ([(ispec, inst_tys)], [], False)
+ -> do { let dfun_id = instanceDFunId ispec
+ ; traceTcS "matchClass success" $
+ vcat [text "dict" <+> ppr pred,
+ text "witness" <+> ppr dfun_id
+ <+> ppr (idType dfun_id) ]
+ -- Record that this dfun is needed
+ ; match_one (null unsafeOverlaps) dfun_id inst_tys }
+
+ -- More than one matches (or Safe Haskell fail!). Defer any
+ -- reactions of a multitude until we learn more about the reagent
+ (matches, _, _)
+ -> do { traceTcS "matchClass multiple matches, deferring choice" $
+ vcat [text "dict" <+> ppr pred,
+ text "matches" <+> ppr matches]
+ ; return NoInstance } }
+ where
+ pred = mkClassPred clas tys
+
+ match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult
+ -- See Note [DFunInstType: instantiating types] in InstEnv
+ match_one so dfun_id mb_inst_tys
+ = do { checkWellStagedDFun pred dfun_id loc
+ ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
+ ; return $ GenInst theta (EvDFunApp dfun_id tys) so }
+
{- Note [Instance and Given overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1854,202 +1907,89 @@ Other notes:
constraint solving.
-}
+-- | Is the constraint for an implicit CallStack parameter?
+-- i.e. (IP "name" CallStack)
+isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack)
+isCallStackIP loc cls tys
+ | cls == ipClass
+ , [_ip_name, ty] <- tys
+ , Just (tc, _) <- splitTyConApp_maybe ty
+ , tc `hasKey` callStackTyConKey
+ = occOrigin (ctLocOrigin loc)
+ | otherwise
+ = Nothing
+ where
+ locSpan = ctLocSpan loc
-{- *******************************************************************
-* *
- Class lookup in the instance environment
-* *
-**********************************************************************-}
-
-matchInstEnv :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
-matchInstEnv dflags clas tys loc
- = do { instEnvs <- getInstEnvs
- ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
- (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
- safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
- ; case (matches, unify, safeHaskFail) of
+ -- We only want to grab constraints that arose due to the use of an IP or a
+ -- function call. See Note [Overview of implicit CallStacks]
+ occOrigin (OccurrenceOf n) = Just (EvCsPushCall n locSpan)
+ occOrigin (IPOccOrigin n) = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan)
+ occOrigin _ = Nothing
- -- Nothing matches
- ([], _, _)
- -> do { traceTcS "matchClass not matching" $
- vcat [ text "dict" <+> ppr pred ]
- ; return NoInstance }
+-- | Assumes that we've checked that this is the 'Typeable' class,
+-- and it was applied to the correct argument.
+matchTypeableClass :: Class -> Kind -> Type -> TcS LookupInstResult
+matchTypeableClass clas k t
- -- A single match (& no safe haskell failure)
- ([(ispec, inst_tys)], [], False)
- -> do { let dfun_id = instanceDFunId ispec
- ; traceTcS "matchClass success" $
- vcat [text "dict" <+> ppr pred,
- text "witness" <+> ppr dfun_id
- <+> ppr (idType dfun_id) ]
- -- Record that this dfun is needed
- ; match_one (null unsafeOverlaps) dfun_id inst_tys }
+ -- See Note [No Typeable for qualified types]
+ | isForAllTy t = return NoInstance
- -- More than one matches (or Safe Haskell fail!). Defer any
- -- reactions of a multitude until we learn more about the reagent
- (matches, _, _)
- -> do { traceTcS "matchClass multiple matches, deferring choice" $
- vcat [text "dict" <+> ppr pred,
- text "matches" <+> ppr matches]
- ; return NoInstance } }
- where
- pred = mkClassPred clas tys
+ -- Is the type of the form `C => t`?
+ | isJust (tcSplitPredFunTy_maybe t) = return NoInstance
- match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult
- -- See Note [DFunInstType: instantiating types] in InstEnv
- match_one so dfun_id mb_inst_tys
- = do { checkWellStagedDFun pred dfun_id loc
- ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
- ; return $ GenInst theta (EvDFunApp dfun_id tys) so }
+ | eqType k typeNatKind = doTyLit knownNatClassName
+ | eqType k typeSymbolKind = doTyLit knownSymbolClassName
+ | Just (tc, ks) <- splitTyConApp_maybe t
+ , all isKind ks = doTyCon tc ks
-{- ********************************************************************
-* *
- Class lookup for CTuples
-* *
-***********************************************************************-}
+ | Just (f,kt) <- splitAppTy_maybe t = doTyApp f kt
+ | otherwise = return NoInstance
-matchCTuple :: Class -> [Type] -> TcS LookupInstResult
-matchCTuple clas tys -- (isCTupleClass clas) holds
- = return (GenInst tys tuple_ev True)
- -- The dfun *is* the data constructor!
where
- data_con = tyConSingleDataCon (classTyCon clas)
- tuple_ev = EvDFunApp (dataConWrapId data_con) tys
-
-{- ********************************************************************
-* *
- Class lookup for Literals
-* *
-***********************************************************************-}
-
-matchKnownNat :: Class -> [Type] -> TcS LookupInstResult
-matchKnownNat clas [ty] -- clas = KnownNat
- | Just n <- isNumLitTy ty = makeLitDict clas ty (EvNum n)
-matchKnownNat _ _ = return NoInstance
-
-matchKnownSymbol :: Class -> [Type] -> TcS LookupInstResult
-matchKnownSymbol clas [ty] -- clas = KnownSymbol
- | Just n <- isStrLitTy ty = makeLitDict clas ty (EvStr n)
-matchKnownSymbol _ _ = return NoInstance
-
-
-makeLitDict :: Class -> Type -> EvLit -> TcS LookupInstResult
--- makeLitDict adds a coercion that will convert the literal into a dictionary
--- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit]
--- in TcEvidence. The coercion happens in 2 steps:
---
--- Integer -> SNat n -- representation of literal to singleton
--- SNat n -> KnownNat n -- singleton to dictionary
---
--- The process is mirrored for Symbols:
--- String -> SSymbol n
--- SSymbol n -> KnownSymbol n -}
-makeLitDict clas ty evLit
- | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
- -- co_dict :: KnownNat n ~ SNat n
- , [ meth ] <- classMethods clas
- , Just tcRep <- tyConAppTyCon_maybe -- SNat
- $ funResultTy -- SNat n
- $ dropForAlls -- KnownNat n => SNat n
- $ idType meth -- forall n. KnownNat n => SNat n
- , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
- -- SNat n ~ Integer
- , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))
- = return $ GenInst [] (\_ -> ev_tm) True
-
+ -- Representation for type constructor applied to some kinds
+ doTyCon tc ks =
+ case mapM kindRep ks of
+ Nothing -> return NoInstance
+ Just kReps ->
+ return $ GenInst [] (\_ -> EvTypeable (EvTypeableTyCon tc kReps) ) True
+
+ {- Representation for an application of a type to a type-or-kind.
+ This may happen when the type expression starts with a type variable.
+ Example (ignoring kind parameter):
+ Typeable (f Int Char) -->
+ (Typeable (f Int), Typeable Char) -->
+ (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps)
+ Typeable f
+ -}
+ doTyApp f tk
+ | isKind tk
+ = return NoInstance -- We can't solve until we know the ctr.
| otherwise
- = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
- $$ vcat (map (ppr . idType) (classMethods clas)))
-
-
-{- ********************************************************************
-* *
- Class lookup for Typeable
-* *
-***********************************************************************-}
-
--- | Assumes that we've checked that this is the 'Typeable' class,
--- and it was applied to the correct argument.
-matchTypeable :: Class -> [Type] -> TcS LookupInstResult
-matchTypeable clas [k,t] -- clas = Typeable
- -- For the first two cases, See Note [No Typeable for polytypes or qualified types]
- | isForAllTy k = return NoInstance -- Polytype
- | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type
-
- -- Now cases that do work
- | k `eqType` typeNatKind = doTyLit knownNatClassName t
- | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t
- | Just (_, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
- , all isGroundKind ks = doTyConApp t
- | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt
-
-matchTypeable _ _ = return NoInstance
-
-doTyConApp :: Type -> TcS LookupInstResult
--- Representation for type constructor applied to some (ground) kinds
-doTyConApp ty = return $ GenInst [] (\_ -> EvTypeable ty EvTypeableTyCon) True
-
--- Representation for concrete kinds. We just use the kind itself,
--- but first check to make sure that it is "simple" (i.e., made entirely
--- out of kind constructors).
-isGroundKind :: KindOrType -> Bool
--- Return True if (a) k is a kind and (b) it is a ground kind
-isGroundKind k
- = isKind k && is_ground k
- where
- is_ground k | Just (_, ks) <- splitTyConApp_maybe k
- = all is_ground ks
- | otherwise
- = False
-
-doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult
--- Representation for an application of a type to a type-or-kind.
--- This may happen when the type expression starts with a type variable.
--- Example (ignoring kind parameter):
--- Typeable (f Int Char) -->
--- (Typeable (f Int), Typeable Char) -->
--- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps)
--- Typeable f
-doTyApp clas ty f tk
- | isKind tk
- = return NoInstance -- We can't solve until we know the ctr.
- | otherwise
- = return $ GenInst [mk_typeable_pred clas f, mk_typeable_pred clas tk]
- (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp (EvId t1) (EvId t2))
- True
-
--- Emit a `Typeable` constraint for the given type.
-mk_typeable_pred :: Class -> Type -> PredType
-mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ]
-
- -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
- -- we generate a sub-goal for the appropriate class. See #10348 for what
- -- happens when we fail to do this.
-doTyLit :: Name -> Type -> TcS LookupInstResult
-doTyLit kc t = do { kc_clas <- tcLookupClass kc
- ; let kc_pred = mkClassPred kc_clas [ t ]
- mk_ev [ev] = EvTypeable t $ EvTypeableTyLit $ EvId ev
- mk_ev _ = panic "doTyLit"
- ; return (GenInst [kc_pred] mk_ev True) }
-
-{- Note [Typeable (T a b c)]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For type applications we always decompose using binary application,
-vai doTyApp, until we get to a *kind* instantiation. Exmaple
- Proxy :: forall k. k -> *
-
-To solve Typeable (Proxy (* -> *) Maybe) we
- - First decompose with doTyApp,
- to get (Typeable (Proxy (* -> *))) and Typeable Maybe
- - Then sovle (Typeable (Proxy (* -> *))) with doTyConApp
-
-If we attempt to short-cut by solving it all at once, via
-doTyCOnAPp
-
-
-Note [No Typeable for polytypes or qualified types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ = return $ GenInst [mk_typeable_pred f, mk_typeable_pred tk]
+ (\[t1,t2] -> EvTypeable $ EvTypeableTyApp (EvId t1,f) (EvId t2,tk))
+ True
+
+ -- Representation for concrete kinds. We just use the kind itself,
+ -- but first check to make sure that it is "simple" (i.e., made entirely
+ -- out of kind constructors).
+ kindRep ki = do (_,ks) <- splitTyConApp_maybe ki
+ mapM_ kindRep ks
+ return ki
+
+ -- Emit a `Typeable` constraint for the given type.
+ mk_typeable_pred ty = mkClassPred clas [ typeKind ty, ty ]
+
+ -- Given KnownNat / KnownSymbol, generate appropriate sub-goal
+ -- and make evidence for a type-level literal.
+ doTyLit c = do clas <- tcLookupClass c
+ let p = mkClassPred clas [ t ]
+ return $ GenInst [p] (\[i] -> EvTypeable
+ $ EvTypeableTyLit (EvId i,t)) True
+
+{- Note [No Typeable for polytype or for constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do not support impredicative typeable, such as
Typeable (forall a. a->a)
Typeable (Eq a => a -> a)
@@ -2063,9 +2003,9 @@ a TypeRep for them. For qualified but not polymorphic types, like
* We don't need a TypeRep for these things. TypeReps are for
monotypes only.
- * Perhaps we could treat `=>` as another type constructor for `Typeable`
- purposes, and thus support things like `Eq Int => Int`, however,
- at the current state of affairs this would be an odd exception as
- no other class works with impredicative types.
- For now we leave it off, until we have a better story for impredicativity.
+ * Perhaps we could treat `=>` as another type constructor for `Typeable`
+ purposes, and thus support things like `Eq Int => Int`, however,
+ at the current state of affairs this would be an odd exception as
+ no other class works with impredicative types.
+ For now we leave it off, until we have a better story for impredicativity.
-}
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 5c55fcef2f..f1db883509 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -314,7 +314,7 @@ tcPatSynMatcher (L loc name) lpat
; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
- matcher_id = mkExportedLocalId PatSynId matcher_name matcher_sigma
+ matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma
-- See Note [Exported LocalIds] in Id
cont_dicts = map nlHsVar prov_dicts
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 4e6b1d3db7..45c25e4942 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -68,7 +68,6 @@ import TcMType
import MkIface
import TcSimplify
import TcTyClsDecls
-import TcTypeable( mkModIdBindings )
import LoadIface
import TidyPgm ( mkBootModDetailsTc )
import RnNames
@@ -461,14 +460,8 @@ tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls explicit_mod_hdr exports decls
- = do { -- Create a binding for $trModule
- -- Do this before processing any data type declarations,
- -- which need tcg_tr_module to be initialised
- ; tcg_env <- mkModIdBindings
-
- -- Do all the declarations
- ; ((tcg_env, tcl_env), lie) <- setGblEnv tcg_env $
- captureConstraints $
+ = do { -- Do all the declarations
+ ((tcg_env, tcl_env), lie) <- captureConstraints $
do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
; tcg_env <- setEnvs (tcg_env, tcl_env) $
checkMain explicit_mod_hdr
@@ -968,13 +961,12 @@ checkBootTyCon tc1 tc2
| Just fam_flav1 <- famTyConFlav_maybe tc1
, Just fam_flav2 <- famTyConFlav_maybe tc2
= ASSERT(tc1 == tc2)
- let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
- eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
+ let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
= eqClosedFamilyAx ax1 ax2
- eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
+ eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
eqFamFlav _ _ = False
injInfo1 = familyTyConInjectivityInfo tc1
injInfo2 = familyTyConInjectivityInfo tc2
@@ -1006,6 +998,7 @@ checkBootTyCon tc1 tc2
(text "The natures of the declarations for" <+>
quotes (ppr tc) <+> text "are different")
| otherwise = checkSuccess
+ eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} =
checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} =
@@ -2070,7 +2063,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
tcg_rules = rules,
tcg_vects = vects,
tcg_imports = imports })
- = vcat [ ppr_types type_env
+ = vcat [ ppr_types insts type_env
, ppr_tycons fam_insts type_env
, ppr_insts insts
, ppr_fam_insts fam_insts
@@ -2087,19 +2080,20 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
`thenCmp`
(is_boot1 `compare` is_boot2)
-ppr_types :: TypeEnv -> SDoc
-ppr_types type_env
+ppr_types :: [ClsInst] -> TypeEnv -> SDoc
+ppr_types insts type_env
= text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
where
+ dfun_ids = map instanceDFunId insts
ids = [id | id <- typeEnvIds type_env, want_sig id]
- want_sig id | opt_PprStyle_Debug
- = True
- | otherwise
- = isExternalName (idName id) &&
- (case idDetails id of { VanillaId -> True; _ -> False })
- -- Looking for VanillaId ignores data constructors, records selectors etc.
- -- The isExternalName ignores local evidence bindings that the type checker
- -- has invented. Top-level user-defined things have External names.
+ want_sig id | opt_PprStyle_Debug = True
+ | otherwise = isLocalId id &&
+ isExternalName (idName id) &&
+ not (id `elem` dfun_ids)
+ -- isLocalId ignores data constructors, records selectors etc.
+ -- The isExternalName ignores local dictionary and method bindings
+ -- that the type checker has invented. Top-level user-defined things
+ -- have External names.
ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
ppr_tycons fam_insts type_env
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 19055647bd..601b030f74 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -144,7 +144,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_rn_imports = [],
tcg_rn_exports = maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
- tcg_tr_module = Nothing,
+
tcg_binds = emptyLHsBinds,
tcg_imp_specs = [],
tcg_sigs = emptyNameSet,
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 7375a8c66e..c046704643 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -477,9 +477,6 @@ data TcGblEnv
-- Things defined in this module, or (in GHCi)
-- in the declarations for a single GHCi command.
-- For the latter, see Note [The interactive package] in HscTypes
- tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module
- -- for which every module has a top-level defn
- -- except in GHCi in which case we have Nothing
tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature
tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids
@@ -901,7 +898,7 @@ pprPECategory RecDataConPE = ptext (sLit "Data constructor")
pprPECategory NoDataKinds = ptext (sLit "Data constructor")
{- Note [Bindings with closed types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f x = let g ys = map not ys
@@ -918,8 +915,6 @@ iff
a) all its free variables are imported, or are let-bound with closed types
b) generalisation is not restricted by the monomorphism restriction
-Invariant: a closed variable has no free type variables in its type.
-
Under OutsideIn we are free to generalise a closed let-binding.
This is an extension compared to the JFP paper on OutsideIn, which
used "top-level" as a proxy for "closed". (It's not a good proxy
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 78f1d35e5c..34b2585b4d 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -16,7 +16,7 @@ module TcTyClsDecls (
kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn, famTyConShape,
tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
- wrongKindOfFamily, dataConCtxt, badDataConTyCon, mkOneRecordSelector
+ wrongKindOfFamily, dataConCtxt, badDataConTyCon
) where
#include "HsVersions.h"
@@ -28,6 +28,7 @@ import TcRnMonad
import TcEnv
import TcValidity
import TcHsSyn
+import TcBinds( tcRecSelBinds )
import TcTyDecls
import TcClassDcl
import TcHsType
@@ -43,7 +44,6 @@ import Class
import CoAxiom
import TyCon
import DataCon
-import ConLike
import Id
import IdInfo
import Var
@@ -53,7 +53,6 @@ import Module
import Name
import NameSet
import NameEnv
-import RdrName
import RnEnv
import Outputable
import Maybes
@@ -64,10 +63,8 @@ import ListSetOps
import Digraph
import DynFlags
import FastString
-import Unique ( mkBuiltinUnique )
import BasicTypes
-import Bag
import Control.Monad
import Data.List
@@ -170,7 +167,16 @@ tcTyClGroup tyclds
-- Step 4: Add the implicit things;
-- we want them in the environment because
-- they may be mentioned in interface files
- ; tcAddImplicits tyclss } }
+ ; tcExtendGlobalValEnv (mkDefaultMethodIds tyclss) $
+ tcAddImplicits tyclss } }
+
+tcAddImplicits :: [TyThing] -> TcM TcGblEnv
+tcAddImplicits tyclss
+ = tcExtendGlobalEnvImplicit implicit_things $
+ tcRecSelBinds rec_sel_binds
+ where
+ implicit_things = concatMap implicitTyThings tyclss
+ rec_sel_binds = mkRecSelBinds tyclss
zipRecTyClss :: [(Name, Kind)]
-> [TyThing] -- Knot-tied
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index bba808063c..0da0cb1382 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -14,33 +14,28 @@ files for imported data types.
module TcTyDecls(
calcRecFlags, RecTyInfo(..),
calcSynCycles, calcClassCycles,
-
- -- * Roles
RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots,
-
- -- * Implicits
- tcAddImplicits
+ mkDefaultMethodIds, mkRecSelBinds, mkOneRecordSelector
) where
#include "HsVersions.h"
import TcRnMonad
import TcEnv
-import TcTypeable( mkTypeableBinds )
-import TcBinds( tcValBinds, addTypecheckedBinds )
-import TypeRep( Type(..) )
import TcType
import TysWiredIn( unitTy )
import MkCore( rEC_SEL_ERROR_ID )
+import TypeRep
import HsSyn
import Class
import Type
-import HscTypes
import TyCon
+import ConLike
import DataCon
import Name
import NameEnv
import RdrName ( mkVarUnqual )
+import Var ( tyVarKind )
import Id
import IdInfo
import VarEnv
@@ -384,7 +379,7 @@ calcRecFlags boot_details is_boot mrole_env tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
- is_promotable = all (computeTyConPromotability rec_tycon_names) all_tycons
+ is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons
roles = inferRoles is_boot mrole_env all_tycons
@@ -478,6 +473,70 @@ findLoopBreakers deps
{-
************************************************************************
* *
+ Promotion calculation
+* *
+************************************************************************
+
+See Note [Checking whether a group is promotable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only want to promote a TyCon if all its data constructors
+are promotable; it'd be very odd to promote some but not others.
+
+But the data constructors may mention this or other TyCons.
+
+So we treat the recursive uses as all OK (ie promotable) and
+do one pass to check that each TyCon is promotable.
+
+Currently type synonyms are not promotable, though that
+could change.
+-}
+
+isPromotableTyCon :: NameSet -> TyCon -> Bool
+isPromotableTyCon rec_tycons tc
+ = isAlgTyCon tc -- Only algebraic; not even synonyms
+ -- (we could reconsider the latter)
+ && ok_kind (tyConKind tc)
+ && case algTyConRhs tc of
+ DataTyCon { data_cons = cs } -> all ok_con cs
+ NewTyCon { data_con = c } -> ok_con c
+ AbstractTyCon {} -> False
+ DataFamilyTyCon {} -> False
+ TupleTyCon { tup_sort = sort } -> case sort of
+ BoxedTuple -> True
+ UnboxedTuple -> False
+ ConstraintTuple -> False
+ where
+ ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
+ where -- Checks for * -> ... -> * -> *
+ (args, res) = splitKindFunTys kind
+
+ -- See Note [Promoted data constructors] in TyCon
+ ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
+ && null eq_spec -- No constraints
+ && null theta
+ && all (isPromotableType rec_tycons) orig_arg_tys
+ where
+ (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
+
+
+isPromotableType :: NameSet -> Type -> Bool
+-- Must line up with DataCon.promoteType
+-- But the function lives here because we must treat the
+-- *recursive* tycons as promotable
+isPromotableType rec_tcs con_arg_ty
+ = go con_arg_ty
+ where
+ go (TyConApp tc tys) = tys `lengthIs` tyConArity tc
+ && (tyConName tc `elemNameSet` rec_tcs
+ || isJust (promotableTyCon_maybe tc))
+ && all go tys
+ go (FunTy arg res) = go arg && go res
+ go (TyVarTy {}) = True
+ go _ = False
+
+{-
+************************************************************************
+* *
Role annotations
* *
************************************************************************
@@ -800,27 +859,6 @@ updateRoleEnv name n role
RIS { role_env = role_env', update = True }
else state )
-
-{- *********************************************************************
-* *
- Building implicits
-* *
-********************************************************************* -}
-
-tcAddImplicits :: [TyThing] -> TcM TcGblEnv
-tcAddImplicits tyclss
- = discardWarnings $
- tcExtendGlobalEnvImplicit implicit_things $
- tcExtendGlobalValEnv def_meth_ids $
- do { (rec_sel_ids, rec_sel_binds) <- mkRecSelBinds tycons
- ; (typeable_ids, typeable_binds) <- mkTypeableBinds tycons
- ; gbl_env <- tcExtendGlobalValEnv (rec_sel_ids ++ typeable_ids) getGblEnv
- ; return (gbl_env `addTypecheckedBinds` (rec_sel_binds ++ typeable_binds)) }
- where
- implicit_things = concatMap implicitTyThings tyclss
- tycons = [tc | ATyCon tc <- tyclss]
- def_meth_ids = mkDefaultMethodIds tyclss
-
{-
************************************************************************
* *
@@ -855,49 +893,53 @@ must bring the default method Ids into scope first (so they can be seen
when typechecking the [d| .. |] quote, and typecheck them later.
-}
-mkRecSelBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id])
+mkRecSelBinds :: [TyThing] -> HsValBinds Name
+-- NB We produce *un-typechecked* bindings, rather like 'deriving'
+-- This makes life easier, because the later type checking will add
+-- all necessary type abstractions and applications
mkRecSelBinds tycons
- = do { -- We generate *un-typechecked* bindings in mkRecSelBind, and
- -- then typecheck them, rather like 'deriving'. This makes life
- -- easier, because the later type checking will add all necessary
- -- type abstractions and applications
-
- let sel_binds :: [(RecFlag, LHsBinds Name)]
- sel_sigs :: [LSig Name]
- (sel_sigs, sel_binds)
- = mapAndUnzip mkRecSelBind [ (tc,fld)
- | tc <- tycons
- , fld <- tyConFieldLabels tc ]
- sel_ids = [sel_id | L _ (IdSig sel_id) <- sel_sigs]
- ; (sel_binds, _) <- tcValBinds TopLevel sel_binds sel_sigs (return ())
- ; return (sel_ids, map snd sel_binds) }
-
-mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name))
+ = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
+ where
+ (sigs, binds) = unzip rec_sels
+ rec_sels = map mkRecSelBind [ (tc,fld)
+ | ATyCon tc <- tycons
+ , fld <- tyConFieldLabels tc ]
+
+
+mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
mkRecSelBind (tycon, fl)
- = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind)))
+ = mkOneRecordSelector all_cons (RecSelData tycon) fl
+ where
+ all_cons = map RealDataCon (tyConDataCons tycon)
+
+mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
+ -> (LSig Name, LHsBinds Name)
+mkOneRecordSelector all_cons idDetails fl =
+ (L loc (IdSig sel_id), unitBag (L loc sel_bind))
where
loc = getSrcSpan sel_name
- sel_id = mkExportedLocalId rec_details sel_name sel_ty
lbl = flLabel fl
sel_name = flSelector fl
- rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
+
+ sel_id = mkExportedLocalId rec_details sel_name sel_ty
+ rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }
-- Find a representative constructor, con1
- all_cons = tyConDataCons tycon
- cons_w_field = tyConDataConsWithFields tycon [lbl]
- con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+ cons_w_field = conLikesWithFields all_cons [lbl]
+ con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
-- Selector type; Note [Polymorphic selectors]
- field_ty = dataConFieldType con1 lbl
- data_ty = dataConOrigResTy con1
+ field_ty = conLikeFieldType con1 lbl
data_tvs = tyVarsOfType data_ty
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
(field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
| otherwise = mkForAllTys (varSetElemsKvsFirst $
data_tvs `extendVarSetList` field_tvs) $
- mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
+ mkPhiTy (conLikeStupidTheta con1) $ -- Urgh!
mkPhiTy field_theta $ -- Urgh!
+ -- req_theta is empty for normal DataCon
+ mkPhiTy req_theta $
mkFunTy data_ty field_tau
-- Make the binding: sel (C2 { fld = x }) = x
@@ -934,8 +976,14 @@ mkRecSelBind (tycon, fl)
-- data instance T Int a where
-- A :: { fld :: Int } -> T Int Bool
-- B :: { fld :: Int } -> T Int Char
- dealt_with con = con `elem` cons_w_field || dataConCannotMatch inst_tys con
- inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1)
+ dealt_with :: ConLike -> Bool
+ dealt_with (PatSynCon _) = False -- We can't predict overlap
+ dealt_with con@(RealDataCon dc) =
+ con `elem` cons_w_field || dataConCannotMatch inst_tys dc
+
+ (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1
+
+ inst_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs
unit_rhs = mkLHsTupleExpr []
msg_lit = HsStringPrim "" (fastStringToByteString lbl)
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index e64f43a9ba..1f31d5666a 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -16,7 +16,7 @@ import Type
import Pair
import TcType ( TcType, tcEqType )
import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon
- , Injectivity(..) )
+ , Injectivity(..), TyConParent(..) )
import Coercion ( Role(..) )
import TcRnTypes ( Xi )
import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..) )
@@ -45,7 +45,7 @@ import qualified Data.Map as Map
import Data.Maybe ( isJust )
{-------------------------------------------------------------------------------
-Built-in type constructors for functions on type-level nats
+Built-in type constructors for functions on type-lelve nats
-}
typeNatTyCons :: [TyCon]
@@ -110,7 +110,7 @@ typeNatLeqTyCon =
(mkTemplateTyVars [ typeNatKind, typeNatKind ])
Nothing
(BuiltInSynFamTyCon ops)
- Nothing
+ NoParentTyCon
NotInjective
where
@@ -129,7 +129,7 @@ typeNatCmpTyCon =
(mkTemplateTyVars [ typeNatKind, typeNatKind ])
Nothing
(BuiltInSynFamTyCon ops)
- Nothing
+ NoParentTyCon
NotInjective
where
@@ -148,7 +148,7 @@ typeSymbolCmpTyCon =
(mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ])
Nothing
(BuiltInSynFamTyCon ops)
- Nothing
+ NoParentTyCon
NotInjective
where
@@ -172,7 +172,7 @@ mkTypeNatFunTyCon2 op tcb =
(mkTemplateTyVars [ typeNatKind, typeNatKind ])
Nothing
(BuiltInSynFamTyCon tcb)
- Nothing
+ NoParentTyCon
NotInjective
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
deleted file mode 100644
index f015eec79f..0000000000
--- a/compiler/typecheck/TcTypeable.hs
+++ /dev/null
@@ -1,206 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
--}
-
-module TcTypeable(
- mkTypeableBinds, mkModIdBindings
- ) where
-
-
-import TcBinds( addTypecheckedBinds )
-import IfaceEnv( newGlobalBinder )
-import TcEnv
-import TcRnMonad
-import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName )
-import Id
-import IdInfo( IdDetails(..) )
-import Type
-import TyCon
-import DataCon
-import Name( getOccName )
-import OccName
-import Module
-import HsSyn
-import DynFlags
-import Bag
-import Fingerprint(Fingerprint(..), fingerprintString)
-import Outputable
-import Data.Word( Word64 )
-import FastString ( FastString, mkFastString )
-
-{- Note [Grand plan for Typeable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The overall plan is this:
-
-1. Generate a binding for each module p:M
- (done in TcTypeable by mkModIdBindings)
- M.$trModule :: GHC.Types.Module
- M.$trModule = Module "p" "M"
- ("tr" is short for "type representation"; see GHC.Types)
-
- We might want to add the filename too.
- This can be used for the lightweight stack-tracing stuff too
-
- Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
-
-2. Generate a binding for every data type declaration T in module M,
- M.$tcT :: GHC.Types.TyCon
- M.$tcT = TyCon ...fingerprint info...
- $trModule
- "T"
- We define (in TyCon)
- type TyConRepName = Name
- to use for these M.$tcT "tycon rep names".
-
-3. Record the TyConRepName in T's TyCon, including for promoted
- data and type constructors, and kinds like * and #.
-
- The TyConRepNaem is not an "implicit Id". It's more like a record
- selector: the TyCon knows its name but you have to go to the
- interface file to find its type, value, etc
-
-4. Solve Typeable costraints. This is done by a custom Typeable solver,
- currently in TcInteract, that use M.$tcT so solve (Typeable T).
-
-There are many wrinkles:
-
-* Since we generate $tcT for every data type T, the types TyCon and
- Module must be available right from the start; so they are defined
- in ghc-prim:GHC.Types
-
-* To save space and reduce dependencies, we need use quite low-level
- representations for TyCon and Module. See GHC.Types
- Note [Runtime representation of modules and tycons]
-
-* It's hard to generate the TyCon/Module bindings when the types TyCon
- and Module aren't yet available; i.e. when compiling GHC.Types
- itself. So we *don't* generate them for types in GHC.Types. Instead
- we write them by hand in base:GHC.Typeable.Internal.
-
-* To be able to define them by hand, they need to have user-writable
- names, thus
- tcBool not $tcBool for the type-rep TyCon for Bool
- Hence PrelNames.tyConRepModOcc
-
-* Moreover for type constructors with special syntax, they need to have
- completely hand-crafted names
- lists tcList not $tc[] for the type-rep TyCon for []
- kinds tcLiftedKind not $tc* for the type-rep TyCon for *
- Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString
- to use for the TyConRepName
-
-* Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must
- be wired in as well. For these wired-in TyCons we generate the
- TyConRepName's unique from that of the TyCon; see
- Unique.tyConRepNameUnique, dataConRepNameUnique.
-
--}
-
-{- *********************************************************************
-* *
- Building top-level binding for $trModule
-* *
-********************************************************************* -}
-
-mkModIdBindings :: TcM TcGblEnv
-mkModIdBindings
- = do { mod <- getModule
- ; if mod == gHC_TYPES
- then getGblEnv -- Do not generate bindings for modules in GHC.Types
- else
- do { loc <- getSrcSpanM
- ; tr_mod_dc <- tcLookupDataCon trModuleDataConName
- ; tr_name_dc <- tcLookupDataCon trNameSDataConName
- ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc
- ; let mod_id = mkExportedLocalId ReflectionId mod_nm
- (mkTyConApp (dataConTyCon tr_mod_dc) [])
- mod_bind = mkVarBind mod_id mod_rhs
- mod_rhs = nlHsApps (dataConWrapId tr_mod_dc)
- [ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod))
- , trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ]
-
- ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
- ; return (tcg_env { tcg_tr_module = Just mod_id }
- `addTypecheckedBinds` [unitBag mod_bind]) } }
-
-
-{- *********************************************************************
-* *
- Building type-representation bindings
-* *
-********************************************************************* -}
-
-mkTypeableBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id])
-mkTypeableBinds tycons
- = do { dflags <- getDynFlags
- ; gbl_env <- getGblEnv
- ; mod <- getModule
- ; if mod == gHC_TYPES
- then return ([], []) -- Do not generate bindings for modules in GHC.Types
- else
- do { tr_datacon <- tcLookupDataCon trTyConDataConName
- ; trn_datacon <- tcLookupDataCon trNameSDataConName
- ; let pkg_str = unitIdString (moduleUnitId mod)
- mod_str = moduleNameString (moduleName mod)
- mod_expr = case tcg_tr_module gbl_env of -- Should be set by now
- Just mod_id -> nlHsVar mod_id
- Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
- stuff = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
- tc_binds = map (mk_typeable_binds stuff) tycons
- tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
- ; return (tycon_rep_ids, tc_binds) } }
-
-trNameLit :: DataCon -> FastString -> LHsExpr Id
-trNameLit tr_name_dc fs
- = nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)]
-
-type TypeableStuff
- = ( DynFlags
- , LHsExpr Id -- Of type GHC.Types.Module
- , String -- Package name
- , String -- Module name
- , DataCon -- Data constructor GHC.Types.TyCon
- , DataCon ) -- Data constructor GHC.Types.TrNameS
-
-mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
-mk_typeable_binds stuff tycon
- = mkTyConRepBinds stuff tycon
- `unionBags`
- unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))
-
-mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
-mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon
- = case tyConRepName_maybe tycon of
- Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
- where
- rep_id = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon [])
- _ -> emptyBag
- where
- tr_tycon = dataConTyCon tr_datacon
- rep_rhs = nlHsApps (dataConWrapId tr_datacon)
- [ nlHsLit (word64 high), nlHsLit (word64 low)
- , mod_expr
- , trNameLit trn_datacon (mkFastString tycon_str) ]
-
- tycon_str = add_tick (occNameString (getOccName tycon))
- add_tick s | isPromotedDataCon tycon = '\'' : s
- | isPromotedTyCon tycon = '\'' : s
- | otherwise = s
-
- hashThis :: String
- hashThis = unwords [pkg_str, mod_str, tycon_str]
-
- Fingerprint high low
- | gopt Opt_SuppressUniques dflags = Fingerprint 0 0
- | otherwise = fingerprintString hashThis
-
- word64 :: Word64 -> HsLit
- word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
- | otherwise = \n -> HsWordPrim (show n) (toInteger n)
-
-mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
-mkTypeableDataConBinds stuff dc
- = case promoteDataCon_maybe dc of
- Promoted tc -> mkTyConRepBinds stuff tc
- NotPromoted -> emptyBag
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index 21598450c2..465ccb14b6 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -13,8 +13,8 @@ module TyCon(
TyCon,
AlgTyConRhs(..), visibleDataCons,
- AlgTyConFlav(..), isNoParent,
- FamTyConFlav(..), Role(..), Promoted(..), Injectivity(..),
+ TyConParent(..), isNoParent,
+ FamTyConFlav(..), Role(..), Injectivity(..),
-- ** Field labels
tyConFieldLabels, tyConFieldLabelEnv,
@@ -42,7 +42,7 @@ module TyCon(
mightBeUnsaturatedTyCon,
isPromotedDataCon, isPromotedTyCon,
isPromotedDataCon_maybe, isPromotedTyCon_maybe,
- promotableTyCon_maybe, isPromotableTyCon, promoteTyCon,
+ promotableTyCon_maybe, promoteTyCon,
isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,
isEnumerationTyCon,
@@ -71,6 +71,7 @@ module TyCon(
tyConStupidTheta,
tyConArity,
tyConRoles,
+ tyConParent,
tyConFlavour,
tyConTuple_maybe, tyConClass_maybe,
tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
@@ -88,9 +89,6 @@ module TyCon(
newTyConCo, newTyConCo_maybe,
pprPromotionQuote,
- -- * Runtime type representation
- TyConRepName, tyConRepName_maybe,
-
-- * Primitive representations of Types
PrimRep(..), PrimElemRep(..),
tyConPrimRep, isVoidRep, isGcPtrRep,
@@ -192,8 +190,8 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
Note that this is a *representational* coercion
The R:TInt is the "representation TyCons".
- It has an AlgTyConFlav of
- DataFamInstTyCon T [Int] ax_ti
+ It has an AlgTyConParent of
+ FamInstTyCon T [Int] ax_ti
* The axiom ax_ti may be eta-reduced; see
Note [Eta reduction for data family axioms] in TcInstDcls
@@ -225,9 +223,9 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
data instance declaration for T (a,b), to get the result type in the
representation; e.g. T (a,b) --> R:TPair a b
- The representation TyCon R:TList, has an AlgTyConFlav of
+ The representation TyCon R:TList, has an AlgTyConParent of
- DataFamInstTyCon T [(a,b)] ax_pr
+ FamInstTyCon T [(a,b)] ax_pr
* Notice that T is NOT translated to a FC type function; it just
becomes a "data type" with no constructors, which can be coerced inot
@@ -271,7 +269,7 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
Note [Associated families and their parent class]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*Associated* families are just like *non-associated* families, except
-that they have a famTcParent field of (Just cls), which identifies the
+that they have a TyConParent of AssocFamilyTyCon, which identifies the
parent class.
However there is an important sharing relationship between
@@ -377,26 +375,15 @@ data TyCon
tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just
-- the return kind)
- tyConArity :: Arity, -- ^ Number of arguments this TyCon must
+ tyConArity :: Arity -- ^ Number of arguments this TyCon must
-- receive to be considered saturated
-- (including implicit kind variables)
-
- tcRepName :: TyConRepName
}
- -- | Algebraic data types, from
- -- - @data@ declararations
- -- - @newtype@ declarations
- -- - data instance declarations
- -- - type instance declarations
- -- - the TyCon generated by a class declaration
- -- - boxed tuples
- -- - unboxed tuples
- -- - constraint tuples
- -- All these constructors are lifted and boxed except unboxed tuples
- -- which should have an 'UnboxedAlgTyCon' parent.
- -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.
- -- See 'AlgTyConRhs' for more information.
+ -- | Algebraic type constructors, which are defined to be those
+ -- arising @data@ type and @newtype@ declarations. All these
+ -- constructors are lifted and boxed. See 'AlgTyConRhs' for more
+ -- information.
| AlgTyCon {
tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant:
-- identical to Unique of Name stored in
@@ -453,11 +440,12 @@ data TyCon
algTcRec :: RecFlag, -- ^ Tells us whether the data type is part
-- of a mutually-recursive group or not
- algTcParent :: AlgTyConFlav, -- ^ Gives the class or family declaration
- -- 'TyCon' for derived 'TyCon's representing
- -- class or family instances, respectively.
+ algTcParent :: TyConParent, -- ^ Gives the class or family declaration
+ -- 'TyCon' for derived 'TyCon's representing
+ -- class or family instances, respectively.
+ -- See also 'synTcParent'
- tcPromoted :: Promoted TyCon -- ^ Promoted TyCon, if any
+ tcPromoted :: Maybe TyCon -- ^ Promoted TyCon, if any
}
-- | Represents type synonyms
@@ -487,8 +475,7 @@ data TyCon
-- of the synonym
}
- -- | Represents families (both type and data)
- -- Argument roles are all Nominal
+ -- | Represents type families
| FamilyTyCon {
tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant:
-- identical to Unique of Name stored in
@@ -509,7 +496,7 @@ data TyCon
-- Precisely, this list scopes over:
--
-- 1. The 'algTcStupidTheta'
- -- 2. The cached types in 'algTyConRhs.NewTyCon'
+ -- 2. The cached types in algTyConRhs.NewTyCon
-- 3. The family instance types if present
--
-- Note that it does /not/ scope over the data
@@ -524,9 +511,8 @@ data TyCon
-- abstract, built-in. See comments for
-- FamTyConFlav
- famTcParent :: Maybe Class, -- ^ For *associated* type/data families
- -- The class in whose declaration the family is declared
- -- See Note [Associated families and their parent class]
+ famTcParent :: TyConParent, -- ^ TyCon of enclosing class for
+ -- associated type families
famTcInj :: Injectivity -- ^ is this a type family injective in
-- its type variables? Nothing if no
@@ -535,7 +521,7 @@ data TyCon
-- | Primitive types; cannot be defined in Haskell. This includes
-- the usual suspects (such as @Int#@) as well as foreign-imported
- -- types and kinds (@*@, @#@, and @?@)
+ -- types and kinds
| PrimTyCon {
tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant:
-- identical to Unique of Name stored in
@@ -559,13 +545,9 @@ data TyCon
-- pointers). This 'PrimRep' holds that
-- information. Only relevant if tyConKind = *
- isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may
+ isUnLifted :: Bool -- ^ Most primitive tycons are unlifted (may
-- not contain bottom) but other are lifted,
-- e.g. @RealWorld@
- -- Only relevant if tyConKind = *
-
- primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons
- -- i.e, *, #, ?
}
-- | Represents promoted data constructor.
@@ -575,8 +557,7 @@ data TyCon
tyConArity :: Arity,
tyConKind :: Kind, -- ^ Translated type of the data constructor
tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars
- dataCon :: DataCon,-- ^ Corresponding data constructor
- tcRepName :: TyConRepName
+ dataCon :: DataCon -- ^ Corresponding data constructor
}
-- | Represents promoted type constructor.
@@ -585,8 +566,7 @@ data TyCon
tyConName :: Name, -- ^ Same Name as the type constructor
tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times
tyConKind :: Kind, -- ^ Always TysPrim.superKind
- ty_con :: TyCon, -- ^ Corresponding type constructor
- tcRepName :: TyConRepName
+ ty_con :: TyCon -- ^ Corresponding type constructor
}
deriving Typeable
@@ -602,6 +582,20 @@ data AlgTyConRhs
Bool -- True <=> It's definitely a distinct data type,
-- equal only to itself; ie not a newtype
-- False <=> Not sure
+ -- See Note [AbstractTyCon and type equality]
+
+ -- | Represents an open type family without a fixed right hand
+ -- side. Additional instances can appear at any time.
+ --
+ -- These are introduced by either a top level declaration:
+ --
+ -- > data T a :: *
+ --
+ -- Or an associated data type declaration, within a class declaration:
+ --
+ -- > class C a b where
+ -- > data T b :: *
+ | DataFamilyTyCon
-- | Information about those 'TyCon's derived from a @data@
-- declaration. This includes data types with no constructors at
@@ -655,15 +649,18 @@ data AlgTyConRhs
-- again check Trac #1072.
}
--- | Isomorphic to Maybe, but used when the question is
--- whether or not something is promoted
-data Promoted a = NotPromoted | Promoted a
+{-
+Note [AbstractTyCon and type equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+TODO
+-}
-- | Extract those 'DataCon's that we are able to learn about. Note
-- that visibility in this sense does not correspond to visibility in
-- the context of any particular user program!
visibleDataCons :: AlgTyConRhs -> [DataCon]
visibleDataCons (AbstractTyCon {}) = []
+visibleDataCons DataFamilyTyCon {} = []
visibleDataCons (DataTyCon{ data_cons = cs }) = cs
visibleDataCons (NewTyCon{ data_con = c }) = [c]
visibleDataCons (TupleTyCon{ data_con = c }) = [c]
@@ -671,35 +668,26 @@ visibleDataCons (TupleTyCon{ data_con = c }) = [c]
-- ^ Both type classes as well as family instances imply implicit
-- type constructors. These implicit type constructors refer to their parent
-- structure (ie, the class or family from which they derive) using a type of
--- the following form.
-data AlgTyConFlav
+-- the following form. We use 'TyConParent' for both algebraic and synonym
+-- types, but the variant 'ClassTyCon' will only be used by algebraic 'TyCon's.
+data TyConParent
= -- | An ordinary type constructor has no parent.
- VanillaAlgTyCon
- TyConRepName
-
- -- | An unboxed type constructor. Note that this carries no TyConRepName
- -- as it is not representable.
- | UnboxedAlgTyCon
+ NoParentTyCon
-- | Type constructors representing a class dictionary.
-- See Note [ATyCon for classes] in TypeRep
| ClassTyCon
Class -- INVARIANT: the classTyCon of this Class is the
-- current tycon
- TyConRepName
-
- -- | Type constructors representing an *instance* of a *data* family.
- -- Parameters:
- --
- -- 1) The type family in question
- --
- -- 2) Instance types; free variables are the 'tyConTyVars'
- -- of the current 'TyCon' (not the family one). INVARIANT:
- -- the number of types matches the arity of the family 'TyCon'
- --
- -- 3) A 'CoTyCon' identifying the representation
- -- type with the type instance family
- | DataFamInstTyCon -- See Note [Data type families]
+
+ -- | An *associated* type of a class.
+ | AssocFamilyTyCon
+ Class -- The class in whose declaration the family is declared
+ -- See Note [Associated families and their parent class]
+
+ -- | Type constructors representing an instance of a *data* family.
+ -- See Note [Data type families] and source comments for more info.
+ | FamInstTyCon -- See Note [Data type families]
(CoAxiom Unbranched) -- The coercion axiom.
-- A *Representational* coercion,
-- of kind T ty1 ty2 ~R R:T a b c
@@ -720,26 +708,27 @@ data AlgTyConFlav
-- gives a representation tycon:
-- data R:TList a = ...
-- axiom co a :: T [a] ~ R:TList a
- -- with R:TList's algTcParent = DataFamInstTyCon T [a] co
-
-instance Outputable AlgTyConFlav where
- ppr (VanillaAlgTyCon {}) = text "Vanilla ADT"
- ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT"
- ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls
- ppr (DataFamInstTyCon _ tc tys) =
+ -- with R:TList's algTcParent = FamInstTyCon T [a] co
+
+instance Outputable TyConParent where
+ ppr NoParentTyCon = text "No parent"
+ ppr (ClassTyCon cls) = text "Class parent" <+> ppr cls
+ ppr (AssocFamilyTyCon cls) =
+ text "Class parent (assoc. family)" <+> ppr cls
+ ppr (FamInstTyCon _ tc tys) =
text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys)
--- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class
+-- | Checks the invariants of a 'TyConParent' given the appropriate type class
-- name, if any
-okParent :: Name -> AlgTyConFlav -> Bool
-okParent _ (VanillaAlgTyCon {}) = True
-okParent _ (UnboxedAlgTyCon) = True
-okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls)
-okParent _ (DataFamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
+okParent :: Name -> TyConParent -> Bool
+okParent _ NoParentTyCon = True
+okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls)
+okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls)
+okParent _ (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
-isNoParent :: AlgTyConFlav -> Bool
-isNoParent (VanillaAlgTyCon {}) = True
-isNoParent _ = False
+isNoParent :: TyConParent -> Bool
+isNoParent NoParentTyCon = True
+isNoParent _ = False
--------------------
@@ -750,22 +739,8 @@ data Injectivity
-- | Information pertaining to the expansion of a type synonym (@type@)
data FamTyConFlav
- = -- | Represents an open type family without a fixed right hand
- -- side. Additional instances can appear at any time.
- --
- -- These are introduced by either a top level declaration:
- --
- -- > data T a :: *
- --
- -- Or an associated data type declaration, within a class declaration:
- --
- -- > class C a b where
- -- > data T b :: *
- DataFamilyTyCon
- TyConRepName
-
- -- | An open type synonym family e.g. @type family F x y :: * -> *@
- | OpenSynFamilyTyCon
+ = -- | An open type synonym family e.g. @type family F x y :: * -> *@
+ OpenSynFamilyTyCon
-- | A closed type synonym family e.g.
-- @type family F x where { F Int = Bool }@
@@ -903,34 +878,7 @@ so the coercion tycon CoT must have
************************************************************************
* *
- TyConRepName
-* *
-********************************************************************* -}
-
-type TyConRepName = Name -- The Name of the top-level declaration
- -- $tcMaybe :: Data.Typeable.Internal.TyCon
- -- $tcMaybe = TyCon { tyConName = "Maybe", ... }
-
-tyConRepName_maybe :: TyCon -> Maybe TyConRepName
-tyConRepName_maybe (FunTyCon { tcRepName = rep_nm })
- = Just rep_nm
-tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm })
- = mb_rep_nm
-tyConRepName_maybe (AlgTyCon { algTcParent = parent })
- | VanillaAlgTyCon rep_nm <- parent = Just rep_nm
- | ClassTyCon _ rep_nm <- parent = Just rep_nm
-tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })
- = Just rep_nm
-tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm })
- = Just rep_nm
-tyConRepName_maybe (PromotedTyCon { tcRepName = rep_nm })
- = Just rep_nm
-tyConRepName_maybe _ = Nothing
-
-
-{- *********************************************************************
-* *
- PrimRep
+\subsection{PrimRep}
* *
************************************************************************
@@ -1114,14 +1062,13 @@ So we compromise, and move their Kind calculation to the call site.
-- | Given the name of the function type constructor and it's kind, create the
-- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want
-- this functionality
-mkFunTyCon :: Name -> Kind -> Name -> TyCon
-mkFunTyCon name kind rep_nm
+mkFunTyCon :: Name -> Kind -> TyCon
+mkFunTyCon name kind
= FunTyCon {
tyConUnique = nameUnique name,
tyConName = name,
tyConKind = kind,
- tyConArity = 2,
- tcRepName = rep_nm
+ tyConArity = 2
}
-- | This is the making of an algebraic 'TyCon'. Notably, you have to
@@ -1137,12 +1084,11 @@ mkAlgTyCon :: Name
-> Maybe CType -- ^ The C type this type corresponds to
-- when using the CAPI FFI
-> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta'
- -> AlgTyConRhs -- ^ Information about data constructors
- -> AlgTyConFlav -- ^ What flavour is it?
- -- (e.g. vanilla, type family)
+ -> AlgTyConRhs -- ^ Information about dat aconstructors
+ -> TyConParent
-> RecFlag -- ^ Is the 'TyCon' recursive?
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
- -> Promoted TyCon -- ^ Promoted version
+ -> Maybe TyCon -- ^ Promoted version
-> TyCon
mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc
= AlgTyCon {
@@ -1164,12 +1110,11 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t
-- | Simpler specialization of 'mkAlgTyCon' for classes
mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class
- -> RecFlag -> Name -> TyCon
-mkClassTyCon name kind tyvars roles rhs clas is_rec tc_rep_name
- = mkAlgTyCon name kind tyvars roles Nothing [] rhs
- (ClassTyCon clas tc_rep_name)
+ -> RecFlag -> TyCon
+mkClassTyCon name kind tyvars roles rhs clas is_rec
+ = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas)
is_rec False
- NotPromoted -- Class TyCons are not promoted
+ Nothing -- Class TyCons are not promoted
mkTupleTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
@@ -1177,8 +1122,8 @@ mkTupleTyCon :: Name
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
-> DataCon
-> TupleSort -- ^ Whether the tuple is boxed or unboxed
- -> Promoted TyCon -- ^ Promoted version
- -> AlgTyConFlav
+ -> Maybe TyCon -- ^ Promoted version
+ -> TyConParent
-> TyCon
mkTupleTyCon name kind arity tyvars con sort prom_tc parent
= AlgTyCon {
@@ -1190,8 +1135,7 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent
tcRoles = replicate arity Representational,
tyConCType = Nothing,
algTcStupidTheta = [],
- algTcRhs = TupleTyCon { data_con = con,
- tup_sort = sort },
+ algTcRhs = TupleTyCon { data_con = con, tup_sort = sort },
algTcFields = emptyFsEnv,
algTcParent = parent,
algTcRec = NonRecursive,
@@ -1202,21 +1146,20 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent
-- | Create an unlifted primitive 'TyCon', such as @Int#@
mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon
mkPrimTyCon name kind roles rep
- = mkPrimTyCon' name kind roles rep True Nothing
+ = mkPrimTyCon' name kind roles rep True
-- | Kind constructors
-mkKindTyCon :: Name -> Kind -> Name -> TyCon
-mkKindTyCon name kind rep_nm
- = mkPrimTyCon' name kind [] VoidRep True (Just rep_nm)
+mkKindTyCon :: Name -> Kind -> TyCon
+mkKindTyCon name kind
+ = mkPrimTyCon' name kind [] VoidRep True
-- | Create a lifted primitive 'TyCon' such as @RealWorld@
mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon
mkLiftedPrimTyCon name kind roles rep
- = mkPrimTyCon' name kind roles rep False Nothing
+ = mkPrimTyCon' name kind roles rep False
-mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep
- -> Bool -> Maybe TyConRepName -> TyCon
-mkPrimTyCon' name kind roles rep is_unlifted rep_nm
+mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep -> Bool -> TyCon
+mkPrimTyCon' name kind roles rep is_unlifted
= PrimTyCon {
tyConName = name,
tyConUnique = nameUnique name,
@@ -1224,8 +1167,7 @@ mkPrimTyCon' name kind roles rep is_unlifted rep_nm
tyConArity = length roles,
tcRoles = roles,
primTyConRep = rep,
- isUnLifted = is_unlifted,
- primRepName = rep_nm
+ isUnLifted = is_unlifted
}
-- | Create a type synonym 'TyCon'
@@ -1243,7 +1185,7 @@ mkSynonymTyCon name kind tyvars roles rhs
-- | Create a type family 'TyCon'
mkFamilyTyCon:: Name -> Kind -> [TyVar] -> Maybe Name -> FamTyConFlav
- -> Maybe Class -> Injectivity -> TyCon
+ -> TyConParent -> Injectivity -> TyCon
mkFamilyTyCon name kind tyvars resVar flav parent inj
= FamilyTyCon
{ tyConUnique = nameUnique name
@@ -1262,16 +1204,15 @@ mkFamilyTyCon name kind tyvars resVar flav parent inj
-- Somewhat dodgily, we give it the same Name
-- as the data constructor itself; when we pretty-print
-- the TyCon we add a quote; see the Outputable TyCon instance
-mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> Kind -> [Role] -> TyCon
-mkPromotedDataCon con name rep_name kind roles
+mkPromotedDataCon :: DataCon -> Name -> Unique -> Kind -> [Role] -> TyCon
+mkPromotedDataCon con name unique kind roles
= PromotedDataCon {
- tyConUnique = nameUnique name,
tyConName = name,
+ tyConUnique = unique,
tyConArity = arity,
tcRoles = roles,
tyConKind = kind,
- dataCon = con,
- tcRepName = rep_name
+ dataCon = con
}
where
arity = length roles
@@ -1286,11 +1227,7 @@ mkPromotedTyCon tc kind
tyConUnique = getUnique tc,
tyConArity = tyConArity tc,
tyConKind = kind,
- ty_con = tc,
- tcRepName = case tyConRepName_maybe tc of
- Just rep_nm -> rep_nm
- Nothing -> pprPanic "mkPromotedTyCon" (ppr tc)
- -- Promoted TyCons always have a TyConRepName
+ ty_con = tc
}
isFunTyCon :: TyCon -> Bool
@@ -1347,6 +1284,7 @@ isDataTyCon (AlgTyCon {algTcRhs = rhs})
-> isBoxed (tupleSortBoxity sort)
DataTyCon {} -> True
NewTyCon {} -> False
+ DataFamilyTyCon {} -> False
AbstractTyCon {} -> False -- We don't know, so return False
isDataTyCon _ = False
@@ -1362,8 +1300,7 @@ isInjectiveTyCon (AlgTyCon {}) Nominal = True
isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational
= isGenInjAlgRhs rhs
isInjectiveTyCon (SynonymTyCon {}) _ = False
-isInjectiveTyCon (FamilyTyCon {famTcFlav = flav}) Nominal = isDataFamFlav flav
-isInjectiveTyCon (FamilyTyCon {}) Representational = False
+isInjectiveTyCon (FamilyTyCon {}) _ = False
isInjectiveTyCon (PrimTyCon {}) _ = True
isInjectiveTyCon (PromotedDataCon {}) _ = True
isInjectiveTyCon (PromotedTyCon {ty_con = tc}) r
@@ -1383,6 +1320,7 @@ isGenerativeTyCon = isInjectiveTyCon
isGenInjAlgRhs :: AlgTyConRhs -> Bool
isGenInjAlgRhs (TupleTyCon {}) = True
isGenInjAlgRhs (DataTyCon {}) = True
+isGenInjAlgRhs (DataFamilyTyCon {}) = False
isGenInjAlgRhs (AbstractTyCon distinct) = distinct
isGenInjAlgRhs (NewTyCon {}) = False
@@ -1471,7 +1409,8 @@ isTypeSynonymTyCon _ = False
-- right hand side to which a synonym family application can expand.
--
--- | True iff we can decompose (T a b c) into ((T a b) c)
+mightBeUnsaturatedTyCon :: TyCon -> Bool
+-- True iff we can decompose (T a b c) into ((T a b) c)
-- I.e. is it injective and generative w.r.t nominal equality?
-- That is, if (T a b) ~N d e f, is it always the case that
-- (T ~N d), (a ~N e) and (b ~N f)?
@@ -1480,9 +1419,8 @@ isTypeSynonymTyCon _ = False
-- It'd be unusual to call mightBeUnsaturatedTyCon on a regular H98
-- type synonym, because you should probably have expanded it first
-- But regardless, it's not decomposable
-mightBeUnsaturatedTyCon :: TyCon -> Bool
mightBeUnsaturatedTyCon (SynonymTyCon {}) = False
-mightBeUnsaturatedTyCon (FamilyTyCon { famTcFlav = flav}) = isDataFamFlav flav
+mightBeUnsaturatedTyCon (FamilyTyCon {}) = False
mightBeUnsaturatedTyCon _other = True
-- | Is this an algebraic 'TyCon' declared with the GADT syntax?
@@ -1502,26 +1440,21 @@ isEnumerationTyCon _ = False
-- | Is this a 'TyCon', synonym or otherwise, that defines a family?
isFamilyTyCon :: TyCon -> Bool
-isFamilyTyCon (FamilyTyCon {}) = True
-isFamilyTyCon _ = False
+isFamilyTyCon (FamilyTyCon {}) = True
+isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True
+isFamilyTyCon _ = False
-- | Is this a 'TyCon', synonym or otherwise, that defines a family with
-- instances?
isOpenFamilyTyCon :: TyCon -> Bool
-isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav })
- | OpenSynFamilyTyCon <- flav = True
- | DataFamilyTyCon {} <- flav = True
-isOpenFamilyTyCon _ = False
+isOpenFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True
+isOpenFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon }) = True
+isOpenFamilyTyCon _ = False
-- | Is this a synonym 'TyCon' that can have may have further instances appear?
isTypeFamilyTyCon :: TyCon -> Bool
-isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav)
-isTypeFamilyTyCon _ = False
-
--- | Is this a synonym 'TyCon' that can have may have further instances appear?
-isDataFamilyTyCon :: TyCon -> Bool
-isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav
-isDataFamilyTyCon _ = False
+isTypeFamilyTyCon (FamilyTyCon {}) = True
+isTypeFamilyTyCon _ = False
-- | Is this an open type family TyCon?
isOpenTypeFamilyTyCon :: TyCon -> Bool
@@ -1546,9 +1479,10 @@ isBuiltInSynFamTyCon_maybe
(FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops
isBuiltInSynFamTyCon_maybe _ = Nothing
-isDataFamFlav :: FamTyConFlav -> Bool
-isDataFamFlav (DataFamilyTyCon {}) = True -- Data family
-isDataFamFlav _ = False -- Type synonym family
+-- | Is this a synonym 'TyCon' that can have may have further instances appear?
+isDataFamilyTyCon :: TyCon -> Bool
+isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True
+isDataFamilyTyCon _ = False
-- | Are we able to extract information 'TyVar' to class argument list
-- mapping from a given 'TyCon'?
@@ -1556,8 +1490,9 @@ isTyConAssoc :: TyCon -> Bool
isTyConAssoc tc = isJust (tyConAssoc_maybe tc)
tyConAssoc_maybe :: TyCon -> Maybe Class
-tyConAssoc_maybe (FamilyTyCon { famTcParent = mb_cls }) = mb_cls
-tyConAssoc_maybe _ = Nothing
+tyConAssoc_maybe tc = case tyConParent tc of
+ AssocFamilyTyCon cls -> Just cls
+ _ -> Nothing
-- The unit tycon didn't used to be classed as a tuple tycon
-- but I thought that was silly so I've undone it
@@ -1596,19 +1531,14 @@ isRecursiveTyCon :: TyCon -> Bool
isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
isRecursiveTyCon _ = False
-promotableTyCon_maybe :: TyCon -> Promoted TyCon
+promotableTyCon_maybe :: TyCon -> Maybe TyCon
promotableTyCon_maybe (AlgTyCon { tcPromoted = prom }) = prom
-promotableTyCon_maybe _ = NotPromoted
-
-isPromotableTyCon :: TyCon -> Bool
-isPromotableTyCon tc = case promotableTyCon_maybe tc of
- Promoted {} -> True
- NotPromoted -> False
+promotableTyCon_maybe _ = Nothing
promoteTyCon :: TyCon -> TyCon
promoteTyCon tc = case promotableTyCon_maybe tc of
- Promoted prom_tc -> prom_tc
- NotPromoted -> pprPanic "promoteTyCon" (ppr tc)
+ Just prom_tc -> prom_tc
+ Nothing -> pprPanic "promoteTyCon" (ppr tc)
-- | Is this a PromotedTyCon?
isPromotedTyCon :: TyCon -> Bool
@@ -1650,10 +1580,13 @@ isImplicitTyCon (FunTyCon {}) = True
isImplicitTyCon (PrimTyCon {}) = True
isImplicitTyCon (PromotedDataCon {}) = True
isImplicitTyCon (PromotedTyCon {}) = True
-isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name })
+isImplicitTyCon (AlgTyCon { algTcRhs = rhs, algTcParent = parent, tyConName = name })
| TupleTyCon {} <- rhs = isWiredInName name
+ | AssocFamilyTyCon {} <- parent = True
+ | otherwise = False
+isImplicitTyCon (FamilyTyCon { famTcParent = parent })
+ | AssocFamilyTyCon {} <- parent = True
| otherwise = False
-isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent
isImplicitTyCon (SynonymTyCon {}) = False
tyConCType_maybe :: TyCon -> Maybe CType
@@ -1746,6 +1679,7 @@ tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs })
DataTyCon { data_cons = cons } -> length cons
NewTyCon {} -> 1
TupleTyCon {} -> 1
+ DataFamilyTyCon {} -> 0
_ -> pprPanic "tyConFamilySize 1" (ppr tc)
tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc)
@@ -1842,41 +1776,50 @@ famTyConFlav_maybe _ = Nothing
-- | Is this 'TyCon' that for a class instance?
isClassTyCon :: TyCon -> Bool
-isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True
-isClassTyCon _ = False
+isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True
+isClassTyCon _ = False
-- | If this 'TyCon' is that for a class instance, return the class it is for.
-- Otherwise returns @Nothing@
tyConClass_maybe :: TyCon -> Maybe Class
-tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas
-tyConClass_maybe _ = Nothing
+tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
+tyConClass_maybe _ = Nothing
+
+----------------------------------------------------------------------------
+tyConParent :: TyCon -> TyConParent
+tyConParent (AlgTyCon {algTcParent = parent}) = parent
+tyConParent (FamilyTyCon {famTcParent = parent}) = parent
+tyConParent _ = NoParentTyCon
----------------------------------------------------------------------------
-- | Is this 'TyCon' that for a data family instance?
isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} })
- = True
-isFamInstTyCon _ = False
+isFamInstTyCon tc = case tyConParent tc of
+ FamInstTyCon {} -> True
+ _ -> False
tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)
-tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts })
- = Just (f, ts, ax)
-tyConFamInstSig_maybe _ = Nothing
+tyConFamInstSig_maybe tc
+ = case tyConParent tc of
+ FamInstTyCon ax f ts -> Just (f, ts, ax)
+ _ -> Nothing
--- | If this 'TyCon' is that of a data family instance, return the family in question
+-- | If this 'TyCon' is that of a family instance, return the family in question
-- and the instance types. Otherwise, return @Nothing@
tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
-tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts })
- = Just (f, ts)
-tyConFamInst_maybe _ = Nothing
+tyConFamInst_maybe tc
+ = case tyConParent tc of
+ FamInstTyCon _ f ts -> Just (f, ts)
+ _ -> Nothing
--- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which
+-- | If this 'TyCon' is that of a family instance, return a 'TyCon' which
-- represents a coercion identifying the representation type with the type
-- instance family. Otherwise, return @Nothing@
tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)
-tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ })
- = Just ax
-tyConFamilyCoercion_maybe _ = Nothing
+tyConFamilyCoercion_maybe tc
+ = case tyConParent tc of
+ FamInstTyCon co _ _ -> Just co
+ _ -> Nothing
{-
************************************************************************
@@ -1912,17 +1855,16 @@ instance Outputable TyCon where
tyConFlavour :: TyCon -> String
tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs })
- | ClassTyCon _ _ <- parent = "class"
+ | ClassTyCon _ <- parent = "class"
| otherwise = case rhs of
TupleTyCon { tup_sort = sort }
| isBoxed (tupleSortBoxity sort) -> "tuple"
| otherwise -> "unboxed tuple"
DataTyCon {} -> "data type"
NewTyCon {} -> "newtype"
+ DataFamilyTyCon {} -> "data family"
AbstractTyCon {} -> "abstract type"
-tyConFlavour (FamilyTyCon { famTcFlav = flav })
- | isDataFamFlav flav = "data family"
- | otherwise = "type family"
+tyConFlavour (FamilyTyCon {}) = "type family"
tyConFlavour (SynonymTyCon {}) = "type synonym"
tyConFlavour (FunTyCon {}) = "built-in type"
tyConFlavour (PrimTyCon {}) = "built-in type"
@@ -1930,16 +1872,14 @@ tyConFlavour (PromotedDataCon {}) = "promoted data constructor"
tyConFlavour (PromotedTyCon {}) = "promoted type constructor"
pprPromotionQuote :: TyCon -> SDoc
--- Promoted data constructors already have a tick in their OccName
-pprPromotionQuote tc
- = case tc of
- PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types
-
- PromotedTyCon {} -> ifPprDebug (char '\'')
- -- However, we don't quote TyCons in kinds, except with -dppr-debug
- -- e.g. type family T a :: Bool -> *
- -- cf Trac #5952.
- _ -> empty
+pprPromotionQuote (PromotedDataCon {}) = char '\'' -- Quote promoted DataCons
+ -- in types
+pprPromotionQuote (PromotedTyCon {}) = ifPprDebug (char '\'')
+pprPromotionQuote _ = empty -- However, we don't quote TyCons
+ -- in kinds e.g.
+ -- type family T a :: Bool -> *
+ -- cf Trac #5952.
+ -- Except with -dppr-debug
instance NamedThing TyCon where
getName = tyConName
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 0c8ed35776..a2feeef723 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -30,7 +30,6 @@ module Type (
mkTyConApp, mkTyConTy,
tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole,
- splitTyConArgs,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
mkPiKinds, mkPiType, mkPiTypes,
@@ -596,14 +595,6 @@ nextRole ty
| otherwise
= Nominal
-splitTyConArgs :: TyCon -> [KindOrType] -> ([Kind], [Type])
--- Given a tycon app (T k1 .. kn t1 .. tm), split the kind and type args
--- TyCons always have prenex kinds
-splitTyConArgs tc kts
- = splitAtList kind_vars kts
- where
- (kind_vars, _) = splitForAllTys (tyConKind tc)
-
newTyConInstRhs :: TyCon -> [Type] -> Type
-- ^ Unwrap one 'layer' of newtype on a type constructor and its
-- arguments, using an eta-reduced version of the @newtype@ if possible.
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 5083804d6f..8946b6cf62 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -76,6 +76,7 @@ import Data.IORef
import Data.Char ( ord, chr )
import Data.Time
import Data.Typeable
+import Data.Typeable.Internal
import Control.Monad ( when )
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
@@ -553,14 +554,10 @@ instance Binary (Bin a) where
-- Instances for Data.Typeable stuff
instance Binary TyCon where
- put_ bh tc = do
- put_ bh (tyConPackage tc)
- put_ bh (tyConModule tc)
- put_ bh (tyConName tc)
+ put_ bh (TyCon _ p m n) = do
+ put_ bh (p,m,n)
get bh = do
- p <- get bh
- m <- get bh
- n <- get bh
+ (p,m,n) <- get bh
return (mkTyCon3 p m n)
instance Binary TypeRep where
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
index b69a773626..fc0192c744 100644
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ b/compiler/vectorise/Vectorise/Generic/PData.hs
@@ -59,7 +59,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
rec_flag -- FIXME: is this ok?
False -- Not promotable
False -- not GADT syntax
- (DataFamInstTyCon ax fam_tc pat_tys)
+ (FamInstTyCon ax fam_tc pat_tys)
; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }
where
tyvars = tyConTyVars vect_tc
@@ -79,7 +79,6 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
fam_envs <- readGEnv global_fam_inst_env
liftDs $ buildDataCon fam_envs dc_name
False -- not infix
- NotPromoted -- not promotable
(map (const no_bang) comp_tys)
(Just $ map (const HsLazy) comp_tys)
[] -- no field labels
@@ -122,7 +121,6 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
fam_envs <- readGEnv global_fam_inst_env
liftDs $ buildDataCon fam_envs dc_name
False -- not infix
- NotPromoted -- not promotable
(map (const no_bang) comp_tys)
(Just $ map (const HsLazy) comp_tys)
[] -- no field labels
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 8396e2cafa..47b1caa516 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -323,9 +323,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
addParallelTyConAndCons tycon
= do
{ addGlobalParallelTyCon tycon
- ; mapM_ addGlobalParallelVar [ id | dc <- tyConDataCons tycon
- , AnId id <- dataConImplicitTyThings dc ]
- -- Ignoring the promoted tycon; hope that's ok
+ ; mapM_ addGlobalParallelVar . concatMap dataConImplicitIds . tyConDataCons $ tycon
}
-- Add a mapping from the original to vectorised type constructor to the vectorisation map.
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 40f28d18d8..910aba473a 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -7,7 +7,6 @@ import Vectorise.Type.Type
import Vectorise.Monad
import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
import BuildTyCl( buildClass, buildDataCon )
-import OccName
import Class
import Type
import TyCon
@@ -99,7 +98,6 @@ vectTyConDecl tycon name'
gadt_flag = isGadtSyntaxTyCon tycon
-- build the vectorised type constructor
- ; tc_rep_name <- mkDerivedName mkTyConRepUserOcc name'
; return $ buildAlgTyCon
name' -- new name
(tyConTyVars tycon) -- keep original type vars
@@ -110,7 +108,7 @@ vectTyConDecl tycon name'
rec_flag -- whether recursive
False -- Not promotable
gadt_flag -- whether in GADT syntax
- (VanillaAlgTyCon tc_rep_name)
+ NoParentTyCon
}
-- some other crazy thing that we don't handle
@@ -137,6 +135,8 @@ vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
vectAlgTyConRhs tc (AbstractTyCon {})
= do dflags <- getDynFlags
cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)
+vectAlgTyConRhs _tc DataFamilyTyCon
+ = return DataFamilyTyCon
vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
, is_enum = is_enum
})
@@ -184,7 +184,6 @@ vectDataCon dc
; liftDs $ buildDataCon fam_envs
name'
(dataConIsInfix dc) -- infix if the original is
- NotPromoted -- Vectorised type is not promotable
(dataConSrcBangs dc) -- strictness as original constructor
(Just $ dataConImplBangs dc)
[] -- no labelled fields for now
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 1153afa414..736b8a957e 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1342,7 +1342,7 @@ defineMacro overwrite s = do
step <- getGhciStepIO
expr <- GHC.parseExpr definition
-- > ghciStepIO . definition :: String -> IO String
- let stringTy = nlHsTyVar stringTy_RDR
+ let stringTy = nlHsTyVar $ getRdrName stringTyConName
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr
tySig = stringTy `nlHsFunTy` ioM
@@ -1392,7 +1392,7 @@ cmdCmd str = handleSourceError GHC.printException $ do
getGhciStepIO :: GHCi (LHsExpr RdrName)
getGhciStepIO = do
ghciTyConName <- GHC.getGHCiMonad
- let stringTy = nlHsTyVar stringTy_RDR
+ let stringTy = nlHsTyVar $ getRdrName stringTyConName
ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar (getRdrName ghciStepIoMName)
diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs
index 1afc6a9563..c30a43dd65 100644
--- a/libraries/base/Data/Typeable.hs
+++ b/libraries/base/Data/Typeable.hs
@@ -58,7 +58,7 @@ module Data.Typeable
-- * A canonical proxy type
Proxy (..),
-
+
-- * Type representations
TypeRep, -- abstract, instance of: Eq, Show, Typeable
typeRepFingerprint,
@@ -66,7 +66,6 @@ module Data.Typeable
showsTypeRep,
TyCon, -- abstract, instance of: Eq, Show, Typeable
- -- For now don't export Module, to avoid name clashes
tyConFingerprint,
tyConString,
tyConPackage,
@@ -88,7 +87,7 @@ module Data.Typeable
typeRepArgs, -- :: TypeRep -> [TypeRep]
) where
-import Data.Typeable.Internal
+import Data.Typeable.Internal hiding (mkTyCon)
import Data.Type.Equality
import Unsafe.Coerce
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 4379155c57..e35d794a62 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -25,34 +25,15 @@
module Data.Typeable.Internal (
Proxy (..),
+ TypeRep(..),
+ KindRep,
Fingerprint(..),
-
- -- * Typeable class
typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7,
Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7,
-
- -- * Module
- Module, -- Abstract
- moduleName, modulePackage,
-
- -- * TyCon
- TyCon, -- Abstract
- tyConPackage, tyConModule, tyConName, tyConString, tyConFingerprint,
- mkTyCon3, mkTyCon3#,
- rnfTyCon,
-
- tcBool, tc'True, tc'False,
- tcOrdering, tc'LT, tc'EQ, tc'GT,
- tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun,
- tcIO, tcSPEC, tcTyCon, tcModule,
- tcCoercible, tcList, tcEq,
- tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK,
-
- funTc, -- ToDo
-
- -- * TypeRep
- TypeRep(..), KindRep,
+ TyCon(..),
typeRep,
+ mkTyCon,
+ mkTyCon3,
mkTyConApp,
mkPolyTyConApp,
mkAppTy,
@@ -66,15 +47,19 @@ module Data.Typeable.Internal (
typeRepFingerprint,
rnfTypeRep,
showsTypeRep,
+ tyConString,
+ rnfTyCon,
+ listTc, funTc,
typeRepKinds,
- typeSymbolTypeRep, typeNatTypeRep
+ typeNatTypeRep,
+ typeSymbolTypeRep
) where
import GHC.Base
import GHC.Word
import GHC.Show
+import GHC.TypeLits
import Data.Proxy
-import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' )
import GHC.Fingerprint.Type
import {-# SOURCE #-} GHC.Fingerprint
@@ -83,106 +68,9 @@ import {-# SOURCE #-} GHC.Fingerprint
-- of Data.Typeable as much as possible so we can optimise the derived
-- instances.
-#include "MachDeps.h"
-
-{- *********************************************************************
-* *
- The TyCon type
-* *
-********************************************************************* -}
-
-modulePackage :: Module -> String
-modulePackage (Module p _) = trNameString p
-
-moduleName :: Module -> String
-moduleName (Module _ m) = trNameString m
-
-tyConPackage :: TyCon -> String
-tyConPackage (TyCon _ _ m _) = modulePackage m
-
-tyConModule :: TyCon -> String
-tyConModule (TyCon _ _ m _) = moduleName m
-
-tyConName :: TyCon -> String
-tyConName (TyCon _ _ _ n) = trNameString n
-
-trNameString :: TrName -> String
-trNameString (TrNameS s) = unpackCString# s
-trNameString (TrNameD s) = s
-
--- | Observe string encoding of a type representation
-{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-}
--- deprecated in 7.4
-tyConString :: TyCon -> String
-tyConString = tyConName
-
-tyConFingerprint :: TyCon -> Fingerprint
-tyConFingerprint (TyCon hi lo _ _)
- = Fingerprint (W64# hi) (W64# lo)
-
-mkTyCon3# :: Addr# -- ^ package name
- -> Addr# -- ^ module name
- -> Addr# -- ^ the name of the type constructor
- -> TyCon -- ^ A unique 'TyCon' object
-mkTyCon3# pkg modl name
- | Fingerprint (W64# hi) (W64# lo) <- fingerprint
- = TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name)
- where
- fingerprint :: Fingerprint
- fingerprint = fingerprintString (unpackCString# pkg
- ++ (' ': unpackCString# modl)
- ++ (' ' : unpackCString# name))
-
-mkTyCon3 :: String -- ^ package name
- -> String -- ^ module name
- -> String -- ^ the name of the type constructor
- -> TyCon -- ^ A unique 'TyCon' object
--- Used when the strings are dynamically allocated,
--- eg from binary deserialisation
-mkTyCon3 pkg modl name
- | Fingerprint (W64# hi) (W64# lo) <- fingerprint
- = TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name)
- where
- fingerprint :: Fingerprint
- fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name))
-
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon tc
- | ('(':',':_) <- tyConName tc = True
- | otherwise = False
-
--- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
---
--- @since 4.8.0.0
-rnfModule :: Module -> ()
-rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m
-
-rnfTrName :: TrName -> ()
-rnfTrName (TrNameS _) = ()
-rnfTrName (TrNameD n) = rnfString n
-
-rnfTyCon :: TyCon -> ()
-rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n
-
-rnfString :: [Char] -> ()
-rnfString [] = ()
-rnfString (c:cs) = c `seq` rnfString cs
-
-
-{- *********************************************************************
-* *
- The TypeRep type
-* *
-********************************************************************* -}
-
--- | A concrete representation of a (monomorphic) type.
--- 'TypeRep' supports reasonably efficient equality.
+-- | A concrete representation of a (monomorphic) type. 'TypeRep'
+-- supports reasonably efficient equality.
data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep]
- -- NB: For now I've made this lazy so that it's easy to
- -- optimise code that constructs and deconstructs TypeReps
- -- perf/should_run/T9203 is a good example
- -- Also note that mkAppTy does discards the fingerprint,
- -- so it's a waste to compute it
type KindRep = TypeRep
@@ -193,42 +81,56 @@ instance Eq TypeRep where
instance Ord TypeRep where
TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y
--- | Observe the 'Fingerprint' of a type representation
---
--- @since 4.8.0.0
-typeRepFingerprint :: TypeRep -> Fingerprint
-typeRepFingerprint (TypeRep fpr _ _ _) = fpr
--- | Applies a kind-polymorphic type constructor to a sequence of kinds and
--- types
+-- | An abstract representation of a type constructor. 'TyCon' objects can
+-- be built using 'mkTyCon'.
+data TyCon = TyCon {
+ tyConFingerprint :: {-# UNPACK #-} !Fingerprint, -- ^ @since 4.8.0.0
+ tyConPackage :: String, -- ^ @since 4.5.0.0
+ tyConModule :: String, -- ^ @since 4.5.0.0
+ tyConName :: String -- ^ @since 4.5.0.0
+ }
+
+instance Eq TyCon where
+ (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
+
+instance Ord TyCon where
+ (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
+
+----------------- Construction --------------------
+
+#include "MachDeps.h"
+
+-- mkTyCon is an internal function to make it easier for GHC to
+-- generate derived instances. GHC precomputes the MD5 hash for the
+-- TyCon and passes it as two separate 64-bit values to mkTyCon. The
+-- TyCon for a derived Typeable instance will end up being statically
+-- allocated.
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon
+#endif
+mkTyCon high# low# pkg modl name
+ = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
+
+-- | Applies a polymorhic type constructor to a sequence of kinds and types
mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
-{-# INLINE mkPolyTyConApp #-}
-mkPolyTyConApp tc kinds types
- = TypeRep (fingerprintFingerprints sub_fps) tc kinds types
+mkPolyTyConApp tc@(TyCon tc_k _ _ _) [] [] = TypeRep tc_k tc [] []
+mkPolyTyConApp tc@(TyCon tc_k _ _ _) kinds types =
+ TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc kinds types
where
- !kt_fps = typeRepFingerprints kinds types
- sub_fps = tyConFingerprint tc : kt_fps
+ arg_ks = [ k | TypeRep k _ _ _ <- kinds ++ types ]
-typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint]
--- Builds no thunks
-typeRepFingerprints kinds types
- = go1 [] kinds
- where
- go1 acc [] = go2 acc types
- go1 acc (k:ks) = let !fp = typeRepFingerprint k
- in go1 (fp:acc) ks
- go2 acc [] = acc
- go2 acc (t:ts) = let !fp = typeRepFingerprint t
- in go2 (fp:acc) ts
-
--- | Applies a kind-monomorphic type constructor to a sequence of types
+-- | Applies a monomorphic type constructor to a sequence of types
mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
mkTyConApp tc = mkPolyTyConApp tc []
-- | A special case of 'mkTyConApp', which applies the function
-- type constructor to a pair of types.
mkFunTy :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = mkTyConApp tcFun [f,a]
+mkFunTy f a = mkTyConApp funTc [f,a]
-- | Splits a type constructor application.
-- Note that if the type construcotr is polymorphic, this will
@@ -248,12 +150,11 @@ splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,trs)
funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
funResultTy trFun trArg
= case splitTyConApp trFun of
- (tc, [t1,t2]) | tc == tcFun && t1 == trArg -> Just t2
+ (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
_ -> Nothing
-- | Adds a TypeRep argument to a TypeRep.
mkAppTy :: TypeRep -> TypeRep -> TypeRep
-{-# INLINE mkAppTy #-}
mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
-- Notice that we call mkTyConApp to construct the fingerprint from tc and
-- the arg fingerprints. Simply combining the current fingerprint with
@@ -261,6 +162,20 @@ mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr])
-- ensure that a TypeRep of the same shape has the same fingerprint!
-- See Trac #5962
+-- | Builds a 'TyCon' object representing a type constructor. An
+-- implementation of "Data.Typeable" should ensure that the following holds:
+--
+-- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
+--
+
+--
+mkTyCon3 :: String -- ^ package name
+ -> String -- ^ module name
+ -> String -- ^ the name of the type constructor
+ -> TyCon -- ^ A unique 'TyCon' object
+mkTyCon3 pkg modl name =
+ TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
+
----------------- Observation ---------------------
-- | Observe the type constructor of a type representation
@@ -275,12 +190,16 @@ typeRepArgs (TypeRep _ _ _ tys) = tys
typeRepKinds :: TypeRep -> [KindRep]
typeRepKinds (TypeRep _ _ ks _) = ks
+-- | Observe string encoding of a type representation
+{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} -- deprecated in 7.4
+tyConString :: TyCon -> String
+tyConString = tyConName
-{- *********************************************************************
-* *
- The Typeable class
-* *
-********************************************************************* -}
+-- | Observe the 'Fingerprint' of a type representation
+--
+-- @since 4.8.0.0
+typeRepFingerprint :: TypeRep -> Fingerprint
+typeRepFingerprint (TypeRep fpr _ _ _) = fpr
-------------------------------------------------------------
--
@@ -354,8 +273,8 @@ instance Show TypeRep where
showsPrec p (TypeRep _ tycon kinds tys) =
case tys of
[] -> showsPrec p tycon
- [x] | tycon == tcList -> showChar '[' . shows x . showChar ']'
- [a,r] | tycon == tcFun -> showParen (p > 8) $
+ [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
+ [a,r] | tycon == funTc -> showParen (p > 8) $
showsPrec 9 a .
showString " -> " .
showsPrec 8 r
@@ -369,6 +288,13 @@ instance Show TypeRep where
showsTypeRep :: TypeRep -> ShowS
showsTypeRep = shows
+instance Show TyCon where
+ showsPrec _ t = showString (tyConName t)
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
+isTupleTyCon _ = False
+
-- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation
--
-- @since 4.8.0.0
@@ -378,6 +304,15 @@ rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs
go [] = ()
go (x:xs) = rnfTypeRep x `seq` go xs
+-- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation
+--
+-- @since 4.8.0.0
+rnfTyCon :: TyCon -> ()
+rnfTyCon (TyCon _ tcp tcm tcn) = go tcp `seq` go tcm `seq` go tcn
+ where
+ go [] = ()
+ go (x:xs) = x `seq` go xs
+
-- Some (Show.TypeRep) helpers:
showArgs :: Show a => ShowS -> [a] -> ShowS
@@ -390,68 +325,13 @@ showTuple args = showChar '('
. showArgs (showChar ',') args
. showChar ')'
-{- *********************************************************
-* *
-* TyCon definitions for GHC.Types *
-* *
-********************************************************* -}
-
-mkGhcTypesTyCon :: Addr# -> TyCon
-{-# INLINE mkGhcTypesTyCon #-}
-mkGhcTypesTyCon name = mkTyCon3# "ghc-prim"# "GHC.Types"# name
-
-tcBool, tc'True, tc'False,
- tcOrdering, tc'GT, tc'EQ, tc'LT,
- tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun,
- tcIO, tcSPEC, tcTyCon, tcModule,
- tcCoercible, tcEq, tcList :: TyCon
-
-tcBool = mkGhcTypesTyCon "Bool"# -- Bool is promotable
-tc'True = mkGhcTypesTyCon "'True"#
-tc'False = mkGhcTypesTyCon "'False"#
-tcOrdering = mkGhcTypesTyCon "Ordering"# -- Ordering is promotable
-tc'GT = mkGhcTypesTyCon "'GT"#
-tc'EQ = mkGhcTypesTyCon "'EQ"#
-tc'LT = mkGhcTypesTyCon "'LT"#
-
--- None of the rest are promotable (see TysWiredIn)
-tcChar = mkGhcTypesTyCon "Char"#
-tcInt = mkGhcTypesTyCon "Int"#
-tcWord = mkGhcTypesTyCon "Word"#
-tcFloat = mkGhcTypesTyCon "Float"#
-tcDouble = mkGhcTypesTyCon "Double"#
-tcSPEC = mkGhcTypesTyCon "SPEC"#
-tcIO = mkGhcTypesTyCon "IO"#
-tcTyCon = mkGhcTypesTyCon "TyCon"#
-tcModule = mkGhcTypesTyCon "Module"#
-tcCoercible = mkGhcTypesTyCon "Coercible"#
-
-tcFun = mkGhcTypesTyCon "->"#
-tcList = mkGhcTypesTyCon "[]"# -- Type rep for the list type constructor
-tcEq = mkGhcTypesTyCon "~"# -- Type rep for the (~) type constructor
-
-tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK :: TyCon
-tcLiftedKind = mkGhcTypesTyCon "*"#
-tcUnliftedKind = mkGhcTypesTyCon "#"#
-tcOpenKind = mkGhcTypesTyCon "#"#
-tcBOX = mkGhcTypesTyCon "BOX"#
-tcAnyK = mkGhcTypesTyCon "AnyK"#
-tcConstraint = mkGhcTypesTyCon "Constraint"#
+listTc :: TyCon
+listTc = typeRepTyCon (typeOf [()])
funTc :: TyCon
-funTc = tcFun -- Legacy
-
-{- *********************************************************
-* *
-* TyCon/TypeRep definitions for type literals *
-* (Symbol and Nat) *
-* *
-********************************************************* -}
+funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
-mkTypeLitTyCon :: String -> TyCon
-mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name
-
-- | Used to make `'Typeable' instance for things of kind Nat
typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
typeNatTypeRep p = typeLitTypeRep (show (natVal' p))
@@ -462,5 +342,17 @@ typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p))
-- | An internal function, to make representations for type literals.
typeLitTypeRep :: String -> TypeRep
-typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) []
+typeLitTypeRep nm = rep
+ where
+ rep = mkTyConApp tc []
+ tc = TyCon
+ { tyConFingerprint = fingerprintString (mk pack modu nm)
+ , tyConPackage = pack
+ , tyConModule = modu
+ , tyConName = nm
+ }
+ pack = "base"
+ modu = "GHC.TypeLits"
+ mk a b c = a ++ " " ++ b ++ " " ++ c
+
diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs
index 879d666bb0..4aeecb15f3 100644
--- a/libraries/base/GHC/Show.hs
+++ b/libraries/base/GHC/Show.hs
@@ -194,16 +194,6 @@ showWord w# cs
deriving instance Show a => Show (Maybe a)
-instance Show TyCon where
- showsPrec p (TyCon _ _ _ tc_name) = showsPrec p tc_name
-
-instance Show TrName where
- showsPrec _ (TrNameS s) = showString (unpackCString# s)
- showsPrec _ (TrNameD s) = showString s
-
-instance Show Module where
- showsPrec _ (Module p m) = shows p . (':' :) . shows m
-
--------------------------------------------------------------
-- Show instances for the first few tuple
--------------------------------------------------------------
diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs
index d3ea1d2147..5c37f64713 100644
--- a/libraries/base/GHC/Stack/Types.hs
+++ b/libraries/base/GHC/Stack/Types.hs
@@ -21,19 +21,6 @@ module GHC.Stack.Types (
SrcLoc(..), CallStack(..),
) where
-{-
-Ideally these would live in GHC.Stack but sadly they can't due to this
-import cycle,
-
- Module imports form a cycle:
- module ‘Data.Maybe’ (libraries/base/Data/Maybe.hs)
- imports ‘GHC.Base’ (libraries/base/GHC/Base.hs)
- which imports ‘GHC.Err’ (libraries/base/GHC/Err.hs)
- which imports ‘GHC.Stack’ (libraries/base/dist-install/build/GHC/Stack.hs)
- which imports ‘GHC.Foreign’ (libraries/base/GHC/Foreign.hs)
- which imports ‘Data.Maybe’ (libraries/base/Data/Maybe.hs)
--}
-
import GHC.Types
-- Make implicit dependency known to build system
diff --git a/libraries/ghc-prim/GHC/Classes.hs b/libraries/ghc-prim/GHC/Classes.hs
index 12fe65f322..18662ad539 100644
--- a/libraries/ghc-prim/GHC/Classes.hs
+++ b/libraries/ghc-prim/GHC/Classes.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, Trustworthy #-}
+{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving, BangPatterns,
KindSignatures, DataKinds, ConstraintKinds,
MultiParamTypeClasses, FunctionalDependencies #-}
@@ -28,28 +28,19 @@
-----------------------------------------------------------------------------
module GHC.Classes(
- -- * Implicit paramaters
IP(..),
-
- -- * Equality and ordering
Eq(..), eqInt, neInt,
Ord(..), gtInt, geInt, leInt, ltInt, compareInt, compareInt#,
-
- -- * Functions over Bool
(&&), (||), not,
-
- -- * Integer arithmetic
divInt#, modInt#
) where
-- GHC.Magic is used in some derived instances
import GHC.Magic ()
-import GHC.IntWord64
import GHC.Prim
import GHC.Tuple
import GHC.Types
-#include "MachDeps.h"
infix 4 ==, /=, <, <=, >=, >
infixr 3 &&
@@ -146,31 +137,6 @@ eqInt, neInt :: Int -> Int -> Bool
(I# x) `eqInt` (I# y) = isTrue# (x ==# y)
(I# x) `neInt` (I# y) = isTrue# (x /=# y)
-#if WORD_SIZE_IN_BITS < 64
-instance Eq TyCon where
- (==) (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _)
- = isTrue# (hi1 `eqWord64#` hi2) && isTrue# (lo1 `eqWord64#` lo2)
-instance Ord TyCon where
- compare (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _)
- | isTrue# (hi1 `gtWord64#` hi2) = GT
- | isTrue# (hi1 `ltWord64#` hi2) = LT
- | isTrue# (lo1 `gtWord64#` lo2) = GT
- | isTrue# (lo1 `ltWord64#` lo2) = LT
- | True = EQ
-#else
-instance Eq TyCon where
- (==) (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _)
- = isTrue# (hi1 `eqWord#` hi2) && isTrue# (lo1 `eqWord#` lo2)
-instance Ord TyCon where
- compare (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _)
- | isTrue# (hi1 `gtWord#` hi2) = GT
- | isTrue# (hi1 `ltWord#` hi2) = LT
- | isTrue# (lo1 `gtWord#` lo2) = GT
- | isTrue# (lo1 `ltWord#` lo2) = LT
- | True = EQ
-#endif
-
-
-- | The 'Ord' class is used for totally ordered datatypes.
--
-- Instances of 'Ord' can be derived for any user-defined
diff --git a/libraries/ghc-prim/GHC/Magic.hs b/libraries/ghc-prim/GHC/Magic.hs
index 740abb729e..22db69f2ae 100644
--- a/libraries/ghc-prim/GHC/Magic.hs
+++ b/libraries/ghc-prim/GHC/Magic.hs
@@ -19,8 +19,6 @@
module GHC.Magic ( inline, lazy, oneShot ) where
-import GHC.CString ()
-
-- | The call @inline f@ arranges that 'f' is inlined, regardless of
-- its size. More precisely, the call @inline f@ rewrites to the
-- right-hand side of @f@'s definition. This allows the programmer to
diff --git a/libraries/ghc-prim/GHC/Tuple.hs b/libraries/ghc-prim/GHC/Tuple.hs
index b08d0b4fee..4ebda15d84 100644
--- a/libraries/ghc-prim/GHC/Tuple.hs
+++ b/libraries/ghc-prim/GHC/Tuple.hs
@@ -16,9 +16,6 @@
module GHC.Tuple where
-import GHC.CString () -- Make sure we do it first, so that the
- -- implicit Typeable stuff can see GHC.Types.TyCon
- -- and unpackCString# etc
default () -- Double and Integer aren't available yet
diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs
index 63b4f0508f..294f15e6e4 100644
--- a/libraries/ghc-prim/GHC/Types.hs
+++ b/libraries/ghc-prim/GHC/Types.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples,
- MultiParamTypeClasses, RoleAnnotations, CPP #-}
+ MultiParamTypeClasses, RoleAnnotations #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Types
@@ -29,12 +29,11 @@ module GHC.Types (
isTrue#,
SPEC(..),
Nat, Symbol,
- Coercible,
- -- * Runtime type representation
- Module(..), TrName(..), TyCon(..)
+ Coercible
) where
import GHC.Prim
+import GHC.Tuple ()
infixr 5 :
@@ -309,56 +308,3 @@ you're reading this in 2023 then things went wrong). See #8326.
-- Libraries can specify this by using 'SPEC' data type to inform which
-- loops should be aggressively specialized.
data SPEC = SPEC | SPEC2
-
-{- *********************************************************************
-* *
- Runtime represntation of TyCon
-* *
-********************************************************************* -}
-
-{- Note [Runtime representation of modules and tycons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We generate a binding for M.$modName and M.$tcT for every module M and
-data type T. Things to think about
-
- - We want them to be economical on space; ideally pure data with no thunks.
-
- - We do this for every module (except this module GHC.Types), so we can't
- depend on anything else (eg string unpacking code)
-
-That's why we have these terribly low-level repesentations. The TrName
-type lets us use the TrNameS constructor when allocating static data;
-but we also need TrNameD for the case where we are deserialising a TyCon
-or Module (for example when deserialising a TypeRep), in which case we
-can't conveniently come up with an Addr#.
-
-
-Note [Representations of types defined in GHC.Types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The representations for the types defined in GHC.Types are
-defined in GHC.Typeable.Internal.
-
--}
-
-#include "MachDeps.h"
-
-data Module = Module
- TrName -- Package name
- TrName -- Module name
-
-data TrName
- = TrNameS Addr# -- Static
- | TrNameD [Char] -- Dynamic
-
-#if WORD_SIZE_IN_BITS < 64
-data TyCon = TyCon
- Word64# Word64# -- Fingerprint
- Module -- Module in which this is defined
- TrName -- Type constructor name
-#else
-data TyCon = TyCon
- Word# Word#
- Module
- TrName
-#endif
diff --git a/testsuite/tests/codeGen/should_run/cgrun057.stderr b/testsuite/tests/codeGen/should_run/cgrun057.stderr
index 262d74912d..64a4028b02 100644
--- a/testsuite/tests/codeGen/should_run/cgrun057.stderr
+++ b/testsuite/tests/codeGen/should_run/cgrun057.stderr
@@ -1,4 +1,4 @@
-*** Exception (reporting due to +RTS -xc): (THUNK_2_0), stack trace:
+*** Exception (reporting due to +RTS -xc): (THUNK_1_0), stack trace:
Main.g,
called from Main.f,
called from Main.main,
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index b4aa53d787..cd14bd1754 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -1,6 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 27, types: 24, coercions: 1}
+Result size of Tidy Core = {terms: 8, types: 19, coercions: 1}
-- RHS size: {terms: 2, types: 3, coercions: 1}
T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a
@@ -13,35 +13,10 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a
Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a)}]
T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a)
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a1 :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a1 = TrNameS "T2431"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T2431.$trModule :: Module
-[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType]
-T2431.$trModule = Module a a1
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a2 :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a2 = TrNameS ":~:"#
-
--- RHS size: {terms: 5, types: 0, coercions: 0}
-T2431.$tc:~: :: TyCon
-[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType]
-T2431.$tc:~: = TyCon 0## 0## T2431.$trModule a2
-
-- RHS size: {terms: 4, types: 7, coercions: 0}
absurd :: forall a. Int :~: Bool -> a
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>b]
-absurd = \ (@ a3) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
+absurd = \ (@ a) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { }
diff --git a/testsuite/tests/deriving/should_fail/T9687.stderr b/testsuite/tests/deriving/should_fail/T9687.stderr
index 36425e48c8..ad95393db7 100644
--- a/testsuite/tests/deriving/should_fail/T9687.stderr
+++ b/testsuite/tests/deriving/should_fail/T9687.stderr
@@ -1,3 +1,3 @@
-T9687.hs:4:10: error:
- Class ‘Typeable’ does not support user-specified instances
+T9687.hs:4:10:
+ Class `Typeable` does not support user-specified instances.
diff --git a/testsuite/tests/ghci.debugger/scripts/T2740.stdout b/testsuite/tests/ghci.debugger/scripts/T2740.stdout
index 1f3e6d9ac5..c6733bca9d 100644
--- a/testsuite/tests/ghci.debugger/scripts/T2740.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/T2740.stdout
@@ -1,5 +1,5 @@
Stopped at T2740.hs:(3,1)-(4,25)
-_result :: a2 = _
+_result :: a = _
Stopped at T2740.hs:3:11-13
_result :: Bool = _
x :: Integer = 1
diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr
index 56f40f2b21..b6e3cc9b12 100644
--- a/testsuite/tests/ghci.debugger/scripts/break006.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr
@@ -12,7 +12,7 @@
Show (f a) =>
Show (Alt f a)
-- Defined in ‘Data.Monoid’
- ...plus 36 others
+ ...plus 33 others
(use -fprint-potential-instances to see them all)
In a stmt of an interactive GHCi command: print it
@@ -29,6 +29,6 @@
Show (f a) =>
Show (Alt f a)
-- Defined in ‘Data.Monoid’
- ...plus 36 others
+ ...plus 33 others
(use -fprint-potential-instances to see them all)
In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci.debugger/scripts/break009.stdout b/testsuite/tests/ghci.debugger/scripts/break009.stdout
index 14543668a1..b926ed2474 100644
--- a/testsuite/tests/ghci.debugger/scripts/break009.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break009.stdout
@@ -1,6 +1,6 @@
Breakpoint 0 activated at ../Test6.hs:5:8-11
Stopped at ../Test6.hs:5:8-11
-_result :: a2 = _
+_result :: a = _
*** Exception: Prelude.head: empty list
CallStack:
- error, called at libraries/base/GHC/List.hs:999:3 in base:GHC.List
+ error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List
diff --git a/testsuite/tests/ghci.debugger/scripts/break010.stdout b/testsuite/tests/ghci.debugger/scripts/break010.stdout
index 682f4c3c1c..2751b6d160 100644
--- a/testsuite/tests/ghci.debugger/scripts/break010.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break010.stdout
@@ -1,5 +1,5 @@
Breakpoint 0 activated at ../Test6.hs:5:8-11
Stopped at ../Test6.hs:5:8-11
-_result :: a2 = _
+_result :: a = _
Stopped at ../Test6.hs:5:8-11
-_result :: a2 = _
+_result :: a = _
diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout
index 67bbec7ce1..dafc1fc397 100644
--- a/testsuite/tests/ghci.debugger/scripts/break011.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout
@@ -9,12 +9,12 @@ _exception :: e = _
-2 : main (../Test7.hs:2:8-29)
<end of history>
Logged breakpoint at ../Test7.hs:2:18-28
-_result :: a14
+_result :: a12
Logged breakpoint at ../Test7.hs:2:8-29
-_result :: IO a14
+_result :: IO a12
no more logged breakpoints
Logged breakpoint at ../Test7.hs:2:18-28
-_result :: a14
+_result :: a12
Stopped at <exception thrown>
_exception :: e
already at the beginning of the history
@@ -23,7 +23,7 @@ _exception = SomeException
"foo"
"CallStack:
error, called at ../Test7.hs:2:18 in main:Main")
-_result :: a14 = _
+_result :: a12 = _
_exception :: SomeException = SomeException
(ErrorCallWithLocation
"foo"
diff --git a/testsuite/tests/ghci.debugger/scripts/break012.stdout b/testsuite/tests/ghci.debugger/scripts/break012.stdout
index 88e8b3ee71..70fa0f37b9 100644
--- a/testsuite/tests/ghci.debugger/scripts/break012.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break012.stdout
@@ -1,16 +1,16 @@
Stopped at break012.hs:(1,1)-(5,18)
-_result :: (t, a3 -> a3, (), a2 -> a2 -> a2) = _
+_result :: (t, a1 -> a1, (), a -> a -> a) = _
Stopped at break012.hs:5:10-18
-_result :: (t, a3 -> a3, (), a2 -> a2 -> a2) = _
+_result :: (t, a1 -> a1, (), a -> a -> a) = _
a :: t = _
-b :: a4 -> a4 = _
+b :: a2 -> a2 = _
c :: () = _
-d :: a2 -> a2 -> a2 = _
+d :: a -> a -> a = _
a :: t
-b :: a4 -> a4
+b :: a2 -> a2
c :: ()
-d :: a2 -> a2 -> a2
+d :: a -> a -> a
a = (_t1::t)
-b = (_t2::a4 -> a4)
+b = (_t2::a2 -> a2)
c = (_t3::())
-d = (_t4::a2 -> a2 -> a2)
+d = (_t4::a -> a -> a)
diff --git a/testsuite/tests/ghci.debugger/scripts/break018.stdout b/testsuite/tests/ghci.debugger/scripts/break018.stdout
index 11ef5476b5..a12e119a42 100644
--- a/testsuite/tests/ghci.debugger/scripts/break018.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break018.stdout
@@ -1,5 +1,5 @@
Stopped at ../mdo.hs:(30,1)-(32,27)
-_result :: IO (N a6) = _
+_result :: IO (N a) = _
Stopped at ../mdo.hs:(30,16)-(32,27)
_result :: IO (N Char) = _
x :: Char = 'h'
@@ -10,4 +10,4 @@ f :: N Char = _
l :: N Char = _
x :: Char = 'h'
Stopped at ../mdo.hs:(8,1)-(9,42)
-_result :: IO (N a6) = _
+_result :: IO (N a) = _
diff --git a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout
index a87ffce942..99ac58dec2 100644
--- a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout
@@ -1,6 +1,6 @@
Breakpoint 0 activated at A.hs:4:1-9
Stopped at A.hs:4:1-9
-_result :: a3 = _
+_result :: a1 = _
Stopped at A.hs:4:7-9
_result :: () = _
x :: () = ()
diff --git a/testsuite/tests/ghci.debugger/scripts/break028.stdout b/testsuite/tests/ghci.debugger/scripts/break028.stdout
index 896a2416ef..2438d73a14 100644
--- a/testsuite/tests/ghci.debugger/scripts/break028.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break028.stdout
@@ -1,5 +1,5 @@
Stopped at break028.hs:15:1-24
-_result :: Id a3 = _
+_result :: Id a = _
Stopped at break028.hs:15:23-24
-_result :: Id a3 = _
-x' :: Id a3 = _
+_result :: Id a = _
+x' :: Id a = _
diff --git a/testsuite/tests/ghci.debugger/scripts/print018.stdout b/testsuite/tests/ghci.debugger/scripts/print018.stdout
index a00d5374dd..d5b7d4603c 100644
--- a/testsuite/tests/ghci.debugger/scripts/print018.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/print018.stdout
@@ -3,9 +3,9 @@ Stopped at ../Test.hs:40:1-17
_result :: () = _
Stopped at ../Test.hs:40:10-17
_result :: () = _
-x :: a36 = _
-x = (_t1::a36)
-x :: a36
+x :: a17 = _
+x = (_t1::a17)
+x :: a17
()
x = Unary
x :: Unary
diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr
index 3c0edbde5a..894c553805 100644
--- a/testsuite/tests/ghci.debugger/scripts/print019.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr
@@ -5,9 +5,9 @@
Use :print or :force to determine these types
Relevant bindings include it :: a1 (bound at <interactive>:10:1)
These potential instances exist:
+ instance Show TyCon -- Defined in ‘Data.Typeable.Internal’
instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’
- instance Show Module -- Defined in ‘GHC.Show’
instance Show Ordering -- Defined in ‘GHC.Show’
- ...plus 32 others
+ ...plus 30 others
(use -fprint-potential-instances to see them all)
In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci.debugger/scripts/print031.stdout b/testsuite/tests/ghci.debugger/scripts/print031.stdout
index da3e14238d..529b6987b5 100644
--- a/testsuite/tests/ghci.debugger/scripts/print031.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/print031.stdout
@@ -4,5 +4,5 @@ Stopped at print031.hs:7:1-19
_result :: Bool = _
Stopped at print031.hs:7:7-19
_result :: Bool = _
-x :: t (Phantom a5) = [Just (Phantom 1)]
+x :: t (Phantom a) = [Just (Phantom 1)]
x = [Just (Phantom 1)]
diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout
index cea9a01264..7c063a6481 100644
--- a/testsuite/tests/ghci/scripts/T4175.stdout
+++ b/testsuite/tests/ghci/scripts/T4175.stdout
@@ -2,7 +2,9 @@ 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 = a -- Defined at T4175.hs:9:1
type instance A Int Int = () -- Defined at T4175.hs:8:1
-data family B a -- Defined at T4175.hs:12: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 () = MkB -- Defined at T4175.hs:13:15
type instance A (B a) b = () -- Defined at T4175.hs:10:1
diff --git a/testsuite/tests/ghci/scripts/T5417.stdout b/testsuite/tests/ghci/scripts/T5417.stdout
index 06329d9a1d..2640c4e04c 100644
--- a/testsuite/tests/ghci/scripts/T5417.stdout
+++ b/testsuite/tests/ghci/scripts/T5417.stdout
@@ -1,7 +1,9 @@
-data B1 a = B1 a
-data instance C.F (B1 a) = B2 a
-data family D a
-class C.C1 a where
- data family C.F a
- -- Defined at T5417a.hs:5:5
-data instance C.F (B1 a) = B2 a -- Defined at T5417.hs:8:10
+data B1 a = B1 a
+data instance C.F (B1 a) = B2 a
+type role D nominal
+data family D a
+class C.C1 a where
+ type role C.F nominal
+ data family C.F a
+ -- Defined at T5417a.hs:5:5
+data instance C.F (B1 a) = B2 a -- Defined at T5417.hs:8:10
diff --git a/testsuite/tests/ghci/scripts/T8674.stdout b/testsuite/tests/ghci/scripts/T8674.stdout
index 45d4f0af0e..6c13176e66 100644
--- a/testsuite/tests/ghci/scripts/T8674.stdout
+++ b/testsuite/tests/ghci/scripts/T8674.stdout
@@ -1,3 +1,5 @@
-data family Sing (a :: k) -- Defined at T8674.hs:4:1
+type role Sing nominal
+data family Sing (a :: k)
+ -- Defined at T8674.hs:4:1
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/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr
index 57e8b0d397..2d2187c5a7 100644
--- a/testsuite/tests/indexed-types/should_compile/T3017.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr
@@ -1,21 +1,21 @@
-TYPE SIGNATURES
- emptyL :: forall a. ListColl a
- test2 ::
- forall c t t1. (Num t, Num t1, Coll c, Elem c ~ (t, t1)) => c -> c
-TYPE CONSTRUCTORS
- class Coll c where
- type family Elem c :: * open
- empty :: c
- insert :: Elem c -> c -> c
- {-# MINIMAL empty, insert #-}
- 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)
-Dependent modules: []
-Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
- integer-gmp-1.0.0.0]
+TYPE SIGNATURES
+ emptyL :: forall a. ListColl a
+ test2 ::
+ forall c t t1. (Num t, Num t1, Coll c, Elem c ~ (t, t1)) => c -> c
+TYPE CONSTRUCTORS
+ class Coll c where
+ type family Elem c :: * open
+ empty :: c
+ insert :: Elem c -> c -> c
+ {-# MINIMAL empty, insert #-}
+ 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)
+Dependent modules: []
+Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
+ integer-gmp-1.0.0.0]
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index c9d744d6be..6d4b412ba7 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -1,33 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 32, types: 17, coercions: 0}
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7116.$trModule2 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T7116.$trModule2 = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7116.$trModule1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T7116.$trModule1 = TrNameS "T7116"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T7116.$trModule :: Module
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T7116.$trModule = Module T7116.$trModule2 T7116.$trModule1
+Result size of Tidy Core = {terms: 22, types: 14, coercions: 0}
-- RHS size: {terms: 8, types: 3, coercions: 0}
dr :: Double -> Double
diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
index dbc250d794..7faa9207a4 100644
--- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
+++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
@@ -5,9 +5,9 @@ overloadedlistsfail01.hs:5:8: error:
Probable fix: use a type annotation to specify what ‘a0’ should be.
These potential instances exist:
instance [safe] Show Version -- Defined in ‘Data.Version’
- instance Show Module -- Defined in ‘GHC.Show’
instance Show Ordering -- Defined in ‘GHC.Show’
- ...plus 26 others
+ instance Show Integer -- Defined in ‘GHC.Show’
+ ...plus 23 others
(use -fprint-potential-instances to see them all)
In the expression: print [1]
In an equation for ‘main’: main = print [1]
diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
index c2768c4d37..6ca37a9434 100644
--- a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
@@ -3,7 +3,9 @@ TYPE SIGNATURES
TYPE CONSTRUCTORS
data MyKind = A | B
Promotable
+ type role Sing nominal
data family Sing (a :: k)
+ RecFlag: Recursive
COERCION AXIOMS
axiom DataFamilyInstanceLHS.TFCo:R:SingMyKind_ ::
Sing = DataFamilyInstanceLHS.R:SingMyKind_
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 2bd38f8b09..9eb2d20aaa 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -37,7 +37,7 @@ test('T1969',
# 2013-02-10 14 (x86/OSX)
# 2013-11-13 17 (x86/Windows, 64bit machine)
# 2015-07-11 21 (x86/Linux, 64bit machine) use +RTS -G1
- (wordsize(64), 55, 20)]),
+ (wordsize(64), 41, 20)]),
# 28 (amd64/Linux)
# 34 (amd64/Linux)
# 2012-09-20 23 (amd64/Linux)
@@ -48,7 +48,6 @@ test('T1969',
# 2013-09-11 30, 10 (amd64/Linux)
# 2013-09-11 30, 15 (adapt to Phab CI)
# 2015-06-03 41, (amd64/Linux) use +RTS -G1
- # 2015-10-28 55, (amd64/Linux) emit Typeable at definition site
compiler_stats_num_field('max_bytes_used',
[(platform('i386-unknown-mingw32'), 5719436, 20),
# 2010-05-17 5717704 (x86/Windows)
@@ -62,7 +61,7 @@ test('T1969',
# 2014-01-22 6429864 (x86/Linux)
# 2014-06-29 5949188 (x86/Linux)
# 2015-07-11 6241108 (x86/Linux, 64bit machine) use +RTS -G1
- (wordsize(64), 15017528, 15)]),
+ (wordsize(64), 11000000, 15)]),
# 2014-09-10 10463640, 10 # post-AMP-update (somewhat stabelish)
# looks like the peak is around ~10M, but we're
# unlikely to GC exactly on the peak.
@@ -72,7 +71,6 @@ test('T1969',
# 2014-09-14 9684256, 10 # try to lower it a bit more to match Phab's CI
# 2014-11-03 10584344, # ghcspeed reports higher numbers consistently
# 2015-07-11 11670120 (amd64/Linux)
- # 2015-10-28 15017528 (amd64/Linux) emit typeable at definition site
compiler_stats_num_field('bytes allocated',
[(platform('i386-unknown-mingw32'), 301784492, 5),
# 215582916 (x86/Windows)
@@ -88,7 +86,7 @@ test('T1969',
# 2014-01-22 316103268 (x86/Linux)
# 2014-06-29 303300692 (x86/Linux)
# 2015-07-11 288699104 (x86/Linux, 64-bit machine) use +RTS -G1
- (wordsize(64), 737455896, 5)]),
+ (wordsize(64), 581460896, 5)]),
# 17/11/2009 434845560 (amd64/Linux)
# 08/12/2009 459776680 (amd64/Linux)
# 17/05/2010 519377728 (amd64/Linux)
@@ -107,7 +105,6 @@ test('T1969',
# 17/07/2014 651626680 (x86_64/Linux) roundabout update
# 10/09/2014 630299456 (x86_64/Linux) post-AMP-cleanup
# 03/06/2015 581460896 (x86_64/Linux) use +RTS -G1
- # 28/10/2015 737455896 (x86_64/Linux) emit Typeable at definition site
only_ways(['normal']),
extra_hc_opts('-dcore-lint -static'),
@@ -145,7 +142,7 @@ test('T3294',
# 2014-12-22 26525384 (x86/Windows) Increase due to silent superclasses?
# 2015-07-11 43196344 (x86/Linux, 64-bit machine) use +RTS -G1
- (wordsize(64), 96127384, 20)]),
+ (wordsize(64), 45000000, 20)]),
# prev: 25753192 (amd64/Linux)
# 29/08/2012: 37724352 (amd64/Linux)
# (increase due to new codegen, see #7198)
@@ -159,9 +156,6 @@ test('T3294',
# (reason unknown, setting expected value somewhere in between)
# 2015-01-22: 45000000 (amd64/Linux)
# varies between 40959592 and 52914488... increasing to +-20%
- # 2015-10-28: 96127384 (amd64/Linux)
- # D757: emit Typeable instances at site of type definition
- # Opened #11030 to track this surprisingly large regression
compiler_stats_num_field('bytes allocated',
[(wordsize(32), 1377050640, 5),
@@ -221,13 +215,12 @@ test('T4801',
# 2014-01-22: 211198056 (x86/Linux)
# 2014-09-03: 185242032 (Windows laptop)
# 2014-12-01: 203962148 (Windows laptop)
- (wordsize(64), 434278248, 10)]),
+ (wordsize(64), 382056344, 10)]),
# prev: 360243576 (amd64/Linux)
# 19/10/2012: 447190832 (amd64/Linux) (-fPIC turned on)
# 19/10/2012: 392409984 (amd64/Linux) (-fPIC turned off)
# 2014-04-08: 362939272 (amd64/Linux) cumulation of various smaller improvements over recent commits
# 2014-10-08: 382056344 (amd64/Linux) stricter foldr2 488e95b
- # 2015-10-28: 434278248 (amd64/Linux) emit Typeable at definition site
###################################
# deactivated for now, as this metric became too volatile recently
@@ -423,7 +416,7 @@ test('T783',
# 2014-09-03: 223377364 (Windows) better specialisation, raft of core-to-core optimisations
# 2014-12-22: 235002220 (Windows) not sure why
- (wordsize(64), 526230456, 10)]),
+ (wordsize(64), 470738808, 10)]),
# prev: 349263216 (amd64/Linux)
# 07/08/2012: 384479856 (amd64/Linux)
# 29/08/2012: 436927840 (amd64/Linux)
@@ -436,18 +429,16 @@ test('T783',
# (fix previous fix for #8456)
# 2014-07-17: 640031840 (amd64/Linux)
# (general round of updates)
- # 2014-08-29: 441932632 (amd64/Linux)
+ # 2014-08-29: 441932632 (amd64/Linux)
# (better specialisation, raft of core-to-core optimisations)
- # 2014-08-29: 719814352 (amd64/Linux)
- # (changed order of cmm block causes analyses to allocate much more,
- # but the changed order is slighly better in terms of runtime, and
- # this test seems to be an extreme outlier.)
- # 2015-05-16: 548288760 (amd64/Linux)
- # (improved sequenceBlocks in nativeCodeGen, #10422)
- # 2015-08-07: 470738808 (amd64/Linux)
- # (simplifying the switch plan code path for simple checks, #10677)
- # 2015-08-28: 526230456 (amd64/Linux)
- # (D757: Emit Typeable instances at site of type definition)
+ # 2014-08-29: 719814352 (amd64/Linux)
+ # (changed order of cmm block causes analyses to allocate much more,
+ # but the changed order is slighly better in terms of runtime, and
+ # this test seems to be an extreme outlier.)
+ # 2015-05-16: 548288760 (amd64/Linux)
+ # (improved sequenceBlocks in nativeCodeGen, #10422)
+ # 2015-08-07: 470738808 (amd64/Linux)
+ # (simplifying the switch plan code path for simple checks, #10677)
extra_hc_opts('-static')
],
compile,[''])
@@ -486,7 +477,7 @@ test('T5321FD',
# (increase due to new codegen)
# 2014-07-31: 211699816 (Windows) (-11%)
# (due to better optCoercion, 5e7406d9, #9233)
- (wordsize(64), 532365376, 10)])
+ (wordsize(64), 470895536, 10)])
# prev: 418306336
# 29/08/2012: 492905640
# (increase due to new codegen)
@@ -503,8 +494,6 @@ test('T5321FD',
# 2015-08-10: 470895536
# (undefined now takes an implicit parameter and GHC -O0 does
# not recognize that the application is bottom)
- # 2015-10-28: 532365376
- # D757: emit Typeable instances at site of type definition
],
compile,[''])
@@ -517,7 +506,7 @@ test('T5642',
# 2014-09-03: 753045568
# 2014-12-10: 641085256 Improvements in constraints solver
- (wordsize(64), 1412808976, 10)])
+ (wordsize(64), 1282916024, 10)])
# prev: 1300000000
# 2014-07-17: 1358833928 (general round of updates)
# 2014-08-07: 1402242360 (caused by 1fc60ea)
@@ -528,7 +517,6 @@ test('T5642',
# It's a bizarre program with LOTS of data types)
# 2014-09-10: 1536924976 post-AMP-cleanup
# 2014-12-10: 1282916024 Improvements in constraints solver
- # 2015-10-28: 1412808976 Emit Typeable at definition site
],
compile,['-O'])
@@ -623,9 +611,8 @@ test('T9675',
# 2015-07-11 56 (x86/Linux, 64-bit machine) use +RTS -G1
]),
compiler_stats_num_field('bytes allocated',
- [(wordsize(64), 608284152, 10)
+ [(wordsize(64), 544489040, 10)
# 2014-10-13 544489040
- # 2015-10-28 608284152 emit Typeable at definition site
,(wordsize(32), 279480696, 10)
# 2015-07-11 279480696 (x86/Linux, 64-bit machine) use +RTS -G1
]),
@@ -692,11 +679,10 @@ test('T9872d',
test('T9961',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
- [(wordsize(64), 708680480, 5),
+ [(wordsize(64), 663978160, 5),
# 2015-01-12 807117816 Initally created
# 2015-spring 772510192 Got better
# 2015-05-22 663978160 Fix for #10370 improves it more
- # 2015-10-28 708680480 Emit Typeable at definition site
(wordsize(32), 375647160, 5)
]),
],
diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T
index 8b132fe3c0..262f4e12fa 100644
--- a/testsuite/tests/perf/should_run/all.T
+++ b/testsuite/tests/perf/should_run/all.T
@@ -409,10 +409,9 @@ test('InlineCloneArrayAlloc',
test('T9203',
[stats_num_field('bytes allocated',
[ (wordsize(32), 50000000, 5)
- , (wordsize(64), 43047088, 5) ]),
+ , (wordsize(64), 94547280, 5) ]),
# was 95747304
# 2019-09-10 94547280 post-AMP cleanup
- # 2015-10-28 43047088 emit Typeable at definition site
only_ways(['normal'])],
compile_and_run,
['-O2'])
diff --git a/testsuite/tests/polykinds/T8132.stderr b/testsuite/tests/polykinds/T8132.stderr
index 4a1ca2b4f6..e4c46591c3 100644
--- a/testsuite/tests/polykinds/T8132.stderr
+++ b/testsuite/tests/polykinds/T8132.stderr
@@ -1,3 +1,3 @@
-T8132.hs:6:10: error:
- Class ‘Typeable’ does not support user-specified instances
+T8132.hs:6:10:
+ Class `Typeable` does not support user-specified instances.
diff --git a/testsuite/tests/quasiquotation/T7918.stdout b/testsuite/tests/quasiquotation/T7918.stdout
index 4dff68d1ce..f4d406b591 100644
--- a/testsuite/tests/quasiquotation/T7918.stdout
+++ b/testsuite/tests/quasiquotation/T7918.stdout
@@ -25,6 +25,3 @@
(undefined, T7918B.hs:18:16-24)
(y, T7918B.hs:19:9-12)
(undefined, T7918B.hs:19:16-24)
-(Module, <no location info>)
-(TrNameS, <no location info>)
-(TrNameS, <no location info>)
diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr
index a4beb6454d..d9f9943d63 100644
--- a/testsuite/tests/roles/should_compile/Roles1.stderr
+++ b/testsuite/tests/roles/should_compile/Roles1.stderr
@@ -21,65 +21,4 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
integer-gmp-1.0.0.0]
==================== Typechecker ====================
-Roles1.$tcT7
- = TyCon
- 12795488517584970699##
- 6852268802866176810##
- Roles1.$trModule
- (TrNameS "T7"#)
-Roles1.$tcT6
- = TyCon
- 1052116432298682626##
- 4782516991847719023##
- Roles1.$trModule
- (TrNameS "T6"#)
-Roles1.$tcT5
- = TyCon
- 10855726709479635304##
- 5574528370049939204##
- Roles1.$trModule
- (TrNameS "T5"#)
-Roles1.$tc'K5
- = TyCon
- 17986294396600628264##
- 15784122741796850983##
- Roles1.$trModule
- (TrNameS "'K5"#)
-Roles1.$tcT4
- = TyCon
- 5809060867006837344##
- 8795972313583150301##
- Roles1.$trModule
- (TrNameS "T4"#)
-Roles1.$tcT3
- = TyCon
- 17827258502042208248##
- 10404219359416482652##
- Roles1.$trModule
- (TrNameS "T3"#)
-Roles1.$tcT2
- = TyCon
- 14324923875690440398##
- 17626224477681351106##
- Roles1.$trModule
- (TrNameS "T2"#)
-Roles1.$tc'K2
- = TyCon
- 17795591238510508397##
- 10155757471958311507##
- Roles1.$trModule
- (TrNameS "'K2"#)
-Roles1.$tcT1
- = TyCon
- 12633763300352597178##
- 11103726621424210926##
- Roles1.$trModule
- (TrNameS "T1"#)
-Roles1.$tc'K1
- = TyCon
- 1949157551035372857##
- 3576433963139282451##
- Roles1.$trModule
- (TrNameS "'K1"#)
-Roles1.$trModule = Module (TrNameS "main"#) (TrNameS "Roles1"#)
diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr
index 4b7b2cb18d..5ecdd16e10 100644
--- a/testsuite/tests/roles/should_compile/Roles13.stderr
+++ b/testsuite/tests/roles/should_compile/Roles13.stderr
@@ -1,62 +1,17 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 42, types: 18, coercions: 5}
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a1 :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a1 = TrNameS "Roles13"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-Roles13.$trModule :: Module
-[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType]
-Roles13.$trModule = Module a a1
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a2 :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a2 = TrNameS "Age"#
-
--- RHS size: {terms: 5, types: 0, coercions: 0}
-Roles13.$tcAge :: TyCon
-[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType]
-Roles13.$tcAge = TyCon 0## 0## Roles13.$trModule a2
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a3 :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a3 = TrNameS "'MkWrap"#
-
--- RHS size: {terms: 5, types: 0, coercions: 0}
-Roles13.$tc'MkWrap :: TyCon
-[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType]
-Roles13.$tc'MkWrap = TyCon 0## 0## Roles13.$trModule a3
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a4 :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a4 = TrNameS "Wrap"#
-
--- RHS size: {terms: 5, types: 0, coercions: 0}
-Roles13.$tcWrap :: TyCon
-[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType]
-Roles13.$tcWrap = TyCon 0## 0## Roles13.$trModule a4
+Result size of Tidy Core = {terms: 5, types: 9, coercions: 5}
-- RHS size: {terms: 2, types: 2, coercions: 0}
-a5 :: Wrap Age -> Wrap Age
+a :: Wrap Age -> Wrap Age
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
-a5 = \ (ds :: Wrap Age) -> ds
+a = \ (ds :: Wrap Age) -> ds
-- RHS size: {terms: 1, types: 0, coercions: 5}
convert :: Wrap Age -> Int
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType]
convert =
- a5
+ a
`cast` (<Wrap Age>_R -> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0]
:: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int))
diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr
index 20c0bfe7a4..bb61133ce0 100644
--- a/testsuite/tests/roles/should_compile/Roles14.stderr
+++ b/testsuite/tests/roles/should_compile/Roles14.stderr
@@ -11,11 +11,4 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
integer-gmp-1.0.0.0]
==================== Typechecker ====================
-Roles12.$tcC2
- = TyCon
- 4006088231579841122##
- 4783761708993822739##
- Roles12.$trModule
- (TrNameS "C2"#)
-Roles12.$trModule = Module (TrNameS "main"#) (TrNameS "Roles12"#)
diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr
index 35895a8ae4..d07314379f 100644
--- a/testsuite/tests/roles/should_compile/Roles2.stderr
+++ b/testsuite/tests/roles/should_compile/Roles2.stderr
@@ -9,17 +9,4 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
integer-gmp-1.0.0.0]
==================== Typechecker ====================
-Roles2.$tcT2
- = TyCon
- 5934726586329293381##
- 1923031187495159753##
- Roles2.$trModule
- (TrNameS "T2"#)
-Roles2.$tcT1
- = TyCon
- 13879106829711353992##
- 15151456821588362072##
- Roles2.$trModule
- (TrNameS "T1"#)
-Roles2.$trModule = Module (TrNameS "main"#) (TrNameS "Roles2"#)
diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr
index 483b349907..6f25b63691 100644
--- a/testsuite/tests/roles/should_compile/Roles3.stderr
+++ b/testsuite/tests/roles/should_compile/Roles3.stderr
@@ -26,29 +26,4 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
integer-gmp-1.0.0.0]
==================== Typechecker ====================
-Roles3.$tcC4
- = TyCon
- 12861862461396457184##
- 6389612623460961504##
- Roles3.$trModule
- (TrNameS "C4"#)
-Roles3.$tcC3
- = TyCon
- 5998139369941479154##
- 6816352641934636458##
- Roles3.$trModule
- (TrNameS "C3"#)
-Roles3.$tcC2
- = TyCon
- 8833962732139387711##
- 7891126688522429937##
- Roles3.$trModule
- (TrNameS "C2"#)
-Roles3.$tcC1
- = TyCon
- 16242970448469140073##
- 10229725431456576413##
- Roles3.$trModule
- (TrNameS "C1"#)
-Roles3.$trModule = Module (TrNameS "main"#) (TrNameS "Roles3"#)
diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr
index 2c19dd29d5..0113869e42 100644
--- a/testsuite/tests/roles/should_compile/Roles4.stderr
+++ b/testsuite/tests/roles/should_compile/Roles4.stderr
@@ -15,17 +15,4 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
integer-gmp-1.0.0.0]
==================== Typechecker ====================
-Roles4.$tcC3
- = TyCon
- 16502190608089501863##
- 13971441568961069854##
- Roles4.$trModule
- (TrNameS "C3"#)
-Roles4.$tcC1
- = TyCon
- 11951908835899020229##
- 6518430686554778113##
- Roles4.$trModule
- (TrNameS "C1"#)
-Roles4.$trModule = Module (TrNameS "main"#) (TrNameS "Roles4"#)
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
index c62d9c43dc..87c3c0058e 100644
--- a/testsuite/tests/roles/should_compile/T8958.stderr
+++ b/testsuite/tests/roles/should_compile/T8958.stderr
@@ -1,5 +1,5 @@
-T8958.hs:1:31: warning:
+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
@@ -20,13 +20,6 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
integer-gmp-1.0.0.0]
==================== Typechecker ====================
-T8958.$tcMap = TyCon 0## 0## T8958.$trModule (TrNameS "Map"#)
-T8958.$tc'MkMap = TyCon 0## 0## T8958.$trModule (TrNameS "'MkMap"#)
-T8958.$tcRepresentational
- = TyCon 0## 0## T8958.$trModule (TrNameS "Representational"#)
-T8958.$tcNominal
- = TyCon 0## 0## T8958.$trModule (TrNameS "Nominal"#)
-T8958.$trModule = Module (TrNameS "main"#) (TrNameS "T8958"#)
AbsBinds [a] []
{Exports: [T8958.$fRepresentationala <= $dRepresentational
<>]
diff --git a/testsuite/tests/simplCore/should_compile/T3234.stderr b/testsuite/tests/simplCore/should_compile/T3234.stderr
index d317991925..c3591d02fe 100644
--- a/testsuite/tests/simplCore/should_compile/T3234.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3234.stderr
@@ -10,7 +10,7 @@
==================== Grand total simplifier statistics ====================
-Total ticks: 46
+Total ticks: 45
14 PreInlineUnconditionally
1 n
@@ -37,7 +37,7 @@ Total ticks: 46
1 foldr/single
1 unpack
1 unpack-list
-2 LetFloatFromLet 2
+1 LetFloatFromLet 1
22 BetaReduction
1 a
1 b
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index f7fa084ef0..374533605e 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -1,33 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 32, types: 13, coercions: 0}
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T3717.$trModule2 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T3717.$trModule2 = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T3717.$trModule1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T3717.$trModule1 = TrNameS "T3717"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T3717.$trModule :: Module
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T3717.$trModule = Module T3717.$trModule2 T3717.$trModule1
+Result size of Tidy Core = {terms: 22, types: 10, coercions: 0}
Rec {
-- RHS size: {terms: 10, types: 2, coercions: 0}
diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout
index 1ef8c79002..e74fa39cb5 100644
--- a/testsuite/tests/simplCore/should_compile/T3772.stdout
+++ b/testsuite/tests/simplCore/should_compile/T3772.stdout
@@ -1,6 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 36, types: 14, coercions: 0}
+Result size of Tidy Core = {terms: 26, types: 11, coercions: 0}
Rec {
-- RHS size: {terms: 10, types: 2, coercions: 0}
@@ -26,32 +26,5 @@ foo =
}
}
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T3772.$trModule1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T3772.$trModule1 = TrNameS "T3772"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T3772.$trModule2 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T3772.$trModule2 = TrNameS "main"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T3772.$trModule :: Module
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T3772.$trModule = Module T3772.$trModule2 T3772.$trModule1
-
diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr
index 334935ddd4..6ad89470bb 100644
--- a/testsuite/tests/simplCore/should_compile/T4908.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4908.stderr
@@ -1,33 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 64, types: 41, coercions: 0}
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T4908.$trModule2 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T4908.$trModule2 = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T4908.$trModule1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T4908.$trModule1 = TrNameS "T4908"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T4908.$trModule :: Module
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T4908.$trModule = Module T4908.$trModule2 T4908.$trModule1
+Result size of Tidy Core = {terms: 54, types: 38, coercions: 0}
Rec {
-- RHS size: {terms: 19, types: 5, coercions: 0}
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 9f71161d14..552c8a8ddc 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -1,33 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 45, types: 17, coercions: 0}
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T4930.$trModule2 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T4930.$trModule2 = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T4930.$trModule1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T4930.$trModule1 = TrNameS "T4930"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T4930.$trModule :: Module
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T4930.$trModule = Module T4930.$trModule2 T4930.$trModule1
+Result size of Tidy Core = {terms: 35, types: 14, coercions: 0}
Rec {
-- RHS size: {terms: 23, types: 6, coercions: 0}
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 1cd13301f9..f7979075ac 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -1,6 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 55, types: 34, coercions: 0}
+Result size of Tidy Core = {terms: 36, types: 29, coercions: 0}
-- RHS size: {terms: 6, types: 3, coercions: 0}
T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo
@@ -17,51 +17,6 @@ T7360.$WFoo3 =
\ (dt [Occ=Once!] :: Int) ->
case dt of _ [Occ=Dead] { I# dt [Occ=Once] -> T7360.Foo3 dt }
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.$trModule2 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T7360.$trModule2 = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.$trModule1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T7360.$trModule1 = TrNameS "T7360"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T7360.$trModule :: Module
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T7360.$trModule = Module T7360.$trModule2 T7360.$trModule1
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.$tcFoo1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T7360.$tcFoo1 = TrNameS "Foo"#
-
--- RHS size: {terms: 5, types: 0, coercions: 0}
-T7360.$tcFoo :: TyCon
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}]
-T7360.$tcFoo = TyCon 0## 0## T7360.$trModule T7360.$tcFoo1
-
-- RHS size: {terms: 5, types: 2, coercions: 0}
fun1 [InlPrag=NOINLINE] :: Foo -> ()
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>]
diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout
index 6c0e36f8f9..35f2412bc4 100644
--- a/testsuite/tests/simplCore/should_compile/T8274.stdout
+++ b/testsuite/tests/simplCore/should_compile/T8274.stdout
@@ -1,10 +1,2 @@
-T8274.$trModule2 = TrNameS "main"#
-T8274.$trModule1 = TrNameS "T8274"#
-T8274.$tcP1 = TrNameS "P"#
- 11095028091707994303##
- 9476557054198009608##
-T8274.$tcN1 = TrNameS "N"#
- 7479687563082171902##
- 17616649989360543185##
p = T8274.Positives 42# 4.23# 4.23## '4'# 4##
n = T8274.Negatives -4# -4.0# -4.0##
diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr
index 3bc95e42cc..5216d1ed5f 100644
--- a/testsuite/tests/simplCore/should_compile/T9400.stderr
+++ b/testsuite/tests/simplCore/should_compile/T9400.stderr
@@ -1,21 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 33, types: 19, coercions: 0}
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-a1 :: TrName
-[GblId, Caf=NoCafRefs, Str=DmdType]
-a1 = TrNameS "T9400"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-T9400.$trModule :: Module
-[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType]
-T9400.$trModule = Module a a1
+Result size of Tidy Core = {terms: 23, types: 16, coercions: 0}
-- RHS size: {terms: 22, types: 14, coercions: 0}
main :: IO ()
diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr
index da97b8859c..082f9aa134 100644
--- a/testsuite/tests/simplCore/should_compile/rule2.stderr
+++ b/testsuite/tests/simplCore/should_compile/rule2.stderr
@@ -10,14 +10,13 @@
==================== Grand total simplifier statistics ====================
-Total ticks: 13
+Total ticks: 12
2 PreInlineUnconditionally
1 f
1 lvl
1 UnfoldingDone 1 Roman.bar
1 RuleFired 1 foo/bar
-1 LetFloatFromLet 1
1 EtaReduction 1 ds
7 BetaReduction
1 f
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 7ae0e9c920..392d4fba73 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -1,33 +1,6 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 172, types: 64, coercions: 0}
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-Roman.$trModule2 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-Roman.$trModule2 = TrNameS "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0}
-Roman.$trModule1 :: TrName
-[GblId,
- Caf=NoCafRefs,
- Str=DmdType m1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-Roman.$trModule1 = TrNameS "Roman"#
-
--- RHS size: {terms: 3, types: 0, coercions: 0}
-Roman.$trModule :: Module
-[GblId[ReflectionId],
- Caf=NoCafRefs,
- Str=DmdType m,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-Roman.$trModule = Module Roman.$trModule2 Roman.$trModule1
+Result size of Tidy Core = {terms: 162, types: 61, coercions: 0}
-- RHS size: {terms: 2, types: 1, coercions: 0}
Roman.foo3 :: Int
diff --git a/testsuite/tests/stranal/should_compile/T10694.stdout b/testsuite/tests/stranal/should_compile/T10694.stdout
index 64d5f7a1aa..2797ce7407 100644
--- a/testsuite/tests/stranal/should_compile/T10694.stdout
+++ b/testsuite/tests/stranal/should_compile/T10694.stdout
@@ -1,5 +1,2 @@
- Str=DmdType m1,
- Str=DmdType m1,
- Str=DmdType m,
[GblId, Arity=2, Str=DmdType <L,U(U)><L,U(U)>m]
Str=DmdType <L,U(U)><L,U(U)>,
diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
index 4bc1e3f379..e8ae690147 100644
--- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
+++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
@@ -1,6 +1,5 @@
==================== Strictness signatures ====================
-BottomFromInnerLambda.$trModule: m
BottomFromInnerLambda.expensive: <S(S),1*U(U)>m
BottomFromInnerLambda.f: <S(S),1*U(U)>
diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
index aa7a2ef8b6..7fb1a55223 100644
--- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
+++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
@@ -1,7 +1,5 @@
==================== Strictness signatures ====================
-DmdAnalGADTs.$tcD: m
-DmdAnalGADTs.$trModule: m
DmdAnalGADTs.diverges: b
DmdAnalGADTs.f: <S,1*U>
DmdAnalGADTs.f': <S,1*U>m
diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
index f04a2118fd..1a0ff337c1 100644
--- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr
+++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
@@ -1,6 +1,5 @@
==================== Strictness signatures ====================
-HyperStrUse.$trModule: m
HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U>m
diff --git a/testsuite/tests/stranal/sigs/StrAnalExample.stderr b/testsuite/tests/stranal/sigs/StrAnalExample.stderr
index bd82226bee..dbe4770080 100644
--- a/testsuite/tests/stranal/sigs/StrAnalExample.stderr
+++ b/testsuite/tests/stranal/sigs/StrAnalExample.stderr
@@ -1,6 +1,5 @@
==================== Strictness signatures ====================
-StrAnalExample.$trModule: m
StrAnalExample.foo: <S,1*U>
diff --git a/testsuite/tests/stranal/sigs/T8569.stderr b/testsuite/tests/stranal/sigs/T8569.stderr
index 3013d769fb..d33935ee14 100644
--- a/testsuite/tests/stranal/sigs/T8569.stderr
+++ b/testsuite/tests/stranal/sigs/T8569.stderr
@@ -1,7 +1,5 @@
==================== Strictness signatures ====================
-T8569.$tcRep: m
-T8569.$trModule: m
T8569.addUp: <S,1*U><L,U>
diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr
index 28d5dd0c7d..8de5d31a01 100644
--- a/testsuite/tests/stranal/sigs/T8598.stderr
+++ b/testsuite/tests/stranal/sigs/T8598.stderr
@@ -1,6 +1,5 @@
==================== Strictness signatures ====================
-T8598.$trModule: m
T8598.fun: <S(S),1*U(U)>m
diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr
index 5f2d27ff20..6e6402bacc 100644
--- a/testsuite/tests/stranal/sigs/UnsatFun.stderr
+++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr
@@ -1,6 +1,5 @@
==================== Strictness signatures ====================
-UnsatFun.$trModule: m
UnsatFun.f: <B,1*U(U)><B,A>b
UnsatFun.g: <B,1*U(U)>b
UnsatFun.g': <L,1*U(U)>
diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr
index 5ca909f7ab..8f078ba901 100644
--- a/testsuite/tests/th/TH_Roles2.stderr
+++ b/testsuite/tests/th/TH_Roles2.stderr
@@ -9,12 +9,4 @@ Dependent packages: [array-0.5.1.0, base-4.8.2.0, deepseq-1.4.1.1,
pretty-1.1.2.0, template-haskell-2.11.0.0]
==================== Typechecker ====================
-TH_Roles2.$tcT
- = TyCon
- 6325001754388382679##
- 4656387726417942748##
- TH_Roles2.$trModule
- (TrNameS "T"#)
-TH_Roles2.$trModule
- = Module (TrNameS "main"#) (TrNameS "TH_Roles2"#)
diff --git a/testsuite/tests/typecheck/should_compile/holes2.stderr b/testsuite/tests/typecheck/should_compile/holes2.stderr
index 63891fa273..ee3d627438 100644
--- a/testsuite/tests/typecheck/should_compile/holes2.stderr
+++ b/testsuite/tests/typecheck/should_compile/holes2.stderr
@@ -4,10 +4,10 @@ holes2.hs:3:5: warning:
prevents the constraint ‘(Show a0)’ from being solved.
Probable fix: use a type annotation to specify what ‘a0’ should be.
These potential instances exist:
- instance Show Module -- Defined in ‘GHC.Show’
instance Show Ordering -- Defined in ‘GHC.Show’
- instance Show TrName -- Defined in ‘GHC.Show’
- ...plus 25 others
+ instance Show Integer -- Defined in ‘GHC.Show’
+ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
+ ...plus 22 others
(use -fprint-potential-instances to see them all)
In the expression: show _
In an equation for ‘f’: f = show _
diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr
index a854b7ea75..46667fb8f4 100644
--- a/testsuite/tests/typecheck/should_fail/T5095.stderr
+++ b/testsuite/tests/typecheck/should_fail/T5095.stderr
@@ -6,7 +6,7 @@ T5095.hs:9:11: error:
instance (Eq a, Eq b) => Eq (Either a b)
-- Defined in ‘Data.Either’
instance Eq All -- Defined in ‘Data.Monoid’
- ...plus 36 others
+ ...plus 35 others
...plus one instance involving out-of-scope types
(use -fprint-potential-instances to see them all)
(The choice depends on the instantiation of ‘a’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr
index 68d7283244..65b157332d 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail072.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr
@@ -8,10 +8,10 @@ tcfail072.hs:23:13: error:
The type variable ‘p0’ is ambiguous
These potential instances exist:
instance Ord Ordering -- Defined in ‘GHC.Classes’
- instance Ord TyCon -- Defined in ‘GHC.Classes’
instance Ord Integer
-- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’
- ...plus 23 others
+ instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’
+ ...plus 22 others
...plus one instance involving out-of-scope types
(use -fprint-potential-instances to see them all)
In the expression: g A
diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr
index 32f73422af..f61320f4c1 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail133.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr
@@ -7,10 +7,11 @@ tcfail133.hs:68:7: error:
prevents the constraint ‘(Show r0)’ from being solved.
Probable fix: use a type annotation to specify what ‘r0’ should be.
These potential instances exist:
- instance Show Module -- Defined in ‘GHC.Show’
instance Show Ordering -- Defined in ‘GHC.Show’
- instance Show TrName -- Defined in ‘GHC.Show’
- ...plus 28 others
+ instance Show Integer -- Defined in ‘GHC.Show’
+ instance (Show a, Show b, Number a, Digit b) => Show (a :@ b)
+ -- Defined at tcfail133.hs:11:54
+ ...plus 25 others
(use -fprint-potential-instances to see them all)
In the expression: show
In the expression: show $ add (One :@ Zero) (One :@ One)
diff --git a/utils/haddock b/utils/haddock
-Subproject 174f23631a0a8de7dc0f3cd67c393a5ca88c4a2
+Subproject 18de4f2f992d3ed41eb83cb073e63304f0271dc