From 4ae1e17253f4417303e46d59f5a737cc1d7fd78e Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 2 May 2007 16:37:09 +0000 Subject: [PATCH] Add more assertions --- compiler/basicTypes/MkId.lhs | 4 ++-- compiler/deSugar/Check.lhs | 6 +++--- compiler/deSugar/DsUtils.lhs | 6 +++--- compiler/deSugar/Match.lhs | 3 ++- compiler/deSugar/MatchLit.lhs | 3 ++- 5 files changed, 12 insertions(+), 10 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index bcfd33d..403d309 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -279,7 +279,7 @@ mkDataConIds wrap_name wkr_name data_con wrapNewTypeBody tycon res_ty_args (Var id_arg1) - id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) + id_arg1 = ASSERT( not (null orig_arg_tys) ) mkTemplateLocal 1 (head orig_arg_tys) ----------- Wrapper -------------- -- We used to include the stupid theta in the wrapper's args @@ -492,7 +492,7 @@ mkRecordSelId tycon field_label data_cons_w_field = filter has_field data_cons -- Can't be empty! has_field con = field_label `elem` dataConFieldLabels con - con1 = head data_cons_w_field + con1 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field (univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1 -- For a data type family, the data_ty (and hence selector_ty) mentions -- only the family TyCon, not the instance TyCon diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 359035f..a81123e 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -249,7 +249,7 @@ must be one Variable to be complete. process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) process_literals used_lits qs - | null default_eqns = ([make_row_vars used_lits (head qs)] ++ pats,indexs) + | null default_eqns = ASSERT( not (null qs) ) ([make_row_vars used_lits (head qs)] ++ pats,indexs) | otherwise = (pats_default,indexs_default) where (pats,indexs) = process_explicit_literals used_lits qs @@ -331,7 +331,7 @@ need_default_case used_cons unused_cons qs (pats',indexs') = check' default_eqns pats_default = [(make_whole_con c:ps,constraints) | c <- unused_cons, (ps,constraints) <- pats'] ++ pats - new_wilds = make_row_vars_for_constructor (head qs) + new_wilds = ASSERT( not (null qs) ) make_row_vars_for_constructor (head qs) pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats indexs_default = unionUniqSets indexs' indexs @@ -432,7 +432,7 @@ mb_neg Nothing v = v mb_neg (Just _) v = -v get_unused_cons :: [Pat Id] -> [DataCon] -get_unused_cons used_cons = unused_cons +get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons where (ConPatOut { pat_con = l_con, pat_ty = ty }) = head used_cons ty_con = dataConTyCon (unLoc l_con) -- Newtype observable diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 62284db..65448cb 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -242,7 +242,7 @@ worthy of a type synonym and a few handy functions. \begin{code} firstPat :: EquationInfo -> Pat Id -firstPat eqn = head (eqn_pats eqn) +firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) shiftEqns :: [EquationInfo] -> [EquationInfo] -- Drop the first pattern in each equation @@ -357,8 +357,8 @@ mkCoAlgCaseMatchResult var ty match_alts -- the scrutinised Id to be sufficiently refined to have a TyCon in it] -- Stuff for newtype - (con1, arg_ids1, match_result1) = head match_alts - arg_id1 = head arg_ids1 + (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts + arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 var_ty = idType var (tc, ty_args) = splitNewTyConApp var_ty newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index a31494e..9dc5d3a 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -610,7 +610,8 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MatchGroup matches match_ty) - = do { eqns_info <- mapM mk_eqn_info matches + = ASSERT( notNull matches ) + do { eqns_info <- mapM mk_eqn_info matches ; new_vars <- selectMatchVars arg_pats ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 2cdab30..e0a7601 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -183,7 +183,8 @@ matchLiterals :: [Id] -> DsM MatchResult matchLiterals (var:vars) ty sub_groups - = do { -- Deal with each group + = ASSERT( all notNull sub_groups ) + do { -- Deal with each group ; alts <- mapM match_group sub_groups -- Combine results. For everything except String -- 1.7.10.4