- check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
-
- -- elem: yes, the elem-list here can sometimes be long-ish,
- -- but as it's use-once, probably not worth doing anything different
- -- We give it its own copy, so it isn't overloaded.
- elem _ [] = False
- elem x (y:ys) = x==y || elem x ys
-
-lintPrimAlt ty alt@(lit,rhs)
- = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
- lintCoreExpr rhs
-
-lintDeflt NoDefault _ = returnL Nothing
-lintDeflt deflt@(BindDefault binder rhs) ty
- = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
- addInScopeVars [binder] (lintCoreExpr rhs)
+ lit_ty = literalType lit
+
+lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
+ | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty,
+ tycon == dataConTyCon con
+ = addLoc (CaseAlt alt) $
+ addInScopeVars args $ -- Put the args in scope before lintBinder,
+ -- because the Ids mention the type variables
+ if isVanillaDataCon con then
+ do { addLoc (CasePat alt) $ do
+ { mapM lintBinder args
+ -- FIX! Add check that all args are Ids.
+ -- Check the pattern
+ -- Scrutinee type must be a tycon applicn; checked by caller
+ -- This code is remarkably compact considering what it does!
+ -- NB: args must be in scope here so that the lintCoreArgs line works.
+ -- NB: relies on existential type args coming *after* ordinary type args
+
+ ; con_type <- lintTyApps (dataConRepType con) tycon_arg_tys
+ -- Can just map Var as we know that this is a vanilla datacon
+ ; con_result_ty <- lintCoreArgs con_type (map Var args)
+ ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
+ }
+ -- Check the RHS
+ ; checkAltExpr rhs alt_ty }
+
+ else -- GADT
+ do { let (tvs,ids) = span isTyVar args
+ ; subst <- getTvSubst
+ ; let in_scope = getTvInScope subst
+ subst_env = getTvSubstEnv subst
+ ; case coreRefineTys in_scope con tvs scrut_ty of {
+ Nothing -> return () ; -- Alternative is dead code
+ Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
+ do { addLoc (CasePat alt) $ do
+ { tvs' <- mapM lintTy (mkTyVarTys tvs)
+ ; con_type <- lintTyApps (dataConRepType con) tvs'
+ ; mapM lintBinder ids -- Lint Ids in the refined world
+ ; lintCoreArgs con_type (map Var ids)
+ }
+
+ ; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
+ -- alt_ty is already an OutType, so don't re-apply
+ -- the current substitution. But we must apply the
+ -- refinement so that the check in checkAltExpr is ok
+ ; checkAltExpr rhs refined_alt_ty
+ } } }
+
+ | otherwise -- Scrut-ty is wrong shape
+ = addErrL (mkBadAltMsg scrut_ty alt)