Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/97741318c541288038c8a564294fed7f0143f586 >--------------------------------------------------------------- commit 97741318c541288038c8a564294fed7f0143f586 Author: Simon Peyton Jones <[email protected]> Date: Wed Feb 1 15:51:30 2012 +0000 When type-checking kinds, be sure to promote list and tuple syntax This fixes the ASSERT failure in Trac #5833 and type error in #5798 >--------------------------------------------------------------- compiler/prelude/TysWiredIn.lhs | 14 ++++++++++++-- compiler/typecheck/TcHsType.lhs | 31 ++++++++++++++++++------------- compiler/types/Kind.lhs | 2 +- compiler/types/TyCon.lhs | 6 +++--- 4 files changed, 34 insertions(+), 19 deletions(-) diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index ec760d7..cd5ca66 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -50,11 +50,12 @@ module TysWiredIn ( -- * List listTyCon, nilDataCon, consDataCon, listTyCon_RDR, consDataCon_RDR, listTyConName, - mkListTy, + mkListTy, mkPromotedListTy, -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, tupleCon, + tupleTyCon, promotedTupleTyCon, + tupleCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -322,6 +323,9 @@ tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) +promotedTupleTyCon :: TupleSort -> Arity -> TyCon +promotedTupleTyCon sort i = mkPromotedTyCon (tupleTyCon sort i) + tupleCon :: TupleSort -> Arity -> DataCon tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially tupleCon BoxedTuple i = snd (boxedTupleArr ! i) @@ -625,6 +629,12 @@ mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon] +mkPromotedListTy :: Type -> Type +mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] + +promotedListTyCon :: TyCon +promotedListTyCon = mkPromotedTyCon listTyCon + nilDataCon :: DataCon nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index b2482c0..9d3534b 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -511,12 +511,13 @@ kc_hs_type (HsDocTy ty _) exp_kind kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind = do { ty_k_s <- mapM kc_lhs_type_fresh tys ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s - ; checkExpectedKind ty (mkListTy kind) exp_kind + ; checkExpectedKind ty (mkPromotedListTy kind) exp_kind ; return (HsExplicitListTy kind (map fst ty_k_s)) } kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do ty_k_s <- mapM kc_lhs_type_fresh tys - let tupleKi = mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s) + let tycon = promotedTupleTyCon BoxedTuple (length tys) + tupleKi = mkTyConApp tycon (map snd ty_k_s) checkExpectedKind ty tupleKi exp_kind return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) @@ -1304,13 +1305,14 @@ sc_ds_hs_kind (HsFunTy ki1 ki2) = sc_ds_hs_kind (HsListTy ki) = do kappa <- sc_ds_lhs_kind ki checkWiredInTyCon listTyCon - return $ mkListTy kappa + return $ mkPromotedListTy kappa sc_ds_hs_kind (HsTupleTy _ kis) = do kappas <- mapM sc_ds_lhs_kind kis checkWiredInTyCon tycon return $ mkTyConApp tycon kappas - where tycon = tupleTyCon BoxedTuple (length kis) + where + tycon = promotedTupleTyCon BoxedTuple (length kis) -- Argument not kind-shaped sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) @@ -1327,15 +1329,16 @@ sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> -- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar sc_ds_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds +-- They are kinds already, so we don't need to promote them sc_ds_var_app name arg_kis - | name == liftedTypeKindTyConName - || name == constraintKindTyConName = do - unless (null arg_kis) - (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) - thing <- tcLookup name - case thing of - AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "sc_ds_var_app 1" + | name == liftedTypeKindTyConName + || name == constraintKindTyConName + = do { unless (null arg_kis) + (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) + ; thing <- tcLookup name + ; case thing of + AGlobal (ATyCon tc) -> return (mkTyConApp tc []) + _ -> panic "sc_ds_var_app 1" } -- General case sc_ds_var_app name arg_kis = do @@ -1348,11 +1351,13 @@ sc_ds_var_app name arg_kis = do let tc_kind = tyConKind tc case isPromotableKind tc_kind of Just n | n == length arg_kis -> - return (mkTyConApp (mkPromotedTypeTyCon tc) arg_kis) + return (mkTyConApp (mkPromotedTyCon tc) arg_kis) Just _ -> err tc_kind "is not fully applied" Nothing -> err tc_kind "is not promotable" + -- It is in scope, but not what we expected Just thing -> wrongThingErr "promoted type" thing name + -- It is not in scope, but it passed the renamer: staging error Nothing -> ASSERT2 ( isTyConName name, ppr name ) failWithTc (ptext (sLit "Promoted kind") <+> diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 91af7fc..90223d4 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -329,7 +329,7 @@ isPromotableTyVar = isLiftedTypeKind . varType -- | Promotes a type to a kind. Assumes the argument is promotable. promoteType :: Type -> Kind -promoteType (TyConApp tc tys) = mkTyConApp (mkPromotedTypeTyCon tc) +promoteType (TyConApp tc tys) = mkTyConApp (mkPromotedTyCon tc) (map promoteType tys) -- T t1 .. tn ~~> 'T k1 .. kn where ti ~~> ki promoteType (FunTy arg res) = mkArrowKind (promoteType arg) (promoteType res) diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index f5c0567..4317e40 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -39,7 +39,7 @@ module TyCon( mkSuperKindTyCon, mkForeignTyCon, mkPromotedDataTyCon, - mkPromotedTypeTyCon, + mkPromotedTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -971,8 +971,8 @@ mkPromotedDataTyCon con name unique kind } -- | Create a promoted type constructor 'TyCon' -mkPromotedTypeTyCon :: TyCon -> TyCon -mkPromotedTypeTyCon con +mkPromotedTyCon :: TyCon -> TyCon +mkPromotedTyCon con = PromotedTypeTyCon { tyConName = getName con, tyConUnique = getUnique con, _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
