import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), StmtCtxt(..), Match(..), HsBinds(..), MonoBinds(..),
- mkSimpleMatch
+ Stmt(..), HsMatchContext(..), Match(..), HsBinds(..), MonoBinds(..),
+ mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
TypecheckedStmt
)
import Match ( matchWrapper, matchSimply )
+import FieldLabel ( FieldLabel, fieldLabelTyCon )
import CostCentre ( mkUserCC )
import Id ( Id, idType, recordSelectorFieldLabel )
import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConArgTys, dataConFieldLabels )
import DataCon ( isExistentialDataCon )
import Literal ( Literal(..) )
+import TyCon ( tyConDataCons )
import Type ( splitFunTys,
- splitAlgTyConApp, splitAlgTyConApp_maybe, splitTyConApp_maybe,
- isNotUsgTy, unUsgTy,
+ splitAlgTyConApp, splitTyConApp_maybe, tyConAppArgs,
splitAppTy, isUnLiftedType, Type
)
import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon, isIntegerTy )
import BasicTypes ( RecFlag(..), Boxity(..) )
import Maybes ( maybeToBool )
-import Unique ( hasKey, ratioTyConKey )
+import PrelNames ( hasKey, ratioTyConKey )
import Util ( zipEqual, zipWithEqual )
import Outputable
in
mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat))
`thenDs` \ error_expr ->
- matchSimply rhs PatBindMatch pat body' error_expr
+ matchSimply rhs PatBindRhs pat body' error_expr
where
result_ty = exprType body
-- HsOverLit has been gotten rid of by the type checker
dsExpr expr@(HsLam a_Match)
- = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
+ = matchWrapper LambdaExpr [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
returnDs (mkLams binders matching_code)
dsExpr expr@(HsApp fun arg)
dsExpr (HsCase discrim matches src_loc)
| all ubx_tuple_match matches
= putSrcLocDs src_loc $
- dsExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
case matching_code of
Case (Var x) bndr alts | x == discrim_var ->
returnDs (Case core_discrim bndr alts)
dsExpr (HsCase discrim matches src_loc)
= putSrcLocDs src_loc $
- dsExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
-> Just elt_ty
other -> Nothing
-- We need the ListComp form to use deListComp (rather than the "do" form)
- -- because the "return" in a do block is a call to "PrelBase.return", and
- -- not a ReturnStmt. Only the ListComp form has ReturnStmts
+ -- because the interpretation of ExprStmt depends on what sort of thing
+ -- it is.
Just elt_ty = maybe_list_comp
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
- ASSERT( isNotUsgTy ty )
returnDs (mkConsExpr ty core_x core_xs)
dsExpr (ExplicitTuple expr_list boxity)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
returnDs (mkConApp (tupleCon boxity (length expr_list))
- (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs))
- -- the above unUsgTy is *required* -- KSW 1999-04-07
+ (map (Type . exprType) core_exprs ++ core_exprs))
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
dictionaries.
\begin{code}
+dsExpr (RecordUpdOut record_expr record_out_ty dicts [])
+ = dsExpr record_expr
+
dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
- = getSrcLocDs `thenDs` \ src_loc ->
+ = getSrcLocDs `thenDs` \ src_loc ->
dsExpr record_expr `thenDs` \ record_expr' ->
-- Desugar the rbinds, and generate let-bindings if
-- necessary so that we don't lose sharing
let
- record_in_ty = exprType record_expr'
- (_, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
- (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
- cons_to_upd = filter has_all_fields cons
+ record_in_ty = exprType record_expr'
+ in_inst_tys = tyConAppArgs record_in_ty
+ out_inst_tys = tyConAppArgs record_out_ty
mk_val_arg field old_arg_id
= case [rhs | (sel_id, rhs, _) <- rbinds,
src_loc)
in
-- Record stuff doesn't work for existentials
- ASSERT( all (not . isExistentialDataCon) cons )
+ ASSERT( all (not . isExistentialDataCon) data_cons )
-- It's important to generate the match with matchWrapper,
-- and the right hand sides with applications of the wrapper Id
-- so that everything works when we are doing fancy unboxing on the
-- constructor aguments.
- mapDs mk_alt cons_to_upd `thenDs` \ alts ->
- matchWrapper RecUpdMatch alts "record update" `thenDs` \ ([discrim_var], matching_code) ->
+ mapDs mk_alt cons_to_upd `thenDs` \ alts ->
+ matchWrapper RecUpd alts "record update" `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var record_expr' matching_code)
where
+ updated_fields :: [FieldLabel]
+ updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_,_) <- rbinds]
+
+ -- Get the type constructor from the first field label,
+ -- so that we are sure it'll have all its DataCons
+ -- (In GHCI, it's possible that some TyCons may not have all
+ -- their constructors, in a module-loop situation.)
+ tycon = fieldLabelTyCon (head updated_fields)
+ data_cons = tyConDataCons tycon
+ cons_to_upd = filter has_all_fields data_cons
+
has_all_fields :: DataCon -> Bool
has_all_fields con_id
- = all ok rbinds
+ = all (`elem` con_fields) updated_fields
where
- con_fields = dataConFieldLabels con_id
- ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields
+ con_fields = dataConFieldLabels con_id
\end{code}
Basically does the translation given in the Haskell~1.3 report:
\begin{code}
-dsDo :: StmtCtxt
+dsDo :: HsMatchContext
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
= let
(_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
- go [ReturnStmt expr]
- = dsExpr expr `thenDs` \ expr2 ->
- returnDs (mkApps (Var return_id) [Type b_ty, expr2])
-
- go (GuardStmt expr locn : stmts)
- = do_expr expr locn `thenDs` \ expr2 ->
- go stmts `thenDs` \ rest ->
- let msg = ASSERT( isNotUsgTy b_ty )
- "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
- in
- mkStringLit msg `thenDs` \ core_msg ->
- returnDs (mkIfThenElse expr2
- rest
- (App (App (Var fail_id)
- (Type b_ty))
- core_msg))
-
+ -- For ExprStmt, see the comments near HsExpr.HsStmt about
+ -- exactly what ExprStmts mean!
+ --
+ -- In dsDo we can only see DoStmt and ListComp (no gaurds)
+
+ go [ResultStmt expr locn]
+ | isDoExpr do_or_lc = do_expr expr locn
+ | otherwise = do_expr expr locn `thenDs` \ expr2 ->
+ returnDs (mkApps (Var return_id) [Type b_ty, expr2])
+
go (ExprStmt expr locn : stmts)
+ | isDoExpr do_or_lc
= do_expr expr locn `thenDs` \ expr2 ->
+ go stmts `thenDs` \ rest ->
let
(_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a)
in
- if null stmts then
- returnDs expr2
- else
- go stmts `thenDs` \ rest ->
- newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
- Lam ignored_result_id rest])
+ newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
+ Lam ignored_result_id rest])
+
+ | otherwise -- List comprehension
+ = do_expr expr locn `thenDs` \ expr2 ->
+ go stmts `thenDs` \ rest ->
+ let
+ msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ in
+ mkStringLit msg `thenDs` \ core_msg ->
+ returnDs (mkIfThenElse expr2 rest
+ (App (App (Var fail_id) (Type b_ty)) core_msg))
go (LetStmt binds : stmts )
= go stmts `thenDs` \ rest ->
(_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a)
fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
(HsLit (HsString (_PK_ msg)))
- msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty )
- ASSERT2( isNotUsgTy b_ty, ppr b_ty )
- "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(HsDoOut do_or_lc stmts return_id then_id
fail_id result_ty locn)
, mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
]
in
- matchWrapper DoBindMatch the_matches match_msg
+ matchWrapper DoExpr the_matches match_msg
`thenDs` \ (binders, matching_code) ->
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
match_msg = case do_or_lc of
- DoStmt -> "`do' statement"
+ DoExpr -> "`do' statement"
ListComp -> "comprehension"
\end{code}
returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, [i_ty], [con])
+ = case splitAlgTyConApp ty of
+ (tycon, [i_ty], [con])
-> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(con, i_ty)
-
- _ -> (panic "ratio_data_con", panic "integer_ty")
\end{code}
projects / ghc-hetmet.git / blobdiff