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,
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
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}
projects / ghc-hetmet.git / blobdiff