X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=5437929a7bb0870d27d4e3e2e6a9da0c68b9cb10;hb=68afb16743cafd5b7495771d359891c6dfc5a186;hp=f657e967a3938b55d329ce1a36e6207e9ee604a8;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index f657e96..5437929 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -12,33 +12,41 @@ import Ubiq import DsLoop -- here for paranoia-checking reasons -- and to break dsExpr/dsBinds-ish loop -import HsSyn +import HsSyn hiding ( collectBinders{-also from CoreSyn-} ) import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..), TypecheckedHsBinds(..), TypecheckedHsExpr(..) ) import DsHsSyn ( outPatType, collectTypedPatBinders ) import CoreSyn +import CoreUtils ( coreExprType ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) -import CoreUtils ( escErrorMsg, mkErrorApp ) -import Id ( idType, mkTupleCon, GenId{-instance-} ) +import FieldLabel ( allFieldLabelTags, fieldLabelTag ) +import Id ( idType, mkTupleCon, dataConSig, + dataConArgTys, recordSelectorFieldLabel, + GenId{-instance-} + ) import PprStyle ( PprStyle(..) ) -import PprType ( GenTyVar{-instance-}, GenType{-instance-} ) +import PprType ( GenType{-instance-}, GenTyVar{-ditto-} ) import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy, charTy, charDataCon, intTy, intDataCon, floatTy, floatDataCon, doubleTy, doubleDataCon, integerTy, intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, stringTy, addrTy, addrPrimTy, addrDataCon, - wordTy, wordPrimTy, wordDataCon ) -import Type ( isPrimType, eqTy ) -import TyVar ( GenTyVar ) -import Unique ( Unique ) -import Util ( panic, pprPanic ) + wordTy, wordPrimTy, wordDataCon, + pAT_ERROR_ID + ) +import Type ( isPrimType, eqTy, getAppDataTyCon, + instantiateTauTy + ) +import TyVar ( GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) +import Util ( panic, pprPanic, assertPanic ) \end{code} The function @match@ is basically the same as in the Wadler chapter, @@ -320,6 +328,25 @@ tidy1 v (LazyPat pat) match_result tidy1 v (ConOpPat pat1 id pat2 ty) match_result = returnDs (ConPat id ty [pat1, pat2], match_result) +tidy1 v (RecPat con_id pat_ty rpats) match_result + = returnDs (ConPat con_id pat_ty pats, match_result) + where + pats = map mk_pat tagged_arg_tys + + -- Boring stuff to find the arg-tys of the constructor + (_, inst_tys, _) = {-_trace "getAppDataTyCon.Match" $-} getAppDataTyCon pat_ty + con_arg_tys' = dataConArgTys con_id inst_tys + tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags + + -- mk_pat picks a WildPat of the appropriate type for absent fields, + -- and the specified pattern for present fields + mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats, + fieldLabelTag (recordSelectorFieldLabel sel_id) == tag + ] of + (pat:pats) -> ASSERT( null pats ) + pat + [] -> WildPat arg_ty + tidy1 v (ListPat ty pats) match_result = returnDs (list_ConPat, match_result) where @@ -486,21 +513,24 @@ matchUnmixedEqns :: [Id] matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names" matchUnmixedEqns all_vars@(var:vars) eqns_info shadows - | unfailablePats column_1_pats -- Could check just one; we know they've been tidied, unmixed; - -- this way is (arguably) a sanity-check - = -- Real true variables, just like in matchVar, SLPJ p 94 + | unfailablePat first_pat + = ASSERT( unfailablePats column_1_pats ) -- Sanity check + -- Real true variables, just like in matchVar, SLPJ p 94 match vars remaining_eqns_info remaining_shadows - | patsAreAllCons column_1_pats -- ToDo: maybe check just one... - = matchConFamily all_vars eqns_info shadows + | isConPat first_pat + = ASSERT( patsAreAllCons column_1_pats ) + matchConFamily all_vars eqns_info shadows - | patsAreAllLits column_1_pats -- ToDo: maybe check just one... - = -- see notes in MatchLiteral + | isLitPat first_pat + = ASSERT( patsAreAllLits column_1_pats ) + -- see notes in MatchLiteral -- not worried about the same literal more than once in a column -- (ToDo: sort this out later) matchLiterals all_vars eqns_info shadows where + first_pat = head column_1_pats column_1_pats = [pat | EqnInfo (pat:_) _ <- eqns_info] remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info] remaining_shadows = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows, @@ -586,16 +616,12 @@ matchWrapper kind [(GRHSMatch matchWrapper kind matches error_string = flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) -> - selectMatchVars arg_pats `thenDs` \ new_vars -> - match new_vars eqns_info [] `thenDs` \ match_result -> + selectMatchVars arg_pats `thenDs` \ new_vars -> + match new_vars eqns_info [] `thenDs` \ match_result -> + + mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> + extractMatchResult match_result fail_expr `thenDs` \ result_expr -> - getSrcLocDs `thenDs` \ (src_file, src_line) -> - newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String - let - src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line - fail_expr = mkErrorApp result_ty str_var (src_loc_str++": "++error_string) - in - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) \end{code} @@ -676,4 +702,15 @@ flattenMatches kind (match : matches) returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) where pats = reverse pats_so_far -- They've accumulated in reverse order + + flatten_match pats_so_far (SimpleMatch expr) + = dsExpr expr `thenDs` \ core_expr -> + returnDs (EqnInfo pats + (MatchResult CantFail (coreExprType core_expr) + (\ ignore -> core_expr) + NoMatchContext)) + -- The NoMatchContext is just a place holder. In a simple match, + -- the matching can't fail, so we won't generate an error message. + where + pats = reverse pats_so_far -- They've accumulated in reverse order \end{code}