#endif
import HsSyn
-import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
import StaticFlags
import CostCentre
import Id
-import Var
import VarSet
+import VarEnv
import DataCon
import TysWiredIn
import BasicTypes
dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
-dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn
- ; e' <- dsExpr e
- ; return (co_fn' e') }
+
+dsExpr (HsWrap co_fn e)
+ = do { co_fn' <- dsHsWrapper co_fn
+ ; e' <- dsExpr e
+ ; warn_id <- doptDs Opt_WarnIdentities
+ ; when warn_id $ warnAboutIdentities e' co_fn'
+ ; return (co_fn' e') }
dsExpr (NegApp expr neg_expr)
= App <$> dsExpr neg_expr <*> dsLExpr expr
dsExpr (HsDo GhciStmt stmts body result_ty)
= dsDo stmts body result_ty
-dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
- = do { (meth_binds, tbl') <- dsSyntaxTable tbl
- ; core_expr <- dsMDo ctxt tbl' stmts body result_ty
- ; return (mkLets meth_binds core_expr) }
+dsExpr (HsDo MDoExpr stmts body result_ty)
+ = dsDo stmts body result_ty
dsExpr (HsDo PArrComp stmts body result_ty)
= -- Special case for array comprehensions
where
[elt_ty] = tcTyConAppArgs result_ty
-dsExpr (HsIf guard_expr then_expr else_expr)
- = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
+dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
+ = do { pred <- dsLExpr guard_expr
+ ; b1 <- dsLExpr then_expr
+ ; b2 <- dsLExpr else_expr
+ ; case mb_fun of
+ Just fun -> do { core_fun <- dsExpr fun
+ ; return (mkCoreApps core_fun [pred,b1,b2]) }
+ Nothing -> return $ mkIfThenElse pred b1 b2 }
\end{code}
-- singletonP x1 +:+ ... +:+ singletonP xn
--
dsExpr (ExplicitPArr ty []) = do
- emptyP <- dsLookupGlobalId emptyPName
+ emptyP <- dsLookupDPHId emptyPName
return (Var emptyP `App` Type ty)
dsExpr (ExplicitPArr ty xs) = do
- singletonP <- dsLookupGlobalId singletonPName
- appP <- dsLookupGlobalId appPName
+ singletonP <- dsLookupDPHId singletonPName
+ appP <- dsLookupDPHId appPName
xs' <- mapM dsLExpr xs
return . foldr1 (binary appP) $ map (unary singletonP) xs'
where
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}
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
- , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts
+ , recS_rec_rets = rec_rets }) stmts
= ASSERT( length rec_ids > 0 )
- ASSERT( isEmptyTcEvBinds _ev_binds ) -- No method binds
goL (new_bind_stmt : stmts)
where
-- returnE <- dsExpr return_id
-- mfixE <- dsExpr mfix_id
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
bind_op
- noSyntaxExpr -- Tuple cannot fail
+ noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
rec_tup_pats = map nlVarPat tup_ids
body_ty = mkAppTy m_ty tup_ty
tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
- handle_failure pat match fail_op
- | matchCanFail match
- = do { fail_op' <- dsExpr fail_op
- ; fail_msg <- mkStringExpr (mk_fail_msg pat)
- ; extractMatchResult match (App fail_op' fail_msg) }
- | otherwise
- = extractMatchResult match (error "It can't fail")
+handle_failure pat match fail_op
+ | matchCanFail match
+ = do { fail_op' <- dsExpr fail_op
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; extractMatchResult match (App fail_op' fail_msg) }
+ | otherwise
+ = extractMatchResult match (error "It can't fail")
mk_fail_msg :: Located e -> String
mk_fail_msg pat = "Pattern match failure in do expression at " ++
return (v1,..vn))
\begin{code}
-dsMDo :: HsStmtContext Name
+{-
+dsMDo :: HsStmtContext Name
-> [(Name,Id)]
-> [LStmt Id]
-> LHsExpr Id
goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
(m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
- mfix_id = lookupEvidence tbl mfixName
return_id = lookupEvidence tbl returnMName
bind_id = lookupEvidence tbl bindMName
then_id = lookupEvidence tbl thenMName
= do { rest <- goL stmts
; dsLocalBinds binds rest }
- go _ (ExprStmt rhs _ rhs_ty) stmts
+ go _ (ExprStmt rhs then_expr rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs
; warnDiscardedDoBindings rhs m_ty rhs_ty
+ ; then_expr2 <- dsExpr then_expr
; rest <- goL stmts
- ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
+ ; return (mkApps then_expr2 [rhs2, rest]) }
- go _ (BindStmt pat rhs _ _) stmts
- = do { body <- goL stmts
- ; var <- selectSimpleMatchVarL pat
+ go _ (BindStmt pat rhs bind_op _) stmts
+ = do { body <- goL stmts
+ ; rhs' <- dsLExpr rhs
+ ; bind_op' <- dsExpr bind_op
+ ; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
- result_ty (cantFailMatchResult body)
- ; fail_msg <- mkStringExpr (mk_fail_msg pat)
- ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
- ; match_code <- extractMatchResult match fail_expr
-
- ; rhs' <- dsLExpr rhs
- ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
- rhs', Lam var match_code]) }
+ result_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; return (mkApps bind_op [rhs', Lam var match_code]) }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
- , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
- , recS_dicts = _ev_binds }) stmts
+ , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
+ , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
= ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets )
ASSERT( isEmptyTcEvBinds _ev_binds )
pprTrace "dsMDo" (ppr later_ids) $
goL (new_bind_stmt : stmts)
where
- new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
+ new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
+ bind_op noSyntaxExpr
-- Remove the later_ids that appear (without fancy coercions)
-- in rec_rets, because there's no need to knot-tie them separately
later_ids' = filter (`notElem` mono_rec_ids) later_ids
mono_rec_ids = [ id | HsVar id <- rec_rets ]
- mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
+ mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
body_ty = mkAppTy m_ty tup_ty
tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
- return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
- (mkLHsTupleExpr rets)
+ return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
mk_wild_pat :: Id -> LPat Id
mk_wild_pat v = noLoc $ WildPat $ idType v
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
+-}
\end{code}
%************************************************************************
%* *
+ Warning about identities
+%* *
+%************************************************************************
+
+Warn about functions that convert between one type and another
+when the to- and from- types are the same. Then it's probably
+(albeit not definitely) the identity
+\begin{code}
+warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
+warnAboutIdentities (Var v) co_fn
+ | idName v `elem` conversionNames
+ , let fun_ty = exprType (co_fn (Var v))
+ , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_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)"))
+ ])
+warnAboutIdentities _ _ = return ()
+
+conversionNames :: [Name]
+conversionNames
+ = [ toIntegerName, toRationalName
+ , fromIntegralName, realToFracName ]
+ -- We can't easily add fromIntegerName, fromRationalName,
+ -- becuase they are generated by literals
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Errors and contexts}
%* *
%************************************************************************
warnDiscardedDoBindings rhs container_ty returning_ty = do {
-- Warn about discarding non-() things in 'monadic' binding
; warn_unused <- doptDs Opt_WarnUnusedDoBind
- ; if warn_unused && not (returning_ty `tcEqType` unitTy)
+ ; if warn_unused && not (returning_ty `eqType` unitTy)
then warnDs (unusedMonadBind rhs returning_ty)
else do {
-- Warn about discarding m a things in 'monadic' binding of the same type,
-- but only if we didn't already warn due to Opt_WarnUnusedDoBind
; warn_wrong <- doptDs Opt_WarnWrongDoBind
; case tcSplitAppTy_maybe returning_ty of
- Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
+ Just (returning_container_ty, _) -> when (warn_wrong && container_ty `eqType` returning_container_ty) $
warnDs (wrongMonadBind rhs returning_ty)
_ -> return () } }
projects / ghc-hetmet.git / blobdiff