-tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v')
-tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty')
-tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
-
-tcCoreAlts scrut_ty (UfAlgAlts alts deflt)
- = mapTc tc_alt alts `thenTc` \ alts' ->
- tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
- returnTc (AlgAlts alts' deflt')
- where
- tc_alt (con, names, rhs)
- = tcVar con `thenTc` \ con' ->
- let
- arg_tys = dataConArgTys con' inst_tys
- (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
- arg_ids = zipWithEqual "tcCoreAlts" mkUserId names arg_tys
- in
- tcExtendGlobalValEnv arg_ids $
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (con', arg_ids, rhs')
-
-tcCoreAlts scrut_ty (UfPrimAlts alts deflt)
- = mapTc tc_alt alts `thenTc` \ alts' ->
- tcCoreDefault scrut_ty deflt `thenTc` \ deflt' ->
- returnTc (PrimAlts alts' deflt')
- where
- tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (lit, rhs')
-
-tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault
-tcCoreDefault scrut_ty (UfBindDefault name rhs)
- = let
- deflt_id = mkUserId name scrut_ty
+tcCoreAlt scrut_ty (UfDefault, names, rhs)
+ = ASSERT( null names )
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (DEFAULT, [], rhs')
+
+tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
+ = ASSERT( null names )
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (LitAlt lit, [], rhs')
+
+tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
+ = ASSERT( null names )
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ tcIfaceType ty `thenTc` \ ty' ->
+ returnTc (LitAlt (MachLitLit str ty'), [], rhs')
+
+-- A case alternative is made quite a bit more complicated
+-- by the fact that we omit type annotations because we can
+-- work them out. True enough, but its not that easy!
+tcCoreAlt scrut_ty alt@(con, names, rhs)
+ = tcConAlt con `thenTc` \ con ->
+ let
+ (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
+
+ (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp
+ -- We are looking at Core here
+ ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
+ ex_tys' = mkTyVarTys ex_tyvars'
+ arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
+ id_names = drop (length ex_tyvars) names
+ arg_ids
+#ifdef DEBUG
+ | length id_names /= length arg_tys
+ = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
+ (ppr main_tyvars <+> ppr ex_tyvars) $$
+ ppr arg_tys)
+ | otherwise
+#endif
+ = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys