------------------------
Fix a type-invariant bug
------------------------
We need to call Type.mkGenTyConApp from Type.mkAppTy, in
case there's a partially applied type synonym. Explanation
with Type.mkAppTy. All part of GHC's rather liberal treatment
of type synonyms.
Shown up by a program from Ralf Laemmel:
type Generic i o = forall x. i x -> o x
type Id x = x
comb :: Generic Id Id
Test is typecheck/should_compile/tc149.hs
-- Synonym notes are built only when the synonym is
-- saturated (see Type.mkSynTy)
-- Not checking the 'note' part allows us to instantiate a synonym
-- Synonym notes are built only when the synonym is
-- saturated (see Type.mkSynTy)
-- Not checking the 'note' part allows us to instantiate a synonym
- -- defn with a for-all type, but that seems OK too
+ -- defn with a for-all type, or with a partially-applied type synonym,
+ -- but that seems OK too
check_tau_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
check_tau_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
import TcUnify ( unifyKind, unifyOpenTypeKind )
import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
TcTyVar, TcKind, TcThetaType, TcTauType,
import TcUnify ( unifyKind, unifyOpenTypeKind )
import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
TcTyVar, TcKind, TcThetaType, TcTauType,
- mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
+ mkTyVarTy, mkTyVarTys, mkFunTy,
hoistForAllTys, zipFunTys,
hoistForAllTys, zipFunTys,
- mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys,
+ mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
liftedTypeKind, unliftedTypeKind, mkArrowKind,
mkArrowKinds, tcSplitFunTy_maybe
)
liftedTypeKind, unliftedTypeKind, mkArrowKind,
mkArrowKinds, tcSplitFunTy_maybe
)
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
import ErrUtils ( Message )
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
import ErrUtils ( Message )
-import TyCon ( TyCon, isSynTyCon, tyConKind )
+import TyCon ( TyCon, tyConKind )
import Class ( classTyCon )
import Name ( Name )
import NameSet
import Class ( classTyCon )
import Name ( Name )
import NameSet
case thing of
ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
case thing of
ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
- AGlobal (ATyCon tc)
- | isSynTyCon tc -> returnTc (mkSynTy tc arg_tys)
- | otherwise -> returnTc (mkTyConApp tc arg_tys)
+ AGlobal (ATyCon tc) -> returnTc (mkGenTyConApp tc arg_tys)
other -> failWithTc (wrongThingErr "type constructor" thing name)
\end{code}
other -> failWithTc (wrongThingErr "type constructor" thing name)
\end{code}
Type, SourceType(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
Type, SourceType(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
- mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
isUnLiftedType, -- Source types are always lifted
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
isUnLiftedType, -- Source types are always lifted
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
mkFunTy, mkFunTys, zipFunTys,
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
mkFunTy, mkFunTys, zipFunTys,
- mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
splitNewType_maybe, splitTyConApp_maybe,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
splitNewType_maybe, splitTyConApp_maybe,
mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys,
funResultTy, funArgTy, zipFunTys, isFunTy,
mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys,
funResultTy, funArgTy, zipFunTys, isFunTy,
+ mkGenTyConApp, mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
- mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
+ mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2])
mk_app ty1 = AppTy orig_ty1 orig_ty2
mk_app ty1 = AppTy orig_ty1 orig_ty2
+ -- We call mkGenTyConApp because the TyConApp could be an
+ -- under-saturated type synonym. GHC allows that; e.g.
+ -- type Foo k = k a -> k a
+ -- type Id x = x
+ -- foo :: Foo Id -> Foo Id
+ --
+ -- Here Id is partially applied in the type sig for Foo,
+ -- but once the type synonyms are expanded all is well
mkAppTys :: Type -> [Type] -> Type
mkAppTys orig_ty1 [] = orig_ty1
mkAppTys :: Type -> [Type] -> Type
mkAppTys orig_ty1 [] = orig_ty1
as apppropriate.
\begin{code}
as apppropriate.
\begin{code}
+mkGenTyConApp :: TyCon -> [Type] -> Type
+mkGenTyConApp tc tys
+ | isSynTyCon tc = mkSynTy tc tys
+ | otherwise = mkTyConApp tc tys
+
mkTyConApp :: TyCon -> [Type] -> Type
-- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
mkTyConApp tycon tys
mkTyConApp :: TyCon -> [Type] -> Type
-- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
mkTyConApp tycon tys