From: simonpj Date: Mon, 5 Apr 2004 10:35:14 +0000 (+0000) Subject: [project @ 2004-04-05 10:35:11 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1913 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=86b3c9519a4027be3d19a46397f0c2a1797c4606;p=ghc-hetmet.git [project @ 2004-04-05 10:35:11 by simonpj] In the derived code for gunfold, use a wild-card for the final case, to avoid a redundant test, and to eliminate the annoying warning about un-matched cases. While I'm at it, rename HsUtils.wildPat to nlWildPat, for consistency. --- diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 4885b13..aed32b6 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -188,7 +188,7 @@ check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet) check' [] = ([([],[])],emptyUniqSet) check' [EqnInfo n ctx ps (MatchResult CanFail _)] - | all_vars ps = ([(takeList ps (repeat wildPat),[])], unitUniqSet n) + | all_vars ps = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n) check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs) | all_vars ps = (pats, addOneToUniqSet indexs n) @@ -253,7 +253,7 @@ process_literals used_lits qs default_eqns = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs) (pats',indexs') = check' default_eqns - pats_default = [(wildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats + pats_default = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats indexs_default = unionUniqSets indexs' indexs \end{code} @@ -301,7 +301,7 @@ nothing to do. \begin{code} first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -first_column_only_vars qs = (map (\ (xs,ys) -> (wildPat:xs,ys)) pats,indexs) +first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs) where (pats,indexs) = check' (map remove_var qs) @@ -374,7 +374,7 @@ remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat make_row_vars used_lits (EqnInfo _ _ pats _ ) = - (nlVarPat new_var:takeList (tail pats) (repeat wildPat),[(new_var,used_lits)]) + (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)]) where new_var = hash_x hash_x = mkInternalName unboundKey {- doesn't matter much -} @@ -382,7 +382,7 @@ hash_x = mkInternalName unboundKey {- doesn't matter much -} noSrcLoc make_row_vars_for_constructor :: EquationInfo -> [WarningPat] -make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat wildPat) +make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat nlWildPat) compare_cons :: Pat Id -> Pat Id -> Bool compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2 @@ -562,11 +562,11 @@ make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) -- representation make_whole_con :: DataCon -> WarningPat -make_whole_con con | isInfixCon con = nlInfixConPat name wildPat wildPat +make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat | otherwise = nlConPat name pats where name = getName con - pats = [wildPat | t <- dataConOrigArgTys con] + pats = [nlWildPat | t <- dataConOrigArgTys con] \end{code} This equation makes the same thing as @tidy@ in @Match.lhs@, the @@ -650,12 +650,12 @@ simplify_pat (DictPat dicts methods) simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] simplify_con con (RecCon fs) - | null fs = PrefixCon [wildPat | t <- dataConOrigArgTys con] + | null fs = PrefixCon [nlWildPat | t <- dataConOrigArgTys con] -- Special case for null patterns; maybe not a record at all | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats) where -- pad out all the missing fields with WildPats. - field_pats = map (\ f -> (getName f, wildPat)) + field_pats = map (\ f -> (getName f, nlWildPat)) (dataConFieldLabels con) all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc) field_pats fs diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index 789887c..3b61f8a 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -173,10 +173,10 @@ nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (PrefixCon (nOfThem (dataConSourceArity con) wildPat))) + (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) nlTuplePat pats box = noLoc (TuplePat pats box) -wildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking +nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index b24701d..0c4f500 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -529,7 +529,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth -- Need two splits because the selector can have a type like -- forall a. Foo a => forall b. Eq b => ... (arg_tys, _) = tcSplitFunTys tau2 - wild_pats = [wildPat | ty <- arg_tys] + wild_pats = [nlWildPat | ty <- arg_tys] mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth = -- A generic default method diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 83134d8..706ee3d 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -164,7 +164,7 @@ gen_Eq_binds tycon case maybeTyConSingleCon tycon of Just _ -> [] Nothing -> -- if cons don't match, then False - [([wildPat, wildPat], false_Expr)] + [([nlWildPat, nlWildPat], false_Expr)] else -- calc. and compare the tags [([a_Pat, b_Pat], untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] @@ -329,13 +329,13 @@ gen_Ord_binds tycon -- Catch this specially to avoid warnings -- about overlapping patterns from the desugarer, -- and to avoid unnecessary pattern-matching - = [([wildPat,wildPat], eqTag_Expr)] + = [([nlWildPat,nlWildPat], eqTag_Expr)] | otherwise = map pats_etc nonnullary_cons ++ (if single_con_type then -- Omit wildcards when there's just one [] -- constructor, to silence desugarer else - [([wildPat, wildPat], default_rhs)]) + [([nlWildPat, nlWildPat], default_rhs)]) where pats_etc data_con @@ -597,7 +597,7 @@ gen_Ix_binds tycon enum_index = mk_easy_FunBind tycon_loc index_RDR [noLoc (AsPat (noLoc c_RDR) - (nlTuplePat [a_Pat, wildPat] Boxed)), + (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] emptyBag ( nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( @@ -898,7 +898,7 @@ gen_Show_binds get_fixity tycon pats_etc data_con | nullary_con = -- skip the showParen junk... ASSERT(null bs_needed) - ([wildPat, con_pat], mk_showString_app con_str) + ([nlWildPat, con_pat], mk_showString_app con_str) | otherwise = ([a_Pat, con_pat], showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one)))) @@ -1004,7 +1004,7 @@ gen_Typeable_binds tycon = unitBag $ mk_easy_FunBind tycon_loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function - [wildPat] emptyBag + [nlWildPat] emptyBag (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where tycon_loc = getSrcSpan tycon @@ -1065,6 +1065,7 @@ gen_Data_binds fix_env tycon tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon data_cons = tyConDataCons tycon + n_cons = length data_cons ------------ gfoldl gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) @@ -1084,14 +1085,17 @@ gen_Data_binds fix_env tycon gunfold_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) (map gunfold_alt data_cons) - gunfold_alt dc = - mkSimpleHsAlt (nlConPat intDataCon_RDR - [nlLitPat (HsIntPrim (toInteger (dataConTag dc)))]) - (foldr nlHsApp + gunfold_alt dc + = mkSimpleHsAlt (mk_tag_pat dc) + (foldr nlHsApp (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) - (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) - ) - + (replicate (dataConSourceArity dc) (nlHsVar k_RDR))) + mk_tag_pat dc -- Last one is a wild-pat, to avoid + -- redundant test, and annoying warning + | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor + | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))] + where + tag = dataConTag dc ------------ toConstr toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) @@ -1101,7 +1105,7 @@ gen_Data_binds fix_env tycon dataTypeOf_bind = mk_easy_FunBind tycon_loc dataTypeOf_RDR - [wildPat] + [nlWildPat] emptyBag (nlHsVar data_type_name)