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 FieldLabel ( allFieldLabelTags, fieldLabelTag )
import Id ( idType, mkTupleCon, dataConSig,
- recordSelectorFieldLabel,
+ dataConArgTys, recordSelectorFieldLabel,
GenId{-instance-}
)
import PprStyle ( PprStyle(..) )
integerTy, intPrimTy, charPrimTy,
floatPrimTy, doublePrimTy, stringTy,
addrTy, addrPrimTy, addrDataCon,
- wordTy, wordPrimTy, wordDataCon )
+ wordTy, wordPrimTy, wordDataCon,
+ pAT_ERROR_ID
+ )
import Type ( isPrimType, eqTy, getAppDataTyCon,
instantiateTauTy
)
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
+ pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (tyvars, _, arg_tys, _) = dataConSig con_id
- (_, inst_tys, _) = getAppDataTyCon pat_ty
- tenv = tyvars `zip` inst_tys
- con_arg_tys' = map (instantiateTauTy tenv) arg_tys
- tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
+ (_, 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
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,
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}
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}