import StaticFlags
import CostCentre
import Id
-import Var
import VarSet
+import VarEnv
import DataCon
import TysWiredIn
import BasicTypes
dsExpr :: HsExpr Id -> DsM CoreExpr
dsExpr (HsPar e) = dsLExpr e
+
+dsExpr (HsHetMetBrak c e) = do { e' <- dsExpr (unLoc e)
+ ; brak <- dsLookupGlobalId hetmet_brak_name
+ ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
+dsExpr (HsHetMetEsc c t e) = do { e' <- dsExpr (unLoc e)
+ ; esc <- dsLookupGlobalId hetmet_esc_name
+ ; return $ mkApps (Var esc) [ (Type c), (Type t), e'] }
+dsExpr (HsHetMetCSP c e) = do { e' <- dsExpr (unLoc e)
+ ; csp <- dsLookupGlobalId hetmet_csp_name
+ ; return $ mkApps (Var csp) [ (Type c), (Type $ exprType e'), e'] }
dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = return (Var var)
dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
--
dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
-dsExpr (HsDo DoExpr stmts res_ty) = dsDo stmts res_ty
-dsExpr (HsDo GhciStmt stmts res_ty) = dsDo stmts res_ty
-dsExpr (HsDo MDoExpr stmts res_ty) = dsDo stmts res_ty
-dsExpr (HsDo MonadComp stmts res_ty) = dsMonadComp stmts res_ty
+dsExpr (HsDo DoExpr stmts _) = dsDo stmts
+dsExpr (HsDo GhciStmt stmts _) = dsDo stmts
+dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
+dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
mk_alt upd_fld_env con
= do { let (univ_tvs, ex_tvs, eq_spec,
- eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
+ theta, arg_tys, _) = dataConFullSig con
subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
-- I'm not bothering to clone the ex_tvs
; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
- ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
+ ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
wrap = mkWpEvVarApps theta_vars `WpCompose`
mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
- , isNothing (lookupTyVar wrap_subst tv) ]
+ , not (tv `elemVarEnv` wrap_subst) ]
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
-- Tediously wrap the application in a cast
-- Note [Update for GADTs]
wrapped_rhs | null eq_spec = rhs
| otherwise = mkLHsWrap (WpCast wrap_co) rhs
- wrap_co = mkTyConApp tycon [ lookup tv ty
- | (tv,ty) <- univ_tvs `zip` out_inst_tys]
- lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
- Just ty' -> ty'
- Nothing -> ty
- wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
- | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
-
+ wrap_co = mkTyConAppCo tycon [ lookup tv ty
+ | (tv,ty) <- univ_tvs `zip` out_inst_tys]
+ lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
+ Just co' -> co'
+ Nothing -> mkReflCo ty
+ wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
+ | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
+
pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
, pat_dicts = eqs_vars ++ theta_vars
, pat_binds = emptyTcEvBinds
dsExpr (HsBinTick ixT ixF e) = do
e2 <- dsLExpr e
- do { ASSERT(exprType e2 `coreEqType` boolTy)
+ do { ASSERT(exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
\end{code}
Haskell 98 report:
\begin{code}
-dsDo :: [LStmt Id]
- -> Type -- Type of the whole expression
- -> DsM CoreExpr
-
-dsDo stmts result_ty
+dsDo :: [LStmt Id] -> DsM CoreExpr
+dsDo stmts
= goL stmts
where
goL [] = panic "dsDo"
goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
- go _ (LastStmt body ret_op) stmts
- = ASSERT( null stmts )
- do { body' <- dsLExpr body
- ; ret_op' <- dsExpr ret_op
- ; return (App ret_op' body') }
+ go _ (LastStmt body _) stmts
+ = ASSERT( null stmts ) dsLExpr body
+ -- The 'return' op isn't used for 'do' expressions
go _ (ExprStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+ tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats
rets = map noLoc rec_rets
(mkFunTy tup_ty body_ty))
mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
- ret_stmt = noLoc $ LastStmt return_op (mkLHsTupleExpr rets)
- tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+ ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
+ ret_stmt = noLoc $ mkLastStmt ret_app
+ -- This LastStmt will be desugared with dsDo,
+ -- which ignores the return_op in the LastStmt,
+ -- so we must apply the return_op explicitly
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
| idName v `elem` conversionNames
, let fun_ty = exprType (co_fn (Var v))
, Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
- , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty
+ , arg_ty `eqType` res_ty -- So we are converting ty -> ty
= warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
, nest 2 $ ptext (sLit "can probably be omitted")
, parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
-- but only if we didn't already warn due to Opt_WarnUnusedDoBind
do { warn_wrong <- doptDs Opt_WarnWrongDoBind
; case tcSplitAppTy_maybe elt_ty of
- Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty
+ Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
-> warnDs (wrongMonadBind rhs elt_ty)
_ -> return () } }
projects / ghc-hetmet.git / blobdiff