Commit e359a65d authored by Simon Peyton Jones's avatar Simon Peyton Jones

Normalise the type when generating do-bind warnings (Trac #8470)

This was easy to do, except that the desugar monad needs a
FamInstEnv init.  Straightforward, routine, albeit a bit clunky.
parent dc9961f9
......@@ -31,6 +31,7 @@ import Module
import RdrName
import NameSet
import NameEnv
import FamInstEnv ( FamInstEnv )
import Rules
import BasicTypes ( Activation(.. ) )
import CoreMonad ( endPass, CoreToDo(..) )
......@@ -90,24 +91,22 @@ deSugar hsc_env
-- Desugar the program
; let export_set = availsToNameSet exports
; let target = hscTarget dflags
; let hpcInfo = emptyHpcInfo other_hpc_info
; (msgs, mb_res) <- do
let want_ticks = gopt Opt_Hpc dflags
|| target == HscInterpreted
|| (gopt Opt_SccProfilingOn dflags
&& case profAuto dflags of
NoProfAuto -> False
_ -> True)
(binds_cvr,ds_hpc_info, modBreaks)
target = hscTarget dflags
hpcInfo = emptyHpcInfo other_hpc_info
want_ticks = gopt Opt_Hpc dflags
|| target == HscInterpreted
|| (gopt Opt_SccProfilingOn dflags
&& case profAuto dflags of
NoProfAuto -> False
_ -> True)
; (binds_cvr, ds_hpc_info, modBreaks)
<- if want_ticks && not (isHsBoot hsc_src)
then addTicksToBinds dflags mod mod_loc export_set
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
......@@ -120,14 +119,13 @@ deSugar hsc_env
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init
, ds_hpc_info, modBreaks) }
, ds_fords `appendStubC` hpc_init ) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
{ -- Add export flags to bindings
do { -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
......@@ -221,23 +219,23 @@ and Rec the rest.
\begin{code}
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> LHsExpr Id
-> IO (Messages, Maybe CoreExpr)
-- Prints its own errors; returns Nothing if error occurred
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
deSugarExpr hsc_env this_mod rdr_env type_env fam_inst_env tc_expr
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar"
-- Do desugaring
; (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
; (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env
type_env fam_inst_env $
dsLExpr tc_expr
; case mb_core_expr of {
Nothing -> return (msgs, Nothing) ;
Just expr ->
-- Dump output
do { dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
......
......@@ -20,6 +20,7 @@ import DsArrows
import DsMonad
import Name
import NameEnv
import FamInstEnv( topNormaliseType )
#ifdef GHCI
-- Template Haskell stuff iff bootstrapped
......@@ -825,31 +826,36 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
| Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
= do { -- Warn about discarding non-() things in 'monadic' binding
; warn_unused <- woptM Opt_WarnUnusedDoBind
; if warn_unused && not (isUnitTy elt_ty)
then warnDs (unusedMonadBind rhs elt_ty)
else
-- 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
do { warn_wrong <- woptM Opt_WarnWrongDoBind
; case tcSplitAppTy_maybe elt_ty of
Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
-> warnDs (wrongMonadBind rhs elt_ty)
_ -> return () } }
= do { warn_unused <- woptM Opt_WarnUnusedDoBind
; warn_wrong <- woptM Opt_WarnWrongDoBind
; when (warn_unused || warn_wrong) $
do { fam_inst_envs <- dsGetFamInstEnvs
; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
-- Warn about discarding non-() things in 'monadic' binding
; if warn_unused && not (isUnitTy norm_elt_ty)
then warnDs (badMonadBind rhs elt_ty
(ptext (sLit "-fno-warn-unused-do-bind")))
else
-- 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
when warn_wrong $
do { case tcSplitAppTy_maybe norm_elt_ty of
Just (elt_m_ty, _)
| m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
-> warnDs (badMonadBind rhs elt_ty
(ptext (sLit "-fno-warn-wrong-do-bind")))
_ -> return () } } }
| otherwise -- RHS does have type of form (m ty), which is weird
= return () -- but at lesat this warning is irrelevant
unusedMonadBind :: LHsExpr Id -> Type -> SDoc
unusedMonadBind rhs elt_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
wrongMonadBind :: LHsExpr Id -> Type -> SDoc
wrongMonadBind rhs elt_ty
= ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc
badMonadBind rhs elt_ty flag_doc
= vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type"))
2 (quotes (ppr elt_ty))
, hang (ptext (sLit "Suppress this warning by saying"))
2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
, ptext (sLit "or by using the flag") <+> flag_doc ]
\end{code}
......@@ -19,7 +19,7 @@ module DsMonad (
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
PArrBuiltin(..),
......@@ -38,6 +38,7 @@ module DsMonad (
) where
import TcRnMonad
import FamInstEnv
import CoreSyn
import HsSyn
import TcIface
......@@ -154,7 +155,8 @@ data PArrBuiltin
data DsGblEnv
= DsGblEnv
{ ds_mod :: Module -- For SCC profiling
{ ds_mod :: Module -- For SCC profiling
, ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env
, ds_unqual :: PrintUnqualified
, ds_msgs :: IORef Messages -- Warning messages
, ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
......@@ -187,15 +189,15 @@ data DsMetaVal
-- the PendingSplices on a HsBracketOut
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> DsM a
-> IO (Messages, Maybe a)
-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env thing_inside
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $
......@@ -272,15 +274,17 @@ initDsTc thing_inside
; dflags <- getDynFlags
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env msg_var
fam_inst_env = tcg_fam_inst_env tcg_env
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env msg_var
; setEnvs ds_envs thing_inside
}
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env msg_var
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
= let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
, ds_if_env = (if_genv, if_lenv)
, ds_unqual = mkPrintUnqualified dflags rdr_env
, ds_msgs = msg_var
......@@ -470,11 +474,18 @@ dsInitPArrBuiltin thing_inside
where
externalVar :: FastString -> DsM Var
externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
arithErr = panic "Arithmetic sequences have to wait until we support type classes"
\end{code}
\begin{code}
dsGetFamInstEnvs :: DsM FamInstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
dsGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) }
......
......@@ -1350,10 +1350,12 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
Nothing -> return Nothing
Just parsed_stmt -> do
let icntxt = hsc_IC hsc_env
rdr_env = ic_rn_gbl_env icntxt
type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
src_span = srcLocSpan interactiveSrcLoc
let icntxt = hsc_IC hsc_env
rdr_env = ic_rn_gbl_env icntxt
type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
fam_insts = snd (ic_instances icntxt)
fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
src_span = srcLocSpan interactiveSrcLoc
-- Rename and typecheck it
-- Here we lift the stmt into the IO monad, see Note
......@@ -1362,7 +1364,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
-- Desugar it
ds_expr <- ioMsgMaybe $
deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
deSugarExpr hsc_env iNTERACTIVE rdr_env type_env fam_inst_env tc_expr
liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
handleWarnings
......
......@@ -56,7 +56,8 @@ initV hsc_env guts info thing_inside
; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
; (_, Just res) <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts) type_env go
(mg_rdr_env guts) type_env
(mg_fam_inst_env guts) go
; case res of
Nothing
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment