Normalise the type when generating do-bind warnings (Trac #8470)
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 23 Oct 2013 11:12:39 +0000 (12:12 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 23 Oct 2013 11:12:39 +0000 (12:12 +0100)
This was easy to do, except that the desugar monad needs a
FamInstEnv init.  Straightforward, routine, albeit a bit clunky.

compiler/deSugar/Desugar.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMonad.lhs
compiler/main/HscMain.hs
compiler/vectorise/Vectorise/Monad.hs

index 20a8a57..46b6492 100644 (file)
@@ -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)
index 6d78d33..9ede48f 100644 (file)
@@ -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}
index dead398..ca413d1 100644 (file)
@@ -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) }
 
index 331ec6d..7f70cab 100644 (file)
@@ -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
 
index 04a0bf2..6f6d40f 100644 (file)
@@ -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