-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)
-tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
-
-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) = getAppDataTyConExpandingDicts scrut_ty
- arg_ids = zipWithEqual "tcCoreAlts" mk_id 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 = mk_id 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' ->
+ tcHsType 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@(UfDataAlt con_name, names, rhs)
+ = tcVar con_name `thenTc` \ con_id ->
+ let
+ con = case isDataConWrapId_maybe con_id of
+ Just con -> con
+ Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
+
+ (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
+
+ (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic "tcCoreAlt" (ppr alt)
+ 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_name, names, rhs) $$
+ (ppr main_tyvars <+> ppr ex_tyvars) $$
+ ppr arg_tys)
+ | otherwise
+#endif
+ = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys