diff options
-rw-r--r-- | compiler/coreSyn/CorePrep.hs | 2 | ||||
-rw-r--r-- | compiler/deSugar/DsBinds.hs | 1 | ||||
-rw-r--r-- | compiler/prelude/PrelNames.hs | 13 | ||||
-rw-r--r-- | compiler/prelude/TysPrim.hs | 7 | ||||
-rw-r--r-- | compiler/prelude/TysWiredIn.hs | 8 | ||||
-rw-r--r-- | compiler/typecheck/TcEvidence.hs | 15 | ||||
-rw-r--r-- | compiler/typecheck/TcInteract.hs | 7 | ||||
-rw-r--r-- | compiler/typecheck/TcTypeNats.hs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcTypeable.hs | 16 | ||||
-rw-r--r-- | compiler/types/TyCon.hs | 2 | ||||
-rw-r--r-- | compiler/types/Type.hs | 7 | ||||
-rw-r--r-- | compiler/types/TypeRep.hs | 14 |
12 files changed, 63 insertions, 31 deletions
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 1e99e80018..6b0e3e9dd1 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -60,7 +60,7 @@ import MonadUtils ( mapAccumLM ) import Data.List ( mapAccumL ) import Control.Monad -#if __GLASGOW_HASKELL__ < 711 +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index bd9fec375c..733b6dfe6f 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -915,7 +915,6 @@ dsEvTypeable ty ev ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr -- Returns a CoreExpr :: TypeRep (for ty) --- together with ty ds_ev_typeable ty (EvTypeableTyCon ev_ts) | Just (tc, kts) <- splitTyConApp_maybe ty , (ks, ts) <- splitTyConArgs tc kts diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index cec6837408..3bc29674e9 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -778,6 +778,7 @@ and it's convenient to write them all down in one place. -} mkSpecialTyConRepName :: FastString -> Name -> Name +-- See Note [Grand plan for Typeable] in TcTypeable mkSpecialTyConRepName fs tc_name = mkExternalName (tyConRepNameUnique (nameUnique tc_name)) tYPEABLE_INTERNAL @@ -785,18 +786,20 @@ mkSpecialTyConRepName fs tc_name wiredInSrcSpan mkPrelTyConRepName :: Name -> Name -mkPrelTyConRepName name -- Prelude tc_name is always External, +-- See Note [Grand plan for Typeable] in TcTypeable +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, -- so nameModule will work - = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan name) + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) where - name_occ = nameOccName name - name_mod = nameModule name - name_uniq = nameUnique name + 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 tyConRepModOcc :: Module -> OccName -> (Module, OccName) +-- See Note [Grand plan for Typeable] in TcTypeable tyConRepModOcc tc_module tc_occ | tc_module == gHC_TYPES = (tYPEABLE_INTERNAL, mkTyConRepUserOcc tc_occ) diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 6ce7abdadb..793635bd3c 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -319,12 +319,15 @@ superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, constraintKindTyConName :: Name -mk_kind_tycon :: Name -> FastString -> TyCon +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) + -- mkSpecialTyConRepName: see Note [Grand plan for Typeable] in TcTypeable superKindTyCon = mk_kind_tycon superKindTyConName (fsLit "tcBOX") - -- See Note [SuperKind (BOX)] + -- See Note [SuperKind (BOX)] anyKindTyCon = mk_kind_tycon anyKindTyConName (fsLit "tcAnyK") constraintKindTyCon = mk_kind_tycon constraintKindTyConName (fsLit "tcConstraint") diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 9c53e153d0..3628c432d2 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -417,9 +417,9 @@ tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i) tupleCon ConstraintTuple i = snd (factTupleArr ! i) boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon) -boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]] -unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]] -factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]] +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]] +factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]] mk_tuple :: TupleSort -> Int -> (TyCon,DataCon) mk_tuple sort arity = (tycon, tuple_con) @@ -429,7 +429,7 @@ mk_tuple sort arity = (tycon, tuple_con) rep_nm = case sort of BoxedTuple -> Just (mkPrelTyConRepName tc_name) UnboxedTuple -> Nothing - ConstraintTuple -> Just (mkPrelTyConRepName tc_name) -- I think + ConstraintTuple -> Nothing -- Constraints are not typeble prom_tc = case sort of BoxedTuple -> Promoted (mkPromotedTyCon tycon (promoteKind tc_kind)) diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index ced34b7369..9c131290d5 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -734,6 +734,7 @@ data EvTerm -- | Instructions on how to make a 'Typeable' dictionary. +-- See Note [Typeable evidence terms] data EvTypeable = EvTypeableTyCon [EvTerm] -- ^ Dicitionary for Typeable (T k1..kn t1..tn) @@ -767,7 +768,19 @@ data EvCallStack -- @?name@, occurring at @loc@, in a calling context @stk@. 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] (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 diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 45463ba3a5..8c61602f12 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -14,10 +14,10 @@ import TcCanonical import TcFlatten import VarSet import Type -import Kind (isKind) +import Kind ( isKind, isConstraintKind ) import Unify import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId ) -import CoAxiom(sfInteractTop, sfInteractInert) +import CoAxiom( sfInteractTop, sfInteractInert ) import Var import TcType @@ -1876,7 +1876,8 @@ matchTypeableClass :: Class -- The Typeable class -> [Type] -> CtLoc -> TcS LookupInstResult matchTypeableClass clas [k, t] loc - | isForAllTy k = return NoInstance + | isForAllTy t = return NoInstance + | isConstraintKind k = return NoInstance | Just (tc, kts) <- splitTyConApp_maybe t = doTyConApp tc kts | Just (f,kt ) <- splitAppTy_maybe t = doTyApp f kt | Just _ <- isNumLitTy t = doLit diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 2e545b2e4d..a888a31556 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -44,7 +44,7 @@ import qualified Data.Map as Map import Data.Maybe ( isJust ) {------------------------------------------------------------------------------- -Built-in type constructors for functions on type-lelve nats +Built-in type constructors for functions on type-level nats -} typeNatTyCons :: [TyCon] diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index e3d0051fca..f3494a9378 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -80,9 +80,15 @@ There are many wrinkles: * To be able to define them by hand, they need to have user-writable names, thus - tcBool, not $tcBool - and tcList, not $tc[] - Hence PrelNames.tyConRepModOcc, and mkSpecialTyConRepName. + 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 @@ -154,8 +160,8 @@ type TypeableStuff , LHsExpr Id -- Of type GHC.Types.Module , String -- Package name , String -- Module name - , DataCon - , DataCon ) + , DataCon -- Data constructor GHC.Types.TyCon + , DataCon ) -- Data constructor GHC.Types.TrNameS mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id mk_typeable_binds stuff tycon diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 5258839ad5..7596fe2671 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -856,7 +856,7 @@ so the coercion tycon CoT must have ************************************************************************ * * - PrimRep + TyConRepName * * ********************************************************************* -} diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 4d9dd1797e..dc7b64fe5d 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -577,12 +577,9 @@ 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 - = go (tyConKind tc) [] kts + = splitAtList kind_vars kts where - go tc_kind acc (kt:kts) - | Just (_,body_kind) <- splitForAllTy_maybe tc_kind - = go body_kind (kt:acc) kts - go _ acc ts = (reverse acc, ts) + (kind_vars, _) = splitForAllTys (tyConKind tc) newTyConInstRhs :: TyCon -> [Type] -> Type -- ^ Unwrap one 'layer' of newtype on a type constructor and its diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs index c78c9c5975..ea7724cfdd 100644 --- a/compiler/types/TypeRep.hs +++ b/compiler/types/TypeRep.hs @@ -730,8 +730,7 @@ pprTcApp _ pp tc [ty] pprTcApp p pp tc tys | isTupleTyCon tc && tyConArity tc == length tys - = pprPromotionQuote tc <> - tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) + = pprTupleApp p pp tc tys | Just dc <- isPromotedDataCon_maybe tc , let dc_tc = dataConTyCon dc @@ -746,6 +745,17 @@ pprTcApp p pp tc tys | otherwise = sdocWithDynFlags (pprTcApp_help p pp tc tys) +pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc +-- Print a saturated tuple +pprTupleApp p pp tc tys + | null tys + , ConstraintTuple <- tupleTyConSort tc + = maybeParen p TopPrec $ + ppr tc <+> dcolon <+> ppr (tyConKind tc) + | otherwise + = pprPromotionQuote tc <> + tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) + pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc -- This one has accss to the DynFlags pprTcApp_help p pp tc tys dflags |