Commit 23b80ac4 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Deal correctly with unused imports for 'coerce'

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
parent af21e388
......@@ -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)
{-
************************************************************************
* *
......
......@@ -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!
......
......@@ -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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
{-
%************************************************************************
......
......@@ -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
......
......@@ -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 ...@
......
{-# OPTIONS_GHC -Wunused-imports #-}
module T12067 where
import Data.Functor.Identity
import Data.Coerce
import T12067a
foo :: M [a] -> MT [] a
foo = coerce
module T12067a (MT(..), M) where
import Data.Functor.Identity
newtype MT m b = MT (m b)
type M b = MT Identity b
......@@ -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'])
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