Deal correctly with unused imports for 'coerce'
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 28 Jun 2016 11:13:13 +0000 (12:13 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 28 Jun 2016 12:41:41 +0000 (13:41 +0100)
We only do newtype unwrapping for Coercible constraints if
the newtype's data constructor is in scope.  We were trying to
record the fact that the data constructor was thereby 'used', so
that an import statement would not be flagged as unnecsssary
(by -Wunused-imports).

But the code was simply wrong. It was wrong because it assumed
that only one level of unwrapping happened, whereas
tcTopNormaliseNewTypeTF_maybe actually unwraps multiple layers.
So we need to return a /list/ of data constructors that are used.

This entailed a bit of refactoring, as usual.

Fixes Trac #12067

compiler/typecheck/FamInst.hs
compiler/typecheck/TcCanonical.hs
compiler/typecheck/TcSMonad.hs
compiler/types/Coercion.hs
compiler/types/FamInstEnv.hs
compiler/types/TyCon.hs
testsuite/tests/typecheck/should_compile/T12067.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T12067a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index 434f1f3..d8bc8a7 100644 (file)
@@ -38,6 +38,7 @@ import Name
 import Pair
 import Panic
 import VarSet
+import Bag( Bag, unionBags, unitBag )
 import Control.Monad
 import Unique
 import Data.Set (Set)
@@ -275,7 +276,7 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
   = Nothing
 
 -- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,
--- potentially looking through newtype instances.
+-- potentially looking through newtype /instances/.
 --
 -- It is only used by the type inference engine (specifically, when
 -- solving representational equality), and hence it is careful to unwrap
@@ -289,15 +290,24 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
 -- It does not look through type families.
 -- It does not normalise arguments to a tycon.
 --
--- Always produces a representational coercion.
+-- If the result is Just (rep_ty, (co, gres), rep_ty), then
+--    co : ty ~R rep_ty
+--    gres are the GREs for the data constructors that
+--                          had to be in scope
 tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
                               -> GlobalRdrEnv
                               -> Type
-                              -> Maybe (TcCoercion, Type)
+                              -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
 tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
 -- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
-  = topNormaliseTypeX_maybe stepper ty
+  = topNormaliseTypeX stepper plus ty
   where
+    plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
+         -> (Bag GlobalRdrElt, TcCoercion)
+    plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2
+                                     , co1 `mkTransCo` co2 )
+
+    stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
     stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance
 
     -- For newtype instances we take a double step or nothing, so that
@@ -305,25 +315,21 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
     -- which would lead to terrible error messages
     unwrap_newtype_instance rec_nts tc tys
       | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys
-      = modifyStepResultCo (co `mkTransCo`) $
+      = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $
         unwrap_newtype rec_nts tc' tys'
       | otherwise = NS_Done
 
     unwrap_newtype rec_nts tc tys
-      | data_cons_in_scope tc
-      = unwrapNewTypeStepper rec_nts tc tys
+      | Just con <- newTyConDataCon_maybe tc
+      , Just gre <- lookupGRE_Name rdr_env (dataConName con)
+           -- This is where we check that the
+           -- data constructor is in scope
+      = mapStepResult (\co -> (unitBag gre, co)) $
+        unwrapNewTypeStepper rec_nts tc tys
 
       | otherwise
       = NS_Done
 
-    data_cons_in_scope :: TyCon -> Bool
-    data_cons_in_scope tc
-      = isWiredInName (tyConName tc) ||
-        (not (isAbstractTyCon tc) && all in_scope data_con_names)
-      where
-        data_con_names = map dataConName (tyConDataCons tc)
-        in_scope dc    = isJust (lookupGRE_Name rdr_env dc)
-
 {-
 ************************************************************************
 *                                                                      *
index 593712a..b6a76c7 100644 (file)
@@ -583,11 +583,11 @@ can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
 
 -- When working with ReprEq, unwrap newtypes.
 can_eq_nc' _flat rdr_env envs ev ReprEq ty1 _ ty2 ps_ty2
-  | Just (co, ty1') <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
-  = can_eq_newtype_nc rdr_env ev NotSwapped co ty1 ty1' ty2 ps_ty2
+  | Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
+  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
 can_eq_nc' _flat rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _
-  | Just (co, ty2') <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
-  = can_eq_newtype_nc rdr_env ev IsSwapped  co ty2 ty2' ty1 ps_ty1
+  | Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
+  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1
 
 -- Then, get rid of casts
 can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
@@ -820,23 +820,21 @@ E.] am worried that it would slow down the common case.)
 
 ------------------------
 -- | We're able to unwrap a newtype. Update the bits accordingly.
-can_eq_newtype_nc :: GlobalRdrEnv
-                  -> CtEvidence           -- ^ :: ty1 ~ ty2
+can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2
                   -> SwapFlag
-                  -> TcCoercion           -- ^ :: ty1 ~ ty1'
-                  -> TcType               -- ^ ty1
-                  -> TcType               -- ^ ty1'
+                  -> TcType                                    -- ^ ty1
+                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'
                   -> TcType               -- ^ ty2
                   -> TcType               -- ^ ty2, with type synonyms
                   -> TcS (StopOrContinue Ct)
-can_eq_newtype_nc rdr_env ev swapped co ty1 ty1' ty2 ps_ty2
+can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2
   = do { traceTcS "can_eq_newtype_nc" $
-         vcat [ ppr ev, ppr swapped, ppr co, ppr ty1', ppr ty2 ]
+         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]
 
          -- check for blowing our stack:
          -- See Note [Newtypes can blow the stack]
        ; checkReductionDepth (ctEvLoc ev) ty1
-       ; addUsedDataCons rdr_env (tyConAppTyCon ty1)
+       ; addUsedGREs (bagToList gres)
            -- we have actually used the newtype constructor here, so
            -- make sure we don't warn about importing it!
 
index a8bb35d..4c854c2 100644 (file)
@@ -18,7 +18,7 @@ module TcSMonad (
     runTcSEqualities,
     nestTcS, nestImplicTcS,
 
-    runTcPluginTcS, addUsedDataCons, deferTcSForAllEq,
+    runTcPluginTcS, addUsedGREs, deferTcSForAllEq,
 
     -- Tracing etc
     panicTcS, traceTcS,
@@ -136,7 +136,7 @@ import TyCon
 import TcErrors   ( solverDepthErrorTcS )
 
 import Name
-import RdrName ( GlobalRdrEnv)
+import RdrName ( GlobalRdrEnv, GlobalRdrElt )
 import qualified RnEnv as TcM
 import Var
 import VarEnv
@@ -2730,8 +2730,8 @@ tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
 -- Setting names as used (used in the deriving of Coercible evidence)
 -- Too hackish to expose it to TcS? In that case somehow extract the used
 -- constructors from the result of solveInteract
-addUsedDataCons :: GlobalRdrEnv -> TyCon -> TcS ()
-addUsedDataCons rdr_env tycon = wrapTcS  $ TcM.addUsedDataCons rdr_env tycon
+addUsedGREs :: [GlobalRdrElt] -> TcS ()
+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres
 
 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 2d45bb1..6545ec0 100644 (file)
@@ -45,8 +45,8 @@ module Coercion (
         instNewTyCon_maybe,
 
         NormaliseStepper, NormaliseStepResult(..), composeSteppers,
-        modifyStepResultCo, unwrapNewTypeStepper,
-        topNormaliseNewType_maybe, topNormaliseTypeX_maybe,
+        mapStepResult, unwrapNewTypeStepper,
+        topNormaliseNewType_maybe, topNormaliseTypeX,
 
         decomposeCo, getCoVar_maybe,
         splitTyConAppCo_maybe,
@@ -843,6 +843,7 @@ mkSymCo    (SubCo (SymCo co))     = SubCo co
 mkSymCo co                        = SymCo co
 
 -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
+--   (co1 ; co2)
 mkTransCo :: Coercion -> Coercion -> Coercion
 mkTransCo co1 (Refl {}) = co1
 mkTransCo (Refl {}) co2 = co2
@@ -1266,30 +1267,32 @@ instNewTyCon_maybe tc tys
 -}
 
 -- | A function to check if we can reduce a type by one step. Used
--- with 'topNormaliseTypeX_maybe'.
-type NormaliseStepper = RecTcChecker
-                     -> TyCon     -- tc
-                     -> [Type]    -- tys
-                     -> NormaliseStepResult
+-- with 'topNormaliseTypeX'.
+type NormaliseStepper ev = RecTcChecker
+                         -> TyCon     -- tc
+                         -> [Type]    -- tys
+                         -> NormaliseStepResult ev
 
 -- | The result of stepping in a normalisation function.
--- See 'topNormaliseTypeX_maybe'.
-data NormaliseStepResult
+-- See 'topNormaliseTypeX'.
+data NormaliseStepResult ev
   = NS_Done   -- ^ Nothing more to do
   | NS_Abort  -- ^ Utter failure. The outer function should fail too.
-  | NS_Step RecTcChecker Type Coercion  -- ^ We stepped, yielding new bits;
-                                        -- ^ co :: old type ~ new type
+  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;
+                                    -- ^ ev is evidence;
+                                    -- Usually a co :: old type ~ new type
 
-modifyStepResultCo :: (Coercion -> Coercion)
-                   -> NormaliseStepResult -> NormaliseStepResult
-modifyStepResultCo f (NS_Step rec_nts ty co) = NS_Step rec_nts ty (f co)
-modifyStepResultCo _ result                  = result
+mapStepResult :: (ev1 -> ev2)
+              -> NormaliseStepResult ev1 -> NormaliseStepResult ev2
+mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)
+mapStepResult _ NS_Done                 = NS_Done
+mapStepResult _ NS_Abort                = NS_Abort
 
 -- | Try one stepper and then try the next, if the first doesn't make
 -- progress.
 -- So if it returns NS_Done, it means that both steppers are satisfied
-composeSteppers :: NormaliseStepper -> NormaliseStepper
-                -> NormaliseStepper
+composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev
+                -> NormaliseStepper ev
 composeSteppers step1 step2 rec_nts tc tys
   = case step1 rec_nts tc tys of
       success@(NS_Step {}) -> success
@@ -1298,7 +1301,7 @@ composeSteppers step1 step2 rec_nts tc tys
 
 -- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into
 -- a loop. If it would fall into a loop, it produces 'NS_Abort'.
-unwrapNewTypeStepper :: NormaliseStepper
+unwrapNewTypeStepper :: NormaliseStepper Coercion
 unwrapNewTypeStepper rec_nts tc tys
   | Just (ty', co) <- instNewTyCon_maybe tc tys
   = case checkRecTc rec_nts tc of
@@ -1312,28 +1315,32 @@ unwrapNewTypeStepper rec_nts tc tys
 -- to use the provided 'NormaliseStepper' until that function fails, and then
 -- this function returns. The roles of the coercions produced by the
 -- 'NormaliseStepper' must all be the same, which is the role returned from
--- the call to 'topNormaliseTypeX_maybe'.
-topNormaliseTypeX_maybe :: NormaliseStepper -> Type -> Maybe (Coercion, Type)
-topNormaliseTypeX_maybe stepper
-  = go initRecTc Nothing
-  where
-    go rec_nts mb_co1 ty
+-- the call to 'topNormaliseTypeX'.
+--
+-- Typically ev is Coercion.
+--
+-- If topNormaliseTypeX step plus ty = Just (ev, ty')
+-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'
+-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn
+-- If it returns Nothing then no newtype unwrapping could happen
+topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev)
+                  -> Type -> Maybe (ev, Type)
+topNormaliseTypeX stepper plus ty
+ | Just (tc, tys) <- splitTyConApp_maybe ty
+ , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys
+ = go rec_nts ev ty'
+ | otherwise
+ = Nothing
+ where
+    go rec_nts ev ty
       | Just (tc, tys) <- splitTyConApp_maybe ty
       = case stepper rec_nts tc tys of
-          NS_Step rec_nts' ty' co2
-            -> go rec_nts' (mb_co1 `trans` co2) ty'
-
-          NS_Done  -> all_done
+          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'
+          NS_Done  -> Just (ev, ty)
           NS_Abort -> Nothing
 
       | otherwise
-      = all_done
-      where
-        all_done | Just co <- mb_co1 = Just (co, ty)
-                 | otherwise         = Nothing
-
-    Nothing    `trans` co2 = Just co2
-    (Just co1) `trans` co2 = Just (co1 `mkTransCo` co2)
+      = Just (ev, ty)
 
 topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
 -- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.
@@ -1352,8 +1359,9 @@ topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
 -- the type family environment. If you do have that at hand, consider to use
 -- topNormaliseType_maybe, which should be a drop-in replacement for
 -- topNormaliseNewType_maybe
+-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'
 topNormaliseNewType_maybe ty
-  = topNormaliseTypeX_maybe unwrapNewTypeStepper ty
+  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty
 
 {-
 %************************************************************************
index 5fc8cbe..3f07c21 100644 (file)
@@ -1208,7 +1208,7 @@ topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type)
 -- Its a bit like Type.repType, but handles type families too
 
 topNormaliseType_maybe env ty
-  = topNormaliseTypeX_maybe stepper ty
+  = topNormaliseTypeX stepper mkTransCo ty
   where
     stepper = unwrapNewTypeStepper `composeSteppers` tyFamStepper
 
index 99bed6c..be73a9f 100644 (file)
@@ -87,6 +87,7 @@ module TyCon(
         algTyConRhs,
         newTyConRhs, newTyConEtadArity, newTyConEtadRhs,
         unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,
+        newTyConDataCon_maybe,
         algTcFields,
         tyConRuntimeRepInfo,
         tyConBinders, tyConResKind,
@@ -2051,6 +2052,10 @@ newTyConCo tc = case newTyConCo_maybe tc of
                  Just co -> co
                  Nothing -> pprPanic "newTyConCo" (ppr tc)
 
+newTyConDataCon_maybe :: TyCon -> Maybe DataCon
+newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con
+newTyConDataCon_maybe _ = Nothing
+
 -- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context
 -- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration
 -- @data Eq a => T a ...@
diff --git a/testsuite/tests/typecheck/should_compile/T12067.hs b/testsuite/tests/typecheck/should_compile/T12067.hs
new file mode 100644 (file)
index 0000000..15471a4
--- /dev/null
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -Wunused-imports #-}
+module T12067 where
+
+import Data.Functor.Identity
+import Data.Coerce
+import T12067a
+
+foo :: M [a] -> MT [] a
+foo = coerce
diff --git a/testsuite/tests/typecheck/should_compile/T12067a.hs b/testsuite/tests/typecheck/should_compile/T12067a.hs
new file mode 100644 (file)
index 0000000..d0ac3a0
--- /dev/null
@@ -0,0 +1,6 @@
+module T12067a (MT(..), M) where
+
+import Data.Functor.Identity
+
+newtype MT m b = MT (m b)
+type M b = MT Identity b
index d56c402..9843539 100644 (file)
@@ -527,3 +527,5 @@ test('T11339b', normal, compile, [''])
 test('T11339c', normal, compile, [''])
 test('T11339d', normal, compile, [''])
 test('T11974', normal, compile, [''])
+test('T12067', extra_clean(['T12067a.hi', 'T12067a.o']),
+     multimod_compile, ['T12067', '-v0'])