Move orphan instance/rule warnings to typechecker/desugarer.
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Thu, 1 Oct 2015 22:24:41 +0000 (15:24 -0700)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Thu, 8 Oct 2015 22:55:08 +0000 (15:55 -0700)
Summary:
Instead of doing these warnings at MkIface time, we do them
when we create the instances/rules in the typechecker/desugarer.

Emitting warnings for auto-generated instances was a pain
(since the specialization monad doesn't have the capacity
to emit warnings) so instead I just deprecated -fwarn-auto-orphans.
Auto rule orphans are pretty harmless anyway: they don't cause
interface files to be eagerly loaded in.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1297

13 files changed:
compiler/deSugar/Desugar.hs
compiler/deSugar/DsBinds.hs
compiler/iface/MkIface.hs
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/specialise/Specialise.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcGenGenerics.hs
compiler/types/InstEnv.hs
docs/users_guide/using-warnings.rst
testsuite/tests/typecheck/should_compile/T4912.stderr
testsuite/tests/warnings/should_compile/T9178.stderr
utils/mkUserGuidePart/Options/Warnings.hs

index 1508922..dceebc1 100644 (file)
@@ -381,12 +381,12 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
               fn_name   = idName fn_id
               final_rhs = simpleOptExpr rhs''    -- De-crap it
               rule_name = snd (unLoc name)
-              rule      = mkRule this_mod False {- Not auto -} is_local
-                                 rule_name rule_act fn_name final_bndrs args
-                                 final_rhs
               arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
 
         ; dflags <- getDynFlags
+        ; rule <- dsMkUserRule this_mod is_local
+                         rule_name rule_act fn_name final_bndrs args
+                         final_rhs
         ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
           warnRuleShadowing rule_name rule_act fn_id arg_ids
 
index 28e866d..b8df7b8 100644 (file)
@@ -13,7 +13,7 @@ lower levels it is preserved with @let@/@letrec@s).
 {-# LANGUAGE CPP #-}
 
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
+                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
   ) where
 
 #include "HsVersions.h"
@@ -69,7 +69,7 @@ import DynFlags
 import FastString
 import Util
 import MonadUtils
-import Control.Monad(liftM)
+import Control.Monad(liftM,when)
 import Fingerprint(Fingerprint(..), fingerprintString)
 
 {-
@@ -450,7 +450,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
              spec_id   = mkLocalId spec_name spec_ty
                             `setInlinePragma` inl_prag
                             `setIdUnfolding`  spec_unf
-             rule =  mkRule this_mod False {- Not auto -} is_local_id
+       ; rule <- dsMkUserRule this_mod is_local_id
                         (mkFastString ("SPEC " ++ showPpr dflags poly_name))
                         rule_act poly_name
                         rule_bndrs args
@@ -503,6 +503,17 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
              | otherwise   = spec_prag_act                   -- Specified by user
 
 
+dsMkUserRule :: Module -> Bool -> RuleName -> Activation
+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
+dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
+    let rule = mkRule this_mod False is_local name act fn bndrs args rhs
+    dflags <- getDynFlags
+    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
+        warnDs (ruleOrphWarn rule)
+    return rule
+
+ruleOrphWarn :: CoreRule -> SDoc
+ruleOrphWarn rule = ptext (sLit "Orphan rule:") <+> ppr rule
 
 {- Note [SPECIALISE on INLINE functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 99544c4..43e57cd 100644 (file)
@@ -110,7 +110,6 @@ import Maybes
 import ListSetOps
 import Binary
 import Fingerprint
-import Bag
 import Exception
 
 import Control.Monad
@@ -135,11 +134,10 @@ mkIface :: HscEnv
         -> Maybe Fingerprint    -- The old fingerprint, if we have it
         -> ModDetails           -- The trimmed, tidied interface
         -> ModGuts              -- Usages, deprecations, etc
-        -> IO (Messages,
-               Maybe (ModIface, -- The new one
-                      Bool))    -- True <=> there was an old Iface, and the
-                                --          new one is identical, so no need
-                                --          to write it
+        -> IO (ModIface, -- The new one
+               Bool)     -- True <=> there was an old Iface, and the
+                         --          new one is identical, so no need
+                         --          to write it
 
 mkIface hsc_env maybe_old_fingerprint mod_details
          ModGuts{     mg_module       = this_mod,
@@ -198,7 +196,7 @@ mkIfaceTc :: HscEnv
           -> SafeHaskellMode    -- The safe haskell mode
           -> ModDetails         -- gotten from mkBootModDetails, probably
           -> TcGblEnv           -- Usages, deprecations, etc
-          -> IO (Messages, Maybe (ModIface, Bool))
+          -> IO (ModIface, Bool)
 mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
   tc_result@TcGblEnv{ tcg_mod = this_mod,
                       tcg_src = hsc_src,
@@ -268,7 +266,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
          -> [FilePath]
          -> SafeHaskellMode
          -> ModDetails
-         -> IO (Messages, Maybe (ModIface, Bool))
+         -> IO (ModIface, Bool)
 mkIface_ hsc_env maybe_old_fingerprint
          this_mod hsc_src used_names used_th deps rdr_env fix_env src_warns
          hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
@@ -354,38 +352,17 @@ mkIface_ hsc_env maybe_old_fingerprint
                    addFingerprints hsc_env maybe_old_fingerprint
                                    intermediate_iface decls
 
-    -- Warn about orphans
-    -- See Note [Orphans and auto-generated rules]
-    let warn_orphs      = wopt Opt_WarnOrphans dflags
-        warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
-        orph_warnings   --- Laziness means no work done unless -fwarn-orphans
-          | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
-          | otherwise                     = emptyBag
-        errs_and_warns = (orph_warnings, emptyBag)
-        unqual = mkPrintUnqualified dflags rdr_env
-        inst_warns = listToBag [ instOrphWarn dflags unqual d
-                               | (d,i) <- insts `zip` iface_insts
-                               , isOrphan (ifInstOrph i) ]
-        rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
-                               | r <- iface_rules
-                               , isOrphan (ifRuleOrph r)
-                               , if ifRuleAuto r then warn_auto_orphs
-                                                 else warn_orphs ]
-
-    if errorsFound dflags errs_and_warns
-      then return ( errs_and_warns, Nothing )
-      else do
-        -- Debug printing
-        dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
-                      (pprModIface new_iface)
+    -- Debug printing
+    dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
+                  (pprModIface new_iface)
 
-        -- bug #1617: on reload we weren't updating the PrintUnqualified
-        -- correctly.  This stems from the fact that the interface had
-        -- not changed, so addFingerprints returns the old ModIface
-        -- with the old GlobalRdrEnv (mi_globals).
-        let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
+    -- bug #1617: on reload we weren't updating the PrintUnqualified
+    -- correctly.  This stems from the fact that the interface had
+    -- not changed, so addFingerprints returns the old ModIface
+    -- with the old GlobalRdrEnv (mi_globals).
+    let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
 
-        return (errs_and_warns, Just (final_iface, no_change_at_all))
+    return (final_iface, no_change_at_all)
   where
 
      dflags = hsc_dflags hsc_env
@@ -725,25 +702,6 @@ mkIfaceAnnCache anns
     env = mkOccEnv_C (flip (++)) (map pair anns)
 
 {-
-Note [Orphans and auto-generated rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we specialise an INLINEABLE function, or when we have
--fspecialise-aggressively, we auto-generate RULES that are orphans.
-We don't want to warn about these, at least not by default, or we'd
-generate a lot of warnings.  Hence -fwarn-auto-orphans.
-
-Indeed, we don't even treat the module as an oprhan module if it has
-auto-generated *rule* orphans.  Orphan modules are read every time we
-compile, so they are pretty obtrusive and slow down every compilation,
-even non-optimised ones.  (Reason: for type class instances it's a
-type correctness issue.)  But specialisation rules are strictly for
-*optimisation* only so it's fine not to read the interface.
-
-What this means is that a SPEC rules from auto-specialisation in
-module M will be used in other modules only if M.hi has been read for
-some other reason, which is actually pretty likely.
-
-
 ************************************************************************
 *                                                                      *
           The ABI of an IfaceDecl
@@ -945,27 +903,6 @@ oldMD5 dflags bh = do
         return $! readHexFingerprint hash_str
 -}
 
-instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
-instOrphWarn dflags unqual inst
-  = mkWarnMsg dflags (getSrcSpan inst) unqual $
-    hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
-    $$ text "To avoid this"
-    $$ nest 4 (vcat possibilities)
-  where
-    possibilities =
-      text "move the instance declaration to the module of the class or of the type, or" :
-      text "wrap the type with a newtype and declare the instance on the new type." :
-      []
-
-ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
-ruleOrphWarn dflags unqual mod rule
-  = mkWarnMsg dflags silly_loc unqual $
-    ptext (sLit "Orphan rule:") <+> ppr rule
-  where
-    silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
-    -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
-    -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
-
 ----------------------
 -- mkOrphMap partitions instance decls or rules into
 --      (a) an OccEnv for ones that are not orphans,
index 0978c11..4d5d727 100644 (file)
@@ -2876,7 +2876,8 @@ fWarningFlags = [
                                       Opt_WarnAlternativeLayoutRuleTransitional,
   flagSpec' "warn-amp"                        Opt_WarnAMP
     (\_ -> deprecate "it has no effect, and will be removed in GHC 7.12"),
-  flagSpec "warn-auto-orphans"                Opt_WarnAutoOrphans,
+  flagSpec' "warn-auto-orphans"               Opt_WarnAutoOrphans
+    (\_ -> deprecate "it has no effect"),
   flagSpec "warn-deferred-type-errors"        Opt_WarnDeferredTypeErrors,
   flagSpec "warn-deprecations"                Opt_WarnWarningsDeprecations,
   flagSpec "warn-deprecated-flags"            Opt_WarnDeprecatedFlags,
index f783a9a..1a35af1 100644 (file)
@@ -460,7 +460,7 @@ makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
                 -> IO (ModIface,Bool)
 makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do
     safe_mode <- hscGetSafeMode tc_result
-    ioMsgMaybe $ do
+    liftIO $ do
         mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode
                   details tc_result
 
@@ -1216,7 +1216,7 @@ hscSimpleIface' tc_result mb_old_iface = do
     safe_mode <- hscGetSafeMode tc_result
     (new_iface, no_change)
         <- {-# SCC "MkFinalIface" #-}
-           ioMsgMaybe $
+           liftIO $
                mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
     -- And the answer is ...
     liftIO $ dumpIfaceStats hsc_env
@@ -1244,7 +1244,7 @@ hscNormalIface' simpl_result mb_old_iface = do
     -- until after code output
     (new_iface, no_change)
         <- {-# SCC "MkFinalIface" #-}
-           ioMsgMaybe $
+           liftIO $
                mkIface hsc_env mb_old_iface details simpl_result
 
     liftIO $ dumpIfaceStats hsc_env
index e3501df..8e76492 100644 (file)
@@ -1324,6 +1324,26 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
 
            ; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } }
 
+{-
+Note [Orphans and auto-generated rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise an INLINEABLE function, or when we have
+-fspecialise-aggressively, we auto-generate RULES that are orphans.
+We don't want to warn about these, or we'd generate a lot of warnings.
+Thus, we only warn about user-specified orphan rules.
+
+Indeed, we don't even treat the module as an orphan module if it has
+auto-generated *rule* orphans.  Orphan modules are read every time we
+compile, so they are pretty obtrusive and slow down every compilation,
+even non-optimised ones.  (Reason: for type class instances it's a
+type correctness issue.)  But specialisation rules are strictly for
+*optimisation* only so it's fine not to read the interface.
+
+What this means is that a SPEC rules from auto-specialisation in
+module M will be used in other modules only if M.hi has been read for
+some other reason, which is actually pretty likely.
+-}
+
 bindAuxiliaryDicts
         :: SpecEnv
         -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions
index f4caf2b..53fd19f 100644 (file)
@@ -441,7 +441,21 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
              -- Not sure if this is really the right place to do so,
              -- but it'll do fine
        ; oflag <- getOverlapFlag overlap_mode
-       ; return (mkLocalInstance dfun oflag tvs' clas tys') }
+       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
+       ; dflags <- getDynFlags
+       ; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst)
+       ; return inst }
+
+instOrphWarn :: ClsInst -> SDoc
+instOrphWarn inst
+  = hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
+    $$ text "To avoid this"
+    $$ nest 4 (vcat possibilities)
+  where
+    possibilities =
+      text "move the instance declaration to the module of the class or of the type, or" :
+      text "wrap the type with a newtype and declare the instance on the new type." :
+      []
 
 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
   -- Add new locally-defined instances
index 9a2b988..3514393 100644 (file)
@@ -14,7 +14,6 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1,
                       MetaTyCons, genGenericMetaTyCons,
                       gen_Generic_binds, get_gen1_constrained_tys) where
 
-import DynFlags
 import HsSyn
 import Type
 import Kind             ( isKind )
@@ -33,15 +32,14 @@ import BasicTypes
 import TysPrim
 import TysWiredIn
 import PrelNames
-import InstEnv
 import TcEnv
-import MkId
 import TcRnMonad
 import HscTypes
 import ErrUtils( Validity(..), andValid )
 import BuildTyCl
 import SrcLoc
 import Bag
+import Inst
 import VarSet (elemVarSet)
 import Outputable
 import FastString
@@ -113,8 +111,7 @@ genGenericMetaTyCons tc =
 -- both the tycon declarations and related instances
 metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
 metaTyConsToDerivStuff tc metaDts =
-  do  dflags <- getDynFlags
-      dClas <- tcLookupClass datatypeClassName
+  do  dClas <- tcLookupClass datatypeClassName
       d_dfun_name <- newDFunName' dClas tc
       cClas <- tcLookupClass constructorClassName
       c_dfun_names <- sequence [ (conTy,) <$> newDFunName' cClas tc
@@ -129,16 +126,18 @@ metaTyConsToDerivStuff tc metaDts =
       let
         (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
         mk_inst clas tc dfun_name
-          = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
-                            OverlapFlag { overlapMode   = (NoOverlap "")
-                                        , isSafeOverlap = safeLanguageOn dflags }
-                            [] clas tys
+          = newClsInst (Just (NoOverlap "")) dfun_name [] [] clas tys
           where
             tys = [mkTyConTy tc]
 
+
+      let d_metaTycon = metaD metaDts
+      d_inst <- mk_inst dClas d_metaTycon d_dfun_name
+      c_insts <- sequence [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ]
+      s_insts <- mapM (mapM (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names
+
+      let
         -- Datatype
-        d_metaTycon = metaD metaDts
-        d_inst   = mk_inst dClas d_metaTycon d_dfun_name
         d_binds  = InstBindings { ib_binds = dBinds
                                 , ib_tyvars = []
                                 , ib_pragmas = []
@@ -147,7 +146,6 @@ metaTyConsToDerivStuff tc metaDts =
         d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
 
         -- Constructor
-        c_insts = [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ]
         c_binds = [ InstBindings { ib_binds = c
                                  , ib_tyvars = []
                                  , ib_pragmas = []
@@ -158,7 +156,6 @@ metaTyConsToDerivStuff tc metaDts =
                    | (is,bs) <- myZip1 c_insts c_binds ]
 
         -- Selector
-        s_insts = map (map (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names
         s_binds = [ [ InstBindings { ib_binds = s
                                    , ib_tyvars = []
                                    , ib_pragmas = []
index b8a3e6a..56df3a5 100644 (file)
@@ -203,7 +203,9 @@ instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
 mkLocalInstance :: DFunId -> OverlapFlag
                 -> [TyVar] -> Class -> [Type]
                 -> ClsInst
--- Used for local instances, where we can safely pull on the DFunId
+-- Used for local instances, where we can safely pull on the DFunId.
+-- Consider using newClsInst instead; this will also warn if
+-- the instance is an orphan.
 mkLocalInstance dfun oflag tvs cls tys
   = ClsInst { is_flag = oflag, is_dfun = dfun
             , is_tvs = tvs
index 0b3faa4..c3271d0 100644 (file)
@@ -40,7 +40,7 @@ standard “packages” of warnings:
     code. The warnings that are *not* enabled by ``-Wall`` are
     ``-fwarn-incomplete-uni-patterns``,
     ``-fwarn-incomplete-record-updates``,
-    ``-fwarn-monomorphism-restriction``, ``-fwarn-auto-orphans``,
+    ``-fwarn-monomorphism-restriction``,
     ``-fwarn-implicit-prelude``, ``-fwarn-missing-local-sigs``,
     ``-fwarn-missing-exported-sigs``, ``-fwarn-missing-import-lists``
     and ``-fwarn-identities``.
@@ -563,10 +563,9 @@ command line.
 
         f x = do { _ignore <- this; _ignore <- that; return (the other) }
 
-``-fwarn-orphans, -fwarn-auto-orphans``
+``-fwarn-orphans``
     .. index::
        single: -fwarn-orphans
-       single: -fwarn-auto-orphans
        single: orphan instances, warning
        single: orphan rules, warning
 
@@ -584,10 +583,7 @@ command line.
     otherwise be of any use. See :ref:`orphan-modules` for details.
 
     The flag ``-fwarn-orphans`` warns about user-written orphan rules or
-    instances. The flag ``-fwarn-auto-orphans`` warns about
-    automatically-generated orphan rules, notably as a result of
-    specialising functions, for type classes (``Specialise``) or
-    argument values (``-fspec-constr``).
+    instances.
 
 ``-fwarn-overlapping-patterns``
     .. index::
index 855d365..02ff1ad 100644 (file)
@@ -1,12 +1,12 @@
 
-T4912.hs:10:10: warning:
-    Orphan instance: instance [safe] Foo TheirData
+T4912.hs:10:1: warning:
+    Orphan instance: instance Foo TheirData
     To avoid this
         move the instance declaration to the module of the class or of the type, or
         wrap the type with a newtype and declare the instance on the new type.
 
-T4912.hs:13:10: warning:
-    Orphan instance: instance [safe] Bar OurData
+T4912.hs:13:1: warning:
+    Orphan instance: instance Bar OurData
     To avoid this
         move the instance declaration to the module of the class or of the type, or
         wrap the type with a newtype and declare the instance on the new type.
index c1e99bc..d22f428 100644 (file)
@@ -1,8 +1,8 @@
 [1 of 2] Compiling T9178DataType    ( T9178DataType.hs, T9178DataType.o )
 [2 of 2] Compiling T9178            ( T9178.hs, T9178.o )
 
-T9178.hs:8:10: warning:
-    Orphan instance: instance [safe] Show T9178_Type
+T9178.hs:8:1: warning:
+    Orphan instance: instance Show T9178_Type
     To avoid this
         move the instance declaration to the module of the class or of the type, or
         wrap the type with a newtype and declare the instance on the new type.
index a79c3a8..688a7e6 100644 (file)
@@ -155,12 +155,12 @@ warningsOptions =
          , flagType = DynamicFlag
          , flagReverse = "-fno-warn-name-shadowing"
          }
-  , flag { flagName = "-fwarn-orphans, -fwarn-auto-orphans"
+  , flag { flagName = "-fwarn-orphans"
          , flagDescription =
            "warn when the module contains :ref:`orphan instance declarations "++
            "or rewrite rules <orphan-modules>`"
          , flagType = DynamicFlag
-         , flagReverse = "-fno-warn-orphans, -fno-warn-auto-orphans"
+         , flagReverse = "-fno-warn-orphans"
          }
   , flag { flagName = "-fwarn-overlapping-patterns"
          , flagDescription = "warn about overlapping patterns"