Commit 0cc47eb9 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Rewrite `Coercible` solver

Summary:
This is a rewrite of the algorithm to solve for Coercible "instances".

A preliminary form of these ideas is at
https://ghc.haskell.org/trac/ghc/wiki/Design/NewCoercibleSolver

The basic idea here is that the `EqPred` constructor of `PredTree`
now is parameterised by a new type `EqRel` (where
`data EqRel = NomEq | ReprEq`). Thus, every equality constraint can
now talk about nominal equality (the usual case) or representational
equality (the `Coercible` case).

This is a change from the previous
behavior where `Coercible` was just considered a regular class with
a special case in `matchClassInst`.

Because of this change, representational equalities are now
canonicalized just like nominal ones, allowing more equalities
to be solved -- in particular, the case at the top of #9117.

A knock-on effect is that the flattener must be aware of the
choice of equality relation, because the inert set now stores
both representational inert equalities alongside the nominal
inert equalities. Of course, we can use representational equalities
to rewrite only within another representational equality --
thus the parameterization of the flattener.

A nice side effect of this change is that I've introduced a new
type `CtFlavour`, which tracks G vs. W vs. D, removing some ugliness
in the flattener.

This commit includes some refactoring as discussed on D546.
It also removes the ability of Deriveds to rewrite Deriveds.

This fixes bugs #9117 and #8984.

Reviewers: simonpj, austin, nomeata

Subscribers: carter, thomie

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

GHC Trac Issues: #9117, #8984
parent 058262ba
......@@ -971,9 +971,9 @@ dataConCannotMatch tys con
-- TODO: could gather equalities from superclasses too
predEqs pred = case classifyPredType pred of
EqPred ty1 ty2 -> [(ty1, ty2)]
TuplePred ts -> concatMap predEqs ts
_ -> []
EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
TuplePred ts -> concatMap predEqs ts
_ -> []
{-
************************************************************************
......
......@@ -951,9 +951,7 @@ ds_tc_coercion subst tc_co
where
go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)
go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)
go (TcAppCo co1 co2) = let leftCo = go co1
rightRole = nextRole leftCo in
mkAppCoFlexible leftCo rightRole (go co2)
go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
......@@ -969,6 +967,7 @@ ds_tc_coercion subst tc_co
go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
go (TcCoVarCo v) = ds_ev_id subst v
go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)
go (TcCoercion co) = co
ds_co_binds :: TcEvBinds -> CvSubst
ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
......
......@@ -6,18 +6,17 @@ module FamInst (
FamInstEnvs, tcGetFamInstEnvs,
checkFamInstConsistency, tcExtendLocalFamInstEnv,
tcLookupFamInst,
tcLookupDataFamInst, tcInstNewTyConTF_maybe, tcInstNewTyCon_maybe,
tcLookupDataFamInst, tcLookupDataFamInst_maybe,
tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
newFamInst
) where
import HscTypes
import FamInstEnv
import InstEnv( roughMatchTcs )
import Coercion( pprCoAxBranchHdr )
import Coercion hiding ( substTy )
import TcEvidence
import LoadIface
import Type( applyTysX )
import TypeRep
import TcRnMonad
import TyCon
import CoAxiom
......@@ -27,6 +26,8 @@ import Outputable
import UniqFM
import FastString
import Util
import RdrName
import DataCon ( dataConName )
import Maybes
import TcMType
import TcType
......@@ -34,6 +35,7 @@ import Name
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Arrow ( first, second )
#include "HsVersions.h"
......@@ -216,45 +218,80 @@ tcLookupFamInst fam_envs tycon tys
-- Checks for a newtype, and for being saturated
-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
tcInstNewTyCon_maybe tc tys
| Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype
, tvs `leLength` tys -- Check saturated enough
= Just (applyTysX tvs ty tys, mkTcUnbranchedAxInstCo Representational co_tc tys)
| otherwise
= Nothing
tcInstNewTyCon_maybe tc tys = fmap (second TcCoercion) $
instNewTyCon_maybe tc tys
-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
-- there is no data family to unwrap.
tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
-> (TyCon, [TcType], TcCoercion)
tcLookupDataFamInst fam_inst_envs tc tc_args
| Just (rep_tc, rep_args, co)
<- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
= (rep_tc, rep_args, TcCoercion co)
| otherwise
= (tc, tc_args, mkTcRepReflCo (mkTyConApp tc tc_args))
tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
-> Maybe (TyCon, [TcType], Coercion)
-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)
-- and returns a coercion between the two: co :: F [a] ~R FList a
-- If there is no instance, or it's not a data family, just return
-- Refl coercion and the original inputs
tcLookupDataFamInst fam_inst_envs tc tc_args
tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
| isDataFamilyTyCon tc
, match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
, FamInstMatch { fim_instance = rep_fam
, fim_tys = rep_args } <- match
, let co_tc = famInstAxiom rep_fam
rep_tc = dataFamInstRepTyCon rep_fam
co = mkTcUnbranchedAxInstCo Representational co_tc rep_args
= (rep_tc, rep_args, co)
co = mkUnbranchedAxInstCo Representational co_tc rep_args
= Just (rep_tc, rep_args, co)
| otherwise
= (tc, tc_args, mkTcNomReflCo (mkTyConApp tc tc_args))
tcInstNewTyConTF_maybe :: FamInstEnvs -> TcType -> Maybe (TyCon, TcType, TcCoercion)
-- ^ If (instNewTyConTF_maybe envs ty) returns Just (ty', co)
-- then co :: ty ~R ty'
-- ty is (D tys) is a newtype (possibly after looking through the type family D)
-- ty' is the RHS type of the of (D tys) newtype
tcInstNewTyConTF_maybe fam_envs ty
| Just (tc, tc_args) <- tcSplitTyConApp_maybe ty
, let (rep_tc, rep_tc_args, fam_co) = tcLookupDataFamInst fam_envs tc tc_args
, Just (inner_ty, nt_co) <- tcInstNewTyCon_maybe rep_tc rep_tc_args
= Just (rep_tc, inner_ty, fam_co `mkTcTransCo` nt_co)
| otherwise
= Nothing
-- | Get rid of top-level newtypes, potentially looking through newtype
-- instances. Only unwraps newtypes that are in scope. This is used
-- for solving for `Coercible` in the solver. This version is careful
-- not to unwrap data/newtype instances if it can't continue unwrapping.
-- Such care is necessary for proper error messages.
--
-- Does not look through type families. Does not normalise arguments to a
-- tycon.
--
-- Always produces a representational coercion.
tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
-> GlobalRdrEnv
-> Type
-> Maybe (TcCoercion, Type)
tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
= fmap (first TcCoercion) $ topNormaliseTypeX_maybe stepper ty
where
stepper
= unwrap_newtype
`composeSteppers`
\ rec_nts tc tys ->
case tcLookupDataFamInst_maybe faminsts tc tys of
Just (tc', tys', co) ->
modifyStepResultCo (co `mkTransCo`)
(unwrap_newtype rec_nts tc' tys')
Nothing -> NS_Done
unwrap_newtype rec_nts tc tys
| data_cons_in_scope tc
= 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 = not $ null $ lookupGRE_Name rdr_env dc
{-
************************************************************************
* *
......
......@@ -480,9 +480,9 @@ oclose preds fixed_tvs
do let (cls_tvs, cls_fds) = classTvsFds cls
fd <- cls_fds
return (instFD fd cls_tvs tys)
EqPred t1 t2 -> [([t1],[t2]), ([t2],[t1])]
TuplePred ts -> concatMap determined ts
_ -> []
EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]
TuplePred ts -> concatMap determined ts
_ -> []
{-
************************************************************************
......
......@@ -220,8 +220,21 @@ instCallConstraints orig preds
= do { co <- unifyType ty1 ty2
; return (EvCoercion co) }
| otherwise
= do { ev_var <- emitWanted orig pred
= do { ev_var <- emitWanted modified_orig pred
; return (EvId ev_var) }
where
-- Coercible constraints appear as normal class constraints, but
-- are aggressively canonicalized and manipulated during solving.
-- The final equality to solve may barely resemble the initial
-- constraint. Here, we remember the initial constraint in a
-- CtOrigin for better error messages. It's perhaps worthwhile
-- considering making this approach general, for other class
-- constraints, too.
modified_orig
| Just (Representational, ty1, ty2) <- getEqPredTys_maybe pred
= CoercibleOrigin ty1 ty2
| otherwise
= orig
----------------
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
......
This diff is collapsed.
......@@ -1807,7 +1807,6 @@ inferInstanceContexts infer_specs
do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
-- checkValidInstance tyvars theta clas inst_tys
-- Not necessary; see Note [Exotic derived instance contexts]
-- in TcSimplify
; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
-- Claim: the result instance declaration is guaranteed valid
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -38,6 +38,7 @@ import TypeRep -- We can see the representation of types
import TcType
import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
import TcEvidence
import Coercion
import TysPrim
import TysWiredIn
import Type
......@@ -1283,6 +1284,7 @@ zonkEvBind env (EvBind var term)
-- See Note [Optimise coercion zonking]
-- This has a very big effect on some programs (eg Trac #5030)
; let ty' = idType var'
; case getEqPredTys_maybe ty' of
Just (r, ty1, ty2) | ty1 `eqType` ty2
-> return (EvBind var' (EvCoercion (mkTcReflCo r ty1)))
......@@ -1409,7 +1411,7 @@ zonkTcTypeToType env ty
-- The two interesting cases!
go (TyVarTy tv) = zonkTyVarOcc env tv
go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) do
go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv )
do { (env', tv') <- zonkTyBndrX env tv
; ty' <- zonkTcTypeToType env' ty
; return (ForAllTy tv' ty') }
......@@ -1417,6 +1419,32 @@ zonkTcTypeToType env ty
zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
zonkCoToCo env co
= go co
where
go (Refl r ty) = mkReflCo r <$> zonkTcTypeToType env ty
go (TyConAppCo r tc args) = mkTyConAppCo r tc <$> mapM go args
go (AppCo co arg) = mkAppCo <$> go co <*> go arg
go (AxiomInstCo ax ind args) = AxiomInstCo ax ind <$> mapM go args
go (UnivCo r ty1 ty2) = mkUnivCo r <$> zonkTcTypeToType env ty1
<*> zonkTcTypeToType env ty2
go (SymCo co) = mkSymCo <$> go co
go (TransCo co1 co2) = mkTransCo <$> go co1 <*> go co2
go (NthCo n co) = mkNthCo n <$> go co
go (LRCo lr co) = mkLRCo lr <$> go co
go (InstCo co arg) = mkInstCo <$> go co <*> zonkTcTypeToType env arg
go (SubCo co) = mkSubCo <$> go co
go (AxiomRuleCo ax ts cs) = AxiomRuleCo ax <$> mapM (zonkTcTypeToType env) ts
<*> mapM go cs
-- The two interesting cases!
go (CoVarCo cv) = return (mkCoVarCo $ zonkIdOcc env cv)
go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv )
do { (env', tv') <- zonkTyBndrX env tv
; co' <- zonkCoToCo env' co
; return (mkForAllCo tv' co') }
zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker
-- This variant collects unbound type variables in a mutable variable
-- Works on both types and kinds
......@@ -1479,3 +1507,5 @@ zonkTcCoToCo env co
; cs' <- mapM go cs
; return (TcAxiomRuleCo co ts' cs')
}
go (TcCoercion co) = do { co' <- zonkCoToCo env co
; return (TcCoercion co') }
This diff is collapsed.
......@@ -143,7 +143,7 @@ newDict cls tys
predTypeOccName :: PredType -> OccName
predTypeOccName ty = case classifyPredType ty of
ClassPred cls _ -> mkDictOcc (getOccName cls)
EqPred _ _ -> mkVarOccFS (fsLit "cobox")
EqPred _ _ _ -> mkVarOccFS (fsLit "cobox")
TuplePred _ -> mkVarOccFS (fsLit "tup")
IrredPred _ -> mkVarOccFS (fsLit "irred")
......@@ -929,6 +929,10 @@ zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig)
; (env2, ty2') <- zonkTidyTcType env1 ty2
; (env3, orig') <- zonkTidyOrigin env2 orig
; return (env3, KindEqOrigin ty1' ty2' orig') }
zonkTidyOrigin env (CoercibleOrigin ty1 ty2)
= do { (env1, ty1') <- zonkTidyTcType env ty1
; (env2, ty2') <- zonkTidyTcType env1 ty2
; return (env2, CoercibleOrigin ty1' ty2') }
zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2)
= do { (env1, p1') <- zonkTidyTcType env p1
; (env2, p2') <- zonkTidyTcType env1 p2
......
......@@ -50,9 +50,10 @@ module TcRnTypes(
isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt, isTypedHoleCt, isPartialTypeSigCt,
ctEvidence, ctLoc, ctPred,
ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel,
mkNonCanonical, mkNonCanonicalCt,
ctEvPred, ctEvLoc, ctEvTerm, ctEvCoercion, ctEvId, ctEvCheckDepth,
ctEvPred, ctEvLoc, ctEvEqRel,
ctEvTerm, ctEvCoercion, ctEvId, ctEvCheckDepth,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
......@@ -73,11 +74,14 @@ module TcRnTypes(
CtEvidence(..),
mkGivenLoc,
isWanted, isGiven, isDerived,
ctEvRole,
-- Constraint solver plugins
TcPlugin(..), TcPluginResult(..), TcPluginSolver,
TcPluginM, runTcPluginM, unsafeTcPluginTcM,
CtFlavour(..), ctEvFlavour,
-- Pretty printing
pprEvVarTheta,
pprEvVars, pprEvVarWithType,
......@@ -95,6 +99,7 @@ import CoreSyn
import HscTypes
import TcEvidence
import Type
import CoAxiom ( Role )
import Class ( Class )
import TyCon ( TyCon )
import ConLike ( ConLike(..) )
......@@ -1026,7 +1031,7 @@ data Ct
| CTyEqCan { -- tv ~ rhs
-- Invariants:
-- * See Note [Applying the inert substitution] in TcFlatten
-- * tv not in tvs(xi) (occurs check)
-- * tv not in tvs(rhs) (occurs check)
-- * If tv is a TauTv, then rhs has no foralls
-- (this avoids substituting a forall for the tyvar in other types)
-- * typeKind ty `subKind` typeKind tv
......@@ -1035,12 +1040,16 @@ data Ct
-- but it has no top-level function.
-- E.g. a ~ [F b] is fine
-- but a ~ F b is not
-- * If the equality is representational, rhs has no top-level newtype
-- See Note [No top-level newtypes on RHS of representational
-- equalities] in TcCanonical
-- * If rhs is also a tv, then it is oriented to give best chance of
-- unification happening; eg if rhs is touchable then lhs is too
cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant]
cc_tyvar :: TcTyVar,
cc_rhs :: TcType -- Not necessarily function-free (hence not Xi)
cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi)
-- See invariants above
cc_eq_rel :: EqRel
}
| CFunEqCan { -- F xis ~ fsk
......@@ -1169,6 +1178,14 @@ ctPred :: Ct -> PredType
-- See Note [Ct/evidence invariant]
ctPred ct = ctEvPred (cc_ev ct)
-- | Get the flavour of the given 'Ct'
ctFlavour :: Ct -> CtFlavour
ctFlavour = ctEvFlavour . ctEvidence
-- | Get the equality relation for the given 'Ct'
ctEqRel :: Ct -> EqRel
ctEqRel = ctEvEqRel . ctEvidence
dropDerivedWC :: WantedConstraints -> WantedConstraints
-- See Note [Dropping derived constraints]
dropDerivedWC wc@(WC { wc_flat = flats })
......@@ -1532,6 +1549,14 @@ ctEvPred = ctev_pred
ctEvLoc :: CtEvidence -> CtLoc
ctEvLoc = ctev_loc
-- | Get the equality relation relevant for a 'CtEvidence'
ctEvEqRel :: CtEvidence -> EqRel
ctEvEqRel = predTypeEqRel . ctEvPred
-- | Get the role relevant for a 'CtEvidence'
ctEvRole :: CtEvidence -> Role
ctEvRole = eqRelRole . ctEvEqRel
ctEvTerm :: CtEvidence -> EvTerm
ctEvTerm (CtGiven { ctev_evtm = tm }) = tm
ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev
......@@ -1568,6 +1593,31 @@ isDerived :: CtEvidence -> Bool
isDerived (CtDerived {}) = True
isDerived _ = False
{-
%************************************************************************
%* *
CtFlavour
%* *
%************************************************************************
Just an enum type that tracks whether a constraint is wanted, derived,
or given, when we need to separate that info from the constraint itself.
-}
data CtFlavour = Given | Wanted | Derived
deriving Eq
instance Outputable CtFlavour where
ppr Given = text "[G]"
ppr Wanted = text "[W]"
ppr Derived = text "[D]"
ctEvFlavour :: CtEvidence -> CtFlavour
ctEvFlavour (CtWanted {}) = Wanted
ctEvFlavour (CtGiven {}) = Given
ctEvFlavour (CtDerived {}) = Derived
{-
************************************************************************
* *
......@@ -1864,6 +1914,7 @@ data CtOrigin
| KindEqOrigin
TcType TcType -- A kind equality arising from unifying these two types
CtOrigin -- originally arising from this
| CoercibleOrigin TcType TcType -- a Coercible constraint
| IPOccOrigin HsIPName -- Occurrence of an implicit parameter
......@@ -1945,8 +1996,13 @@ pprCtOrigin (DerivOriginDC dc n)
pprCtOrigin (DerivOriginCoerce meth ty1 ty2)
= hang (ctoHerald <+> ptext (sLit "the coercion of the method") <+> quotes (ppr meth))
2 (sep [ ptext (sLit "from type") <+> quotes (ppr ty1)
, ptext (sLit " to type") <+> quotes (ppr ty2) ])
2 (sep [ text "from type" <+> quotes (ppr ty1)
, nest 2 $ text "to type" <+> quotes (ppr ty2) ])
pprCtOrigin (CoercibleOrigin ty1 ty2)
= hang (ctoHerald <+> text "trying to show that the representations of")
2 (quotes (ppr ty1) <+> text "and" $$
quotes (ppr ty2) <+> text "are the same")
pprCtOrigin simple_origin
= ctoHerald <+> pprCtO simple_origin
......
This diff is collapsed.
......@@ -20,7 +20,8 @@ import TcSMonad as TcS
import TcInteract
import Kind ( isKind, isSubKind, defaultKind_maybe )
import Inst
import Type ( classifyPredType, isIPClass, PredTree(..), getClassPredTys_maybe )
import Type ( classifyPredType, isIPClass, PredTree(..)
, getClassPredTys_maybe, EqRel(..) )
import TyCon ( isTypeFamilyTyCon )
import Class ( Class )
import Id ( idType )
......@@ -446,11 +447,13 @@ quantifyPred :: TyVarSet -- Quantifying over these
quantifyPred qtvs pred
= case classifyPredType pred of
ClassPred cls tys
| isIPClass cls -> True -- See note [Inheriting implicit parameters]
| otherwise -> tyVarsOfTypes tys `intersectsVarSet` qtvs
EqPred ty1 ty2 -> quant_fun ty1 || quant_fun ty2
IrredPred ty -> tyVarsOfType ty `intersectsVarSet` qtvs
TuplePred {} -> False
| isIPClass cls -> True -- See note [Inheriting implicit parameters]
| otherwise -> tyVarsOfTypes tys `intersectsVarSet` qtvs
EqPred NomEq ty1 ty2 -> quant_fun ty1 || quant_fun ty2
-- representational equality is like a class constraint
EqPred ReprEq ty1 ty2 -> tyVarsOfTypes [ty1, ty2] `intersectsVarSet` qtvs
IrredPred ty -> tyVarsOfType ty `intersectsVarSet` qtvs
TuplePred {} -> False
where
-- Only quantify over (F tys ~ ty) if tys mentions a quantifed variable
-- In particular, quanitifying over (F Int ~ ty) is a bit like quantifying
......@@ -648,7 +651,7 @@ simplifyRule name lhs_wanted rhs_wanted
quantify_insol ct = not (isEqPred (ctPred ct))
quantify_normal ct
| EqPred t1 t2 <- classifyPredType (ctPred ct)
| EqPred NomEq t1 t2 <- classifyPredType (ctPred ct)
= not (t1 `tcEqType` t2)
| otherwise
= True
......@@ -1253,7 +1256,7 @@ floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats })
float_me :: Ct -> Bool
float_me ct -- The constraint is un-flattened and de-cannonicalised
| let pred = ctPred ct
, EqPred ty1 ty2 <- classifyPredType pred
, EqPred NomEq ty1 ty2 <- classifyPredType pred
, tyVarsOfType pred `disjointVarSet` skol_set
, useful_to_float ty1 ty2
= True
......
......@@ -45,7 +45,7 @@ module TcType (
--------------------------------
-- Builders
mkPhiTy, mkSigmaTy, mkTcEqPred,
mkPhiTy, mkSigmaTy, mkTcEqPred, mkTcReprEqPred, mkTcEqPredRole,
--------------------------------
-- Splitters
......@@ -56,7 +56,7 @@ module TcType (
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
tcGetTyVar_maybe, tcGetTyVar,
tcGetTyVar_maybe, tcGetTyVar, nextRole,
tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
---------------------------------
......@@ -68,7 +68,7 @@ module TcType (
isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
isPredTy, isTyVarClassPred,
isPredTy, isTyVarClassPred, isTyVarExposed,
---------------------------------
-- Misc type manipulators
......@@ -834,6 +834,19 @@ mkTcEqPred ty1 ty2
where
k = typeKind ty1
-- | Make a representational equality predicate
mkTcReprEqPred :: TcType -> TcType -> Type
mkTcReprEqPred ty1 ty2
= mkTyConApp coercibleTyCon [k, ty1, ty2]
where
k = typeKind ty1
-- | Make an equality predicate at a given role. The role must not be Phantom.
mkTcEqPredRole :: Role -> TcType -> TcType -> Type
mkTcEqPredRole Nominal = mkTcEqPred
mkTcEqPredRole Representational = mkTcReprEqPred
mkTcEqPredRole Phantom = panic "mkTcEqPredRole Phantom"
-- @isTauTy@ tests for nested for-alls. It should not be called on a boxy type.
isTauTy :: Type -> Bool
......@@ -1393,6 +1406,21 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of
Just (tc, _) -> uniq == getUnique tc
Nothing -> False
-- | Does the given tyvar appear in the given type outside of any
-- non-newtypes? Assume we're looking for @a@. Says "yes" for
-- @a@, @N a@, @b a@, @a b@, @b (N a)@. Says "no" for
-- @[a]@, @Maybe a@, @T a@, where @N@ is a newtype and @T@ is a datatype.
isTyVarExposed :: TcTyVar -> TcType -> Bool
isTyVarExposed tv (TyVarTy tv') = tv == tv'
isTyVarExposed tv (TyConApp tc tys)
| isNewTyCon tc = any (isTyVarExposed tv) tys
| otherwise = False
isTyVarExposed _ (LitTy {}) = False
isTyVarExposed _ (FunTy {}) = False
isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun
|| isTyVarExposed tv arg
isTyVarExposed _ (ForAllTy {}) = False
{-
************************************************************************
* *
......
......@@ -495,10 +495,11 @@ check_pred_help under_syn dflags ctxt pred
= check_pred_help True dflags ctxt pred'
| otherwise
= case classifyPredType pred of
ClassPred cls tys -> check_class_pred dflags ctxt pred cls tys
EqPred {} -> check_eq_pred dflags pred
TuplePred tys -> check_tuple_pred under_syn dflags ctxt pred tys
IrredPred _ -> check_irred_pred under_syn dflags ctxt pred
ClassPred cls tys -> check_class_pred dflags ctxt pred cls tys
EqPred NomEq _ _ -> check_eq_pred dflags pred
EqPred ReprEq ty1 ty2 -> check_repr_eq_pred dflags ctxt pred ty1 ty2
TuplePred tys -> check_tuple_pred under_syn dflags ctxt pred tys
IrredPred _ -> check_irred_pred under_syn dflags ctxt pred
check_class_pred :: DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM ()
check_class_pred dflags ctxt pred cls tys
......@@ -509,26 +510,31 @@ check_class_pred dflags ctxt pred cls tys
(badIPPred pred)
-- Check the form of the argument types
; checkTc (check_class_pred_tys dflags ctxt tys)
(predTyVarErr (mkClassPred cls tys) $$ how_to_allow)
; check_class_pred_tys dflags ctxt pred tys
}
where
class_name = className cls
arity = classArity cls
n_tys = length tys
arity_err = arityErr "Class" class_name arity n_tys
how_to_allow = parens (ptext (sLit "Use FlexibleContexts to permit this"))
check_eq_pred :: DynFlags -> PredType -> TcM ()
check_eq_pred dflags pred
= -- Equational constraints are valid in all contexts if type
-- families are permitted
= -- Equational constraints are valid in all contexts if type
-- families are permitted
checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags)
(eqPredTyErr pred)
check_repr_eq_pred :: DynFlags -> UserTypeCtxt -> PredType
-> TcType -> TcType -> TcM ()
check_repr_eq_pred dflags ctxt pred ty1 ty2
= check_class_pred_tys dflags ctxt pred tys
where
tys = [ty1, ty2]
check_tuple_pred :: Bool -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
check_tuple_pred under_syn dflags ctxt pred ts
= do { -- See Note [ConstraintKinds in predicates]
= do { -- See Note [ConstraintKinds in predicates]
checkTc (under_syn || xopt Opt_ConstraintKinds dflags)
(predTupleErr pred)
; mapM_ (check_pred_help under_syn dflags ctxt) ts }
......@@ -581,18 +587,23 @@ It is equally dangerous to allow them in instance heads because in that case the
Paterson conditions may not detect duplication of a type variable or size change. -}
-------------------------
check_class_pred_tys :: DynFlags -> UserTypeCtxt -> [KindOrType] -> Bool
check_class_pred_tys dflags ctxt kts
= case ctxt of
check_class_pred_tys :: DynFlags -> UserTypeCtxt
-> PredType -> [KindOrType] -> TcM ()
check_class_pred_tys dflags ctxt pred kts
= checkTc pred_ok (predTyVarErr pred $$ how_to_allow)
where
(_, tys) = span isKind kts -- see Note [Kind polymorphic type classes]
flexible_contexts = xopt Opt_FlexibleContexts dflags
undecidable_ok = xopt Opt_UndecidableInstances dflags
pred_ok = case ctxt of
SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine
InstDeclCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys
-- Further checks on head and theta in
-- checkInstTermination
_ -> flexible_contexts || all tyvar_head tys
where
(_, tys) = span isKind kts -- see Note [Kind polymorphic type classes]
flexible_contexts = xopt Opt_FlexibleContexts dflags
undecidable_ok = xopt Opt_UndecidableInstances dflags
how_to_allow = parens (ptext (sLit "Use FlexibleContexts to permit this"))
-------------------------
tyvar_head :: Type -> Bool
......@@ -851,7 +862,7 @@ instTypeErr cls tys msg
{-
validDeivPred checks for OK 'deriving' context. See Note [Exotic
derived instance contexts] in TcSimplify. However the predicate is
derived instance contexts] in TcDeriv. However the predicate is
here because it uses sizeTypes, fvTypes.
Also check for a bizarre corner case, when the derived instance decl
......@@ -866,12 +877,16 @@ not converge. See Trac #5287.
validDerivPred :: TyVarSet -> PredType -> Bool
validDerivPred tv_set pred
= case classifyPredType pred of
ClassPred _ tys -> hasNoDups fvs
&& sizeTypes tys == length fvs
&& all (`elemVarSet` tv_set) fvs
TuplePred ps -> all (validDerivPred tv_set) ps
_ -> True -- Non-class predicates are ok
ClassPred _ tys -> check_tys tys
-- EqPred ReprEq is a Coercible constraint; treat
-- like a class
EqPred ReprEq ty1 ty2 -> check_tys [ty1, ty2]
TuplePred ps -> all (validDerivPred tv_set) ps
_ -> True -- Non-class predicates are ok
where
check_tys tys = hasNoDups fvs
&& sizeTypes tys == length fvs
&& all (`elemVarSet` tv_set) fvs