diff options
Diffstat (limited to 'compiler')
60 files changed, 3749 insertions, 3702 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 2760156e1c..616316c7ff 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -66,6 +66,7 @@ module BasicTypes( StrictnessMark(..), isMarkedStrict, DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, CompilerPhase(..), PhaseNum, Activation(..), isActive, isActiveIn, @@ -125,6 +126,31 @@ type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). %************************************************************************ %* * + Swap flag +%* * +%************************************************************************ + +\begin{code} +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + +instance Outputable SwapFlag where + ppr IsSwapped = ptext (sLit "Is-swapped") + ppr NotSwapped = ptext (sLit "Not-swapped") + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a +\end{code} + + +%************************************************************************ +%* * \subsection[FunctionOrData]{FunctionOrData} %* * %************************************************************************ diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 93762abba9..1d777895e4 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -142,7 +142,7 @@ data IdDetails -- instance C a => C [a] -- has is_silent = 1, because the dfun -- has type dfun :: (D a, C a) => C [a] - -- See the DFun Superclass Invariant in TcInstDcls + -- See Note [Silent superclass arguments] in TcInstDcls -- -- Bool = True <=> the class has only one method, so may be -- implemented with a newtype, so it might be bad diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 3d89f59f04..de8bd7dae7 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -45,7 +45,7 @@ module Name ( -- ** Creating 'Name's mkSystemName, mkSystemNameAt, - mkInternalName, mkDerivedInternalName, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, mkSystemVarName, mkSysTvName, mkFCallName, mkExternalName, mkWiredInName, @@ -266,6 +266,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq -- * for interface files we tidyCore first, which makes -- the OccNames distinct when they need to be +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index cdd79f5db2..bd829550c8 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -27,7 +27,8 @@ module VarEnv ( modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, foldVarEnv, elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv_Directly, restrictVarEnv, + filterVarEnv_Directly, restrictVarEnv, + partitionVarEnv, -- * The InScopeSet type InScopeSet, @@ -384,6 +385,7 @@ extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a @@ -430,6 +432,7 @@ isEmptyVarEnv = isNullUFM foldVarEnv = foldUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv_Directly = filterUFM_Directly +partitionVarEnv = partitionUFM restrictVarEnv env vs = filterVarEnv_Directly keep env where diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index dcd366f381..250efdd85d 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -838,6 +838,19 @@ lintCoercion the_co@(NthCo n co) _ -> failWithL (hang (ptext (sLit "Bad getNth:")) 2 (ppr the_co $$ ppr s $$ ppr t)) } +lintCoercion the_co@(LRCo lr co) + = do { (_,s,t) <- lintCoercion co + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just s_pr, Just t_pr) + -> return (k, s_pick, t_pick) + where + s_pick = pickLR lr s_pr + t_pick = pickLR lr t_pr + k = typeKind s_pick + + _ -> failWithL (hang (ptext (sLit "Bad LRCo:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } + lintCoercion (InstCo co arg_ty) = do { (k,s,t) <- lintCoercion co ; arg_kind <- lintType arg_ty diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index d2f6691a7c..287f08049e 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -74,6 +74,9 @@ data Ty | UnsafeCoercion Ty Ty | InstCoercion Ty Ty | NthCoercion Int Ty + | LRCoercion LeftOrRight Ty + +data LeftOrRight = CLeft | CRight data Kind = Klifted diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 21037088e1..8844818bdc 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -326,8 +326,13 @@ make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (mak make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co) make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2) make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co) +make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co) make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty) +make_lr :: LeftOrRight -> C.LeftOrRight +make_lr CLeft = C.CLeft +make_lr CRight = C.CRight + -- Used for both tycon app coercions and axiom instantiations. make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty make_conAppCo dflags con cos = diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index 26e64ee641..2290810fe1 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -114,6 +114,10 @@ pty (UnsafeCoercion t1 t2) = sep [text "%unsafe", paty t1, paty t2] pty (NthCoercion n t) = sep [text "%nth", int n, paty t] +pty (LRCoercion CLeft t) = + sep [text "%left", paty t] +pty (LRCoercion CRight t) = + sep [text "%right", paty t] pty (InstCoercion t1 t2) = sep [text "%inst", paty t1, paty t2] pty t = pbty t diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index 7170f1cede..6bc78a8272 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -470,6 +470,8 @@ data CoercionMap a , km_sym :: CoercionMap a , km_trans :: CoercionMap (CoercionMap a) , km_nth :: IntMap.IntMap (CoercionMap a) + , km_left :: CoercionMap a + , km_right :: CoercionMap a , km_inst :: CoercionMap (TypeMap a) } wrapEmptyKM :: CoercionMap a @@ -477,7 +479,8 @@ wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv , km_app = emptyTM, km_forall = emptyTM , km_var = emptyTM, km_axiom = emptyNameEnv , km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM - , km_nth = emptyTM, km_inst = emptyTM } + , km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM + , km_inst = emptyTM } instance TrieMap CoercionMap where type Key CoercionMap = Coercion @@ -493,7 +496,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc , km_app = kapp, km_forall = kforall , km_var = kvar, km_axiom = kax , km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans - , km_nth = knth, km_inst = kinst }) + , km_nth = knth, km_left = kml, km_right = kmr + , km_inst = kinst }) = KM { km_refl = mapTM f krefl , km_tc_app = mapNameEnv (mapTM f) ktc , km_app = mapTM (mapTM f) kapp @@ -504,6 +508,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc , km_sym = mapTM f ksym , km_trans = mapTM (mapTM f) ktrans , km_nth = IntMap.map (mapTM f) knth + , km_left = mapTM f kml + , km_right = mapTM f kmr , km_inst = mapTM (mapTM f) kinst } lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a @@ -522,6 +528,8 @@ lkC env co m go (CoVarCo v) = km_var >.> lkVar env v go (SymCo c) = km_sym >.> lkC env c go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c + go (LRCo CLeft c) = km_left >.> lkC env c + go (LRCo CRight c) = km_right >.> lkC env c xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a xtC env co f EmptyKM = xtC env co f wrapEmptyKM @@ -534,9 +542,11 @@ xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f } xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c |>> xtBndr env v f } -xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } -xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } -xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } +xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } +xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } +xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } +xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f } +xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f } fdC :: (a -> b -> b) -> CoercionMap a -> b -> b fdC _ EmptyKM = \z -> z @@ -550,6 +560,8 @@ fdC k m = foldTM k (km_refl m) . foldTM k (km_sym m) . foldTM (foldTM k) (km_trans m) . foldTM (foldTM k) (km_nth m) + . foldTM k (km_left m) + . foldTM k (km_right m) . foldTM (foldTM k) (km_inst m) \end{code} diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 493ff0c13e..d92f2d1dd7 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -576,6 +576,7 @@ addTickHsExpr (HsWrap w e) = (addTickHsExpr e) -- explicitly no tick on inside addTickHsExpr e@(HsType _) = return e +addTickHsExpr HsHole = panic "addTickHsExpr.HsHole" -- Others dhould never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4fa1ec00c9..95d36f3879 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -440,8 +440,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | otherwise = putSrcSpanDs loc $ - do { let poly_name = idName poly_id - ; spec_name <- newLocalName poly_name + do { uniq <- newUnique + ; let poly_name = idName poly_id + spec_name = mkClonedInternalName uniq poly_name ; (bndrs, ds_lhs) <- liftM collectBinders (dsHsWrapper spec_co (Var poly_id)) ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) @@ -740,10 +741,6 @@ dsEvTerm (EvCast tm co) -- 'v' is always a lifted evidence variable so it is -- unnecessary to call varToCoreExpr v here. -dsEvTerm (EvKindCast v co) - = do { v' <- dsEvTerm v - ; dsTcCoercion co $ (\_ -> v') } - dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms ; return (Var df `mkTyApps` tys `mkApps` tms') } dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox @@ -833,6 +830,7 @@ ds_tc_coercion subst tc_co go (TcSymCo co) = mkSymCo (go co) go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2) go (TcNthCo n co) = mkNthCo n (go co) + go (TcLRCo lr co) = mkLRCo lr (go co) go (TcInstCo co ty) = mkInstCo (go co) ty go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 8c53c1aea1..a7501594e6 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -216,6 +216,8 @@ dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty)) dsExpr (HsApp fun arg) = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg + +dsExpr HsHole = panic "dsExpr: HsHole" \end{code} Note [Desugaring vars] diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 80429d7c9c..719b080492 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -294,6 +294,7 @@ data HsExpr id | HsWrap HsWrapper -- TRANSLATION (HsExpr id) + | HsHole deriving (Data, Typeable) -- HsTupArg is used for tuple sections @@ -559,6 +560,8 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) ppr_expr (HsArrForm op _ args) = hang (ptext (sLit "(|") <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) +ppr_expr HsHole + = ptext $ sLit "_" pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index a319f6ed62..616bc0acf4 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -20,11 +20,12 @@ module BinIface ( #include "HsVersions.h" import TcRnMonad -import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon) +import TyCon import DataCon (dataConName, dataConWorkId, dataConTyCon) import PrelInfo (wiredInThings, basicKnownKeyNames) import Id (idName, isDataConWorkId_maybe) import CoreSyn (DFunArg(..)) +import Coercion (LeftOrRight(..)) import TysWiredIn import IfaceEnv import HscTypes @@ -1037,6 +1038,15 @@ instance Binary IfaceTyCon where put_ bh (IfaceTc ext) = put_ bh ext get bh = liftM IfaceTc (get bh) +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + instance Binary IfaceCoCon where put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } put_ bh IfaceReflCo = putByte bh 1 @@ -1045,6 +1055,7 @@ instance Binary IfaceCoCon where put_ bh IfaceTransCo = putByte bh 4 put_ bh IfaceInstCo = putByte bh 5 put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + put_ bh (IfaceLRCo lr) = do { putByte bh 7; put_ bh lr } get bh = do h <- getByte bh @@ -1056,6 +1067,7 @@ instance Binary IfaceCoCon where 4 -> return IfaceTransCo 5 -> return IfaceInstCo 6 -> do { d <- get bh; return (IfaceNthCo d) } + 7 -> do { lr <- get bh; return (IfaceLRCo lr) } _ -> panic ("get IfaceCoCon " ++ show h) ------------------------------------------------------------------------- @@ -1392,6 +1404,18 @@ instance Binary IfaceDecl where occ <- return $! mkOccNameFS tcName a1 return (IfaceAxiom occ a2 a3 a4) +instance Binary ty => Binary (SynTyConRhs ty) where + put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { a <- get bh + ; b <- get bh + ; return (SynFamilyTyCon a b) } + _ -> do { ty <- get bh + ; return (SynonymTyCon ty) } } + instance Binary IfaceClsInst where put_ bh (IfaceClsInst cls tys dfun flag orph) = do put_ bh cls diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 9456bdaf34..5f5e8a1896 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -46,7 +46,7 @@ import Outputable \begin{code} ------------------------------------------------------ buildSynTyCon :: Name -> [TyVar] - -> SynTyConRhs + -> SynTyConRhs Type -> Kind -- ^ Kind of the RHS -> TyConParent -> TcRnIf m n TyCon diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index a41a9dac47..06c7b67ba6 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -35,6 +35,7 @@ module IfaceSyn ( #include "HsVersions.h" +import TyCon( SynTyConRhs(..) ) import IfaceType import CoreSyn( DFunArg, dfunArgExprs ) import PprCore() -- Printing DFunArgs @@ -89,9 +90,7 @@ data IfaceDecl | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn - -- Nothing for an type family declaration - } + ifSynRhs :: SynTyConRhs IfaceType } | IfaceClass { ifCtxt :: IfaceContext, -- Context... ifName :: OccName, -- Name of the class TyCon @@ -487,12 +486,12 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty}) + ifSynRhs = SynonymTyCon mono_ty}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Nothing, ifSynKind = kind }) + ifSynRhs = SynFamilyTyCon {}, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) @@ -797,9 +796,9 @@ freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon -freeNamesIfSynRhs :: Maybe IfaceType -> NameSet -freeNamesIfSynRhs (Just ty) = freeNamesIfType ty -freeNamesIfSynRhs Nothing = emptyNameSet +freeNamesIfSynRhs :: SynTyConRhs IfaceType -> NameSet +freeNamesIfSynRhs (SynonymTyCon ty) = freeNamesIfType ty +freeNamesIfSynRhs _ = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 225a3c812b..4a35f0049b 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -99,7 +99,7 @@ data IfaceCoCon = IfaceCoAx IfExtName | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo | IfaceTransCo | IfaceInstCo - | IfaceNthCo Int + | IfaceNthCo Int | IfaceLRCo LeftOrRight \end{code} %************************************************************************ @@ -278,6 +278,7 @@ instance Outputable IfaceCoCon where ppr IfaceTransCo = ptext (sLit "Trans") ppr IfaceInstCo = ptext (sLit "Inst") ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d + ppr (IfaceLRCo lr) = ppr lr instance Outputable IfaceTyLit where ppr = ppr_tylit @@ -376,6 +377,8 @@ coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo , coToIfaceType co2 ] coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d) [ coToIfaceType co ] +coToIfaceType (LRCo lr co) = IfaceCoConApp (IfaceLRCo lr) + [ coToIfaceType co ] coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo [ coToIfaceType co , toIfaceType ty ] diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index d92cb4a185..a4a9dfc5f6 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1459,11 +1459,11 @@ tyConToIfaceDecl env tycon | Just clas <- tyConClass_maybe tycon = classToIfaceDecl env clas - | isSynTyCon tycon + | Just syn_rhs <- synTyConRhs_maybe tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifSynRhs = syn_rhs, - ifSynKind = syn_ki } + ifSynRhs = to_ifsyn_rhs syn_rhs, + ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1483,18 +1483,12 @@ tyConToIfaceDecl env tycon where (env1, tyvars) = tidyTyVarBndrs env (tyConTyVars tycon) - (syn_rhs, syn_ki) - = case synTyConRhs tycon of - SynFamilyTyCon -> - ( Nothing - , tidyToIfaceType env1 (synTyConResKind tycon) ) - SynonymTyCon ty -> - ( Just (tidyToIfaceType env1 ty) - , tidyToIfaceType env1 (typeKind ty) ) + to_ifsyn_rhs (SynFamilyTyCon a b) = SynFamilyTyCon a b + to_ifsyn_rhs (SynonymTyCon ty) = SynonymTyCon (tidyToIfaceType env1 ty) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls DataFamilyTyCon {} = IfDataFamTyCon + ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 80c2029a70..b9783a8d4f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -474,9 +474,9 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type syonym") <+> ppr n - tc_syn_rhs Nothing = return SynFamilyTyCon - tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty - ; return (SynonymTyCon rhs_ty) } + tc_syn_rhs (SynFamilyTyCon a b) = return (SynFamilyTyCon a b) + tc_syn_rhs (SynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, @@ -962,6 +962,7 @@ tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t +tcIfaceCoApp (IfaceLRCo lr) [t] = LRCo lr <$> tcIfaceCo t tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) tcIfaceCoVar :: FastString -> IfL CoVar diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b412fc1166..7ae46532c5 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -510,6 +510,7 @@ data ExtensionFlag | Opt_TraditionalRecordSyntax | Opt_LambdaCase | Opt_MultiWayIf + | Opt_TypeHoles deriving (Eq, Enum, Show) -- | Contains not only a collection of 'DynFlag's but also a plethora of @@ -2451,7 +2452,8 @@ xFlags = [ ( "OverlappingInstances", Opt_OverlappingInstances, nop ), ( "UndecidableInstances", Opt_UndecidableInstances, nop ), ( "IncoherentInstances", Opt_IncoherentInstances, nop ), - ( "PackageImports", Opt_PackageImports, nop ) + ( "PackageImports", Opt_PackageImports, nop ), + ( "TypeHoles", Opt_TypeHoles, nop ) ] defaultFlags :: Platform -> [DynFlag] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index b1cc786840..06b3ecaf23 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -159,7 +159,7 @@ module GHC ( tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, isFamilyTyCon, tyConClass_maybe, - synTyConDefn, synTyConType, synTyConResKind, + synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind, -- ** Type variables TyVar, diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 1ee18f84e3..0fa7bdff52 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -165,13 +165,13 @@ pprTypeForUser print_foralls ty pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprTyCon pefas ss tyCon - | GHC.isSynTyCon tyCon - = if GHC.isFamilyTyCon tyCon - then pprTyConHdr pefas tyCon <+> dcolon <+> - pprTypeForUser pefas (GHC.synTyConResKind tyCon) - else - let rhs_type = GHC.synTyConType tyCon - in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) + | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon + = case syn_rhs of + SynFamilyTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) + SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) + 2 (pprTypeForUser pefas rhs_ty) + | Just cls <- GHC.tyConClass_maybe tyCon = pprClass pefas ss cls | otherwise diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 56f2d48f61..aceb67229e 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -131,6 +131,7 @@ isStaticFlag f = "fruntime-types", "fno-pre-inlining", "fno-opt-coercion", + "fno-flat-cache", "fexcess-precision", "fhardwire-lib-paths", "fcpr-off", diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 3165c6944b..fa4b61e287 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -48,6 +48,7 @@ module StaticFlags ( opt_SimplExcessPrecision, opt_NoOptCoercion, opt_MaxWorkerArgs, + opt_NoFlatCache, -- Unfolding control opt_UF_CreationThreshold, @@ -243,6 +244,9 @@ opt_SimplExcessPrecision = lookUp (fsLit "-fexcess-precision") opt_NoOptCoercion :: Bool opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") +opt_NoFlatCache :: Bool +opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache") + -- Unfolding control -- See Note [Discounts and thresholds] in CoreUnfold diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 1b8d96df35..5d177d5016 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -654,7 +654,13 @@ The type constructor Any of kind forall k. k -> k has these properties: primitive type: - has a fixed unique, anyTyConKey, - lives in the global name cache - - built with TyCon.PrimTyCon + + * It is a *closed* type family, with no instances. This means that + if ty :: '(k1, k2) we add a given coercion + g :: ty ~ (Fst ty, Snd ty) + If Any was a *data* type, then we'd get inconsistency becuase 'ty' + could be (Any '(k1,k2)) and then we'd have an equality with Any on + one side and '(,) on the other * It is lifted, and hence represented by a pointer @@ -714,6 +720,17 @@ anyTyCon :: TyCon anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) +{- Can't do this yet without messing up kind proxies +anyTyCon :: TyCon +anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] + syn_rhs + NoParentTyCon + where + kind = ForAllTy kKiVar (mkTyVarTy kKiVar) + syn_rhs = SynFamilyTyCon { synf_open = False, synf_injective = True } + -- NB Closed, injective +-} + anyTypeOfKind :: Kind -> Type anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind] \end{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 78a64344f3..ec495ad33d 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -34,7 +34,7 @@ import HsSyn import TcRnMonad import TcEnv ( thRnBrack ) import RnEnv -import RnTypes +import RnTypes import RnPat import DynFlags import BasicTypes ( FixityDirection(..) ) @@ -299,6 +299,9 @@ rnExpr (ArithSeq _ seq) rnExpr (PArrSeq _ seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> return (PArrSeq noPostTcExpr new_seq, fvs) + +rnExpr HsHole + = return (HsHole, emptyFVs) \end{code} These three are pattern syntax appearing in expressions. @@ -306,7 +309,11 @@ Since all the symbols are reservedops we can simply reject them. We return a (bogus) EWildPat in each case. \begin{code} -rnExpr e@EWildPat = patSynErr e +rnExpr e@EWildPat = do { holes <- xoptM Opt_TypeHoles + ; if holes + then return (HsHole, emptyFVs) + else patSynErr e + } rnExpr e@(EAsPat {}) = patSynErr e rnExpr e@(EViewPat {}) = patSynErr e rnExpr e@(ELazyPat {}) = patSynErr e @@ -331,6 +338,11 @@ rnExpr (HsArrApp arrow arg _ ho rtl) return (HsArrApp arrow' arg' placeHolderType ho rtl, fvArrow `plusFV` fvArg) where + -- See Note [Escaping the arrow scope] in TcRnTypes + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. select_arrow_scope tc = case ho of HsHigherOrderApp -> tc HsFirstOrderApp -> escapeArrowScope tc diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index eed579eed7..678136d439 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -477,7 +477,7 @@ mkStgAltType bndr alts = case repType (idType bndr) of _is_poly_alt_tycon tc = isFunTyCon tc || isPrimTyCon tc -- "Any" is lifted but primitive - || isFamilyTyCon tc -- Type family; e.g. arising from strict + || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict -- function application where argument has a -- type-family type diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index b6370b5c92..45ef02657e 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -26,7 +26,6 @@ import Name import Module import Outputable import UniqFM -import VarSet import FastString import Util import Maybes @@ -177,7 +176,9 @@ tcLookupFamInst tycon tys | otherwise = do { instEnv <- tcGetFamInstEnvs ; let mb_match = lookupFamInstEnv instEnv tycon tys - ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv) +-- ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ +-- pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ +-- ppr mb_match $$ ppr instEnv) ; case mb_match of [] -> return Nothing ((fam_inst, rep_tys):_) diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 2de781578d..67b66fd579 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -25,15 +25,12 @@ module Inst ( tcSyntaxName, -- Simple functions over evidence variables - hasEqualities, unitImplication, + hasEqualities, tyVarsOfWC, tyVarsOfBag, - tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication, - tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts, + tyVarsOfCt, tyVarsOfCts, - tidyEvVar, tidyCt, tidyGivenLoc, - - substEvVar, substImplication, substCt + tidyEvVar, tidyCt, tidySkolemInfo ) where #include "HsVersions.h" @@ -86,7 +83,7 @@ emitWanted :: CtOrigin -> TcPredType -> TcM EvVar emitWanted origin pred = do { loc <- getCtLoc origin ; ev <- newWantedEvVar pred - ; emitFlat (mkNonCanonical (Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev })) + ; emitFlat (mkNonCanonical loc (CtWanted { ctev_pred = pred, ctev_evar = ev })) ; return ev } newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) @@ -366,14 +363,14 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv -> TcRn (TidyEnv, SDoc) -syntaxNameCtxt name orig ty tidy_env = do - inst_loc <- getCtLoc orig - let - msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+> - ptext (sLit "(needed by a syntactic construct)"), - nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)), - nest 2 (pprArisingAt inst_loc)] - return (tidy_env, msg) +syntaxNameCtxt name orig ty tidy_env + = do { inst_loc <- getCtLoc orig + ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name) + <+> ptext (sLit "(needed by a syntactic construct)") + , nest 2 (ptext (sLit "has the required type:") + <+> ppr (tidyType tidy_env ty)) + , nest 2 (pprArisingAt inst_loc) ] + ; return (tidy_env, msg) } \end{code} @@ -515,11 +512,6 @@ addClsInstsErr herald ispecs %************************************************************************ \begin{code} -unitImplication :: Implication -> Bag Implication -unitImplication implic - | isEmptyWC (ic_wanted implic) = emptyBag - | otherwise = unitBag implic - hasEqualities :: [EvVar] -> Bool -- Has a bunch of canonical constraints (all givens) got any equalities in it? hasEqualities givens = any (has_eq . evVarPred) givens @@ -534,37 +526,30 @@ hasEqualities givens = any (has_eq . evVarPred) givens ---------------- Getting free tyvars ------------------------- tyVarsOfCt :: Ct -> TcTyVarSet +-- NB: the tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys) tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys -tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty -tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl) - -tyVarsOfCDict :: Ct -> TcTyVarSet -tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys -tyVarsOfCDict _ct = emptyVarSet - -tyVarsOfCDicts :: Cts -> TcTyVarSet -tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet +tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) +tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev) tyVarsOfCts :: Cts -> TcTyVarSet tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet tyVarsOfWC :: WantedConstraints -> TyVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) = tyVarsOfCts flat `unionVarSet` - tyVarsOfBag tyVarsOfImplication implic `unionVarSet` + tyVarsOfBag tyVarsOfImplic implic `unionVarSet` tyVarsOfCts insol -tyVarsOfImplication :: Implication -> TyVarSet -tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted }) - = tyVarsOfWC wanted `delVarSetList` skols - -tyVarsOfEvVar :: EvVar -> TyVarSet -tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev - -tyVarsOfEvVars :: [EvVar] -> TyVarSet -tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet +tyVarsOfImplic :: Implication -> TyVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyVarsOfImplic (Implic { ic_skols = skols, ic_fsks = fsks + , ic_given = givens, ic_wanted = wanted }) + = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens)) + `delVarSetList` skols `delVarSetList` fsks tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet @@ -575,95 +560,45 @@ tidyCt :: TidyEnv -> Ct -> Ct -- Used only in error reporting -- Also converts it to non-canonical tidyCt env ct - = CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct) - , cc_depth = cc_depth ct } + = case ct of + CHoleCan { cc_ev = ev } + -> ct { cc_ev = tidy_ev env ev } + _ -> CNonCanonical { cc_ev = tidy_ev env (cc_ev ct) + , cc_loc = cc_loc ct } where - tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence + tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence -- NB: we do not tidy the ctev_evtm/var field because we don't -- show it in error messages - tidy_flavor env ctev@(Given { ctev_gloc = gloc, ctev_pred = pred }) - = ctev { ctev_gloc = tidyGivenLoc env gloc - , ctev_pred = tidyType env pred } - tidy_flavor env ctev@(Wanted { ctev_pred = pred }) + tidy_ev env ctev@(CtGiven { ctev_pred = pred }) = ctev { ctev_pred = tidyType env pred } - tidy_flavor env ctev@(Derived { ctev_pred = pred }) + tidy_ev env ctev@(CtWanted { ctev_pred = pred }) + = ctev { ctev_pred = tidyType env pred } + tidy_ev env ctev@(CtDerived { ctev_pred = pred }) = ctev { ctev_pred = tidyType env pred } tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = setVarType var (tidyType env (varType var)) -tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc -tidyGivenLoc env (CtLoc skol span ctxt) - = CtLoc (tidySkolemInfo env skol) span ctxt - -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) - = UnifyForAllSkol (map tidy_tv skol_tvs) (tidyType env ty) - where - tidy_tv tv = case getTyVar_maybe ty' of - Just tv' -> tv' - Nothing -> pprPanic "ticySkolemInfo" (ppr tv <+> ppr ty') - where - ty' = tidyTyVarOcc env tv -tidySkolemInfo _ info = info - ----------------- Substitution ------------------------- --- This is used only in TcSimpify, for substituations that are *also* --- reflected in the unification variables. So we don't substitute --- in the evidence. - -substCt :: TvSubst -> Ct -> Ct --- Conservatively converts it to non-canonical: --- Postcondition: if the constraint does not get rewritten -substCt subst ct - | pty <- ctPred ct - , sty <- substTy subst pty - = if sty `eqType` pty then - ct { cc_ev = substFlavor subst (cc_ev ct) } - else - CNonCanonical { cc_ev = substFlavor subst (cc_ev ct) - , cc_depth = cc_depth ct } - -substWC :: TvSubst -> WantedConstraints -> WantedConstraints -substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = WC { wc_flat = mapBag (substCt subst) flat - , wc_impl = mapBag (substImplication subst) implic - , wc_insol = mapBag (substCt subst) insol } - -substImplication :: TvSubst -> Implication -> Implication -substImplication subst implic@(Implic { ic_skols = tvs - , ic_given = given - , ic_wanted = wanted - , ic_loc = loc }) - = implic { ic_skols = tvs' - , ic_given = map (substEvVar subst1) given - , ic_wanted = substWC subst1 wanted - , ic_loc = substGivenLoc subst1 loc } +tidySkolemInfo :: TidyEnv -> SkolemInfo -> (TidyEnv, SkolemInfo) +tidySkolemInfo env (SigSkol cx ty) + = (env', SigSkol cx ty') where - (subst1, tvs') = mapAccumL substTyVarBndr subst tvs - -substEvVar :: TvSubst -> EvVar -> EvVar -substEvVar subst var = setVarType var (substTy subst (varType var)) - -substFlavor :: TvSubst -> CtEvidence -> CtEvidence -substFlavor subst ctev@(Given { ctev_gloc = gloc, ctev_pred = pred }) - = ctev { ctev_gloc = substGivenLoc subst gloc - , ctev_pred = substTy subst pred } + (env', ty') = tidyOpenType env ty -substFlavor subst ctev@(Wanted { ctev_pred = pred }) - = ctev { ctev_pred = substTy subst pred } - -substFlavor subst ctev@(Derived { ctev_pred = pty }) - = ctev { ctev_pred = substTy subst pty } +tidySkolemInfo env (InferSkol ids) + = (env', InferSkol ids') + where + (env', ids') = mapAccumL do_one env ids + do_one env (name, ty) = (env', (name, ty')) + where + (env', ty') = tidyOpenType env ty -substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc -substGivenLoc subst (CtLoc skol span ctxt) - = CtLoc (substSkolemInfo subst skol) span ctxt +tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) + = (env1, UnifyForAllSkol skol_tvs' ty') + where + env1 = tidyFreeTyVars env (tyVarsOfType ty `delVarSetList` skol_tvs) + (env2, skol_tvs') = tidyTyVarBndrs env1 skol_tvs + ty' = tidyType env2 ty -substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo -substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty) -substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids) -substSkolemInfo _ info = info +tidySkolemInfo env info = (env, info) \end{code} diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index e15b2adc6e..9d3d433a9b 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -18,6 +18,7 @@ import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) import HsSyn import TcMatches +-- import TcSimplify( solveWantedsTcM ) import TcType import TcMType import TcBinds @@ -160,18 +161,20 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) + -- ToDo: There should be no need for the escapeArrowScope stuff + -- See Note [Escaping the arrow scope] in TcRnTypes ; arg' <- tcMonoExpr arg arg_ty ; return (HsArrApp fun' arg' fun_ty ho_app lr) } where - -- Before type-checking f, use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside f. In the higher-order case (-<<), they are. + -- Before type-checking f, use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside f. In the higher-order case (-<<), they are. select_arrow_scope tc = case ho_app of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc ------------------------------------------- -- Command application @@ -256,15 +259,34 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] e_res_ty + -- ToDo: SLPJ: something is badly wrong here. + -- The escapeArrowScope pops the Untouchables.. but that + -- risks screwing up the skolem-escape check + -- Moreover, arrowfail001 fails with an ASSERT failure + -- because a variable gets the wrong level -- Check expr - ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ - escapeArrowScope (tcMonoExpr expr e_ty) + ; (inner_binds, expr') + <- checkConstraints ArrowSkol [w_tv] [] $ + escapeArrowScope (tcMonoExpr expr e_ty) + +{- + ; ((inner_binds, expr'), lie) + <- captureConstraints $ + checkConstraints ArrowSkol [w_tv] [] $ + tcMonoExpr expr e_ty + -- No need for escapeArrowScope in the + -- type checker. + -- Note [Escaping the arrow scope] in TcRnTypes + ; (lie, outer_binds) <- solveWantedsTcM lie + ; emitConstraints lie +-} -- OK, now we are in a position to unscramble -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; let wrap = WpTyLam w_tv <.> mkWpLet inst_binds + ; let wrap = {- mkWpLet (EvBinds outer_binds) <.> -} + WpTyLam w_tv <.> mkWpLet inner_binds ; return (HsArrForm (mkLHsWrap wrap expr') fixity cmds') } where -- Make the types diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index f9c58ccd99..3f9f7cc4c2 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,7 +6,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcHsBootSigs, tcPolyBinds, tcPolyCheck, + tcHsBootSigs, tcPolyCheck, PragFun, tcSpecPrags, tcVectDecls, mkPragFun, TcSigInfo(..), TcSigFun, instTcTySig, instTcTySigFromId, @@ -274,7 +274,8 @@ tcValBinds top_lvl binds sigs thing_inside -- Extend the envt right away with all -- the Ids declared with type signatures - ; (binds', thing) <- tcExtendIdEnv poly_ids $ + -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack + ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ tcBindGroups top_lvl sig_fn prag_fn binds thing_inside @@ -336,7 +337,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing) go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc - ; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $ go sccs + ; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $ + go sccs ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) } go [] = do { thing <- thing_inside; return (emptyBag, [], thing) } @@ -397,20 +399,15 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list { traceTc "------------------------------------------------" empty ; traceTc "Bindings for {" (ppr binder_names) - --- -- Instantiate the polytypes of any binders that have signatures --- -- (as determined by sig_fn), returning a TcSigInfo for each --- ; tc_sig_fn <- tcInstSigs sig_fn binder_names - ; dflags <- getDynFlags ; type_env <- getLclTypeEnv ; let plan = decideGeneralisationPlan dflags type_env binder_names bind_list sig_fn ; traceTc "Generalisation plan" (ppr plan) ; result@(tc_binds, poly_ids, _) <- case plan of - NoGen -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list - InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list - CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list + NoGen -> tcPolyNoGen top_lvl rec_tc prag_fn sig_fn bind_list + InferGen mn cl -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn mn cl bind_list + CheckGen sig -> tcPolyCheck top_lvl rec_tc prag_fn sig bind_list -- Check whether strict bindings are ok -- These must be non-recursive etc, and are not generalised @@ -429,17 +426,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list -- span that includes them all ------------------ -tcPolyNoGen - :: TcSigFun -> PragFun +tcPolyNoGen -- No generalisation whatsoever + :: TopLevelFlag -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures + -> PragFun -> TcSigFun -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) --- No generalisation whatsoever -tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list - = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) - rec_tc bind_list +tcPolyNoGen top_lvl rec_tc prag_fn tc_sig_fn bind_list + = do { (binds', mono_infos) <- tcMonoBinds top_lvl rec_tc tc_sig_fn + (LetGblBndr prag_fn) + bind_list ; mono_ids' <- mapM tc_mono_info mono_infos ; return (binds', mono_ids', NotTopLevel) } where @@ -455,17 +453,19 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list -- So we can safely ignore _specs ------------------ -tcPolyCheck :: TcSigInfo -> PragFun +tcPolyCheck :: TopLevelFlag -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures + -> PragFun -> TcSigInfo -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -- There is just one binding, -- it binds a single variable, -- it has a signature, -tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped +tcPolyCheck top_lvl rec_tc prag_fn + sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped , sig_theta = theta, sig_tau = tau, sig_loc = loc }) - prag_fn rec_tc bind_list + bind_list = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) @@ -474,7 +474,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped <- setSrcSpan loc $ checkConstraints skol_info tvs ev_vars $ tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ - tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list + tcMonoBinds top_lvl rec_tc (\_ -> Just sig) LetLclBndr bind_list ; spec_prags <- tcSpecPrags poly_id prag_sigs ; poly_id <- addInlinePrags poly_id prag_sigs @@ -494,22 +494,22 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped ------------------ tcPolyInfer - :: Bool -- True <=> apply the monomorphism restriction - -> Bool -- True <=> free vars have closed types - -> TcSigFun -> PragFun + :: TopLevelFlag -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures + -> PragFun -> TcSigFun + -> Bool -- True <=> apply the monomorphism restriction + -> Bool -- True <=> free vars have closed types -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId], TopLevelFlag) -tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list - = do { (((binds', mono_infos), untch), wanted) +tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn mono closed bind_list + = do { ((binds', mono_infos), wanted) <- captureConstraints $ - captureUntouchables $ - tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list + tcMonoBinds top_lvl rec_tc tc_sig_fn LetLclBndr bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] ; (qtvs, givens, mr_bites, ev_binds) <- - simplifyInfer closed mono name_taus (untch,wanted) + simplifyInfer closed mono name_taus wanted ; theta <- zonkTcThetaType (map evVarPred givens) ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos @@ -525,10 +525,8 @@ tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list ; traceTc "Binding:" (ppr final_closed $$ ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids, final_closed) + ; return (unitBag abs_bind, poly_ids, final_closed) } -- poly_ids are guaranteed zonked by mkExport - } - -------------- mkExport :: PragFun @@ -938,14 +936,15 @@ should not typecheck because will not typecheck. \begin{code} -tcMonoBinds :: TcSigFun -> LetBndrSpec +tcMonoBinds :: TopLevelFlag -> RecFlag -- Whether the binding is recursive for typechecking purposes -- i.e. the binders are mentioned in their RHSs, and -- we are not rescued by a type signature + -> TcSigFun -> LetBndrSpec -> [LHsBind Name] -> TcM (LHsBinds TcId, [MonoBindInfo]) -tcMonoBinds sig_fn no_gen is_rec +tcMonoBinds top_lvl is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches, bind_fvs = fvs })] -- Single function binding, @@ -957,15 +956,17 @@ tcMonoBinds sig_fn no_gen is_rec -- e.g. f = \(x::forall a. a->a) -> <body> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches) - + do { rhs_ty <- newFlexiTyVarTy openTypeKind ; mono_id <- newNoSigLetBndr no_gen name rhs_ty + ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $ + tcMatchesFun name inf matches rhs_ty + ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', bind_fvs = fvs, fun_co_fn = co_fn, fun_tick = Nothing })), [(name, Nothing, mono_id)]) } -tcMonoBinds sig_fn no_gen _ binds +tcMonoBinds top_lvl _ sig_fn no_gen binds = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds -- Bring the monomorphic Ids, into scope for the RHSs @@ -974,10 +975,10 @@ tcMonoBinds sig_fn no_gen _ binds -- A monomorphic binding for each term variable that lacks -- a type sig. (Ones with a sig are already in scope.) - ; binds' <- tcExtendIdEnv2 rhs_id_env $ do - traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) - | (n,id) <- rhs_id_env] - mapM (wrapLocM tcRhs) tc_binds + ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env] + ; binds' <- tcExtendIdEnv2 rhs_id_env $ + mapM (wrapLocM (tcRhs top_lvl)) tc_binds ; return (listToBag binds', mono_info) } ------------------------ @@ -1033,13 +1034,14 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible ------------------- -tcRhs :: TcMonoBind -> TcM (HsBind TcId) +tcRhs :: TopLevelFlag -> TcMonoBind -> TcM (HsBind TcId) -- When we are doing pattern bindings, or multiple function bindings at a time -- we *don't* bring any scoped type variables into scope -- Wny not? They are not completely rigid. -- That's why we have the special case for a single FunBind in tcMonoBinds -tcRhs (TcFunBind (_,_,mono_id) loc inf matches) - = do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) +tcRhs top_lvl (TcFunBind (_,_,mono_id) loc inf matches) + = tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $ + do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf matches (idType mono_id) ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf @@ -1047,8 +1049,9 @@ tcRhs (TcFunBind (_,_,mono_id) loc inf matches) , fun_co_fn = co_fn , bind_fvs = placeHolderNames, fun_tick = Nothing }) } -tcRhs (TcPatBind _ pat' grhss pat_ty) - = do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) +tcRhs top_lvl (TcPatBind infos pat' grhss pat_ty) + = tcExtendIdBndrs [ TcIdBndr mono_id top_lvl | (_,_,mono_id) <- infos ] $ + do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index d38345844d..33c62dcc15 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -7,8 +7,7 @@ -- for details module TcCanonical( - canonicalize, flatten, flattenMany, occurCheckExpand, - FlattenMode (..), + canonicalize, occurCheckExpand, emitWorkNC, StopOrContinue (..) ) where @@ -28,19 +27,14 @@ import Outputable import Control.Monad ( when ) import MonadUtils import Control.Applicative ( (<|>) ) +import TysWiredIn ( eqTyCon ) -import TrieMap import VarSet import TcSMonad import FastString import Util - - -import TysWiredIn ( eqTyCon ) - -import Data.Maybe ( isJust, fromMaybe ) --- import Data.List ( zip4 ) +import Maybes( catMaybes ) \end{code} @@ -171,48 +165,46 @@ EvBinds, so we are again good. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canonicalize :: Ct -> TcS StopOrContinue -canonicalize ct@(CNonCanonical { cc_ev = fl, cc_depth = d }) +canonicalize ct@(CNonCanonical { cc_ev = ev, cc_loc = d }) = do { traceTcS "canonicalize (non-canonical)" (ppr ct) ; {-# SCC "canEvVar" #-} - canEvVar d fl } + canEvNC d ev } -canonicalize (CDictCan { cc_depth = d - , cc_ev = fl +canonicalize (CDictCan { cc_loc = d + , cc_ev = ev , cc_class = cls , cc_tyargs = xis }) = {-# SCC "canClass" #-} - canClass d fl cls xis -- Do not add any superclasses -canonicalize (CTyEqCan { cc_depth = d - , cc_ev = fl + canClass d ev cls xis -- Do not add any superclasses +canonicalize (CTyEqCan { cc_loc = d + , cc_ev = ev , cc_tyvar = tv , cc_rhs = xi }) - = {-# SCC "canEqLeafTyVarLeftRec" #-} - canEqLeafTyVarLeftRec d fl tv xi + = {-# SCC "canEqLeafTyVarEq" #-} + canEqLeafTyVarEq d ev tv xi -canonicalize (CFunEqCan { cc_depth = d - , cc_ev = fl +canonicalize (CFunEqCan { cc_loc = d + , cc_ev = ev , cc_fun = fn , cc_tyargs = xis1 , cc_rhs = xi2 }) - = {-# SCC "canEqLeafFunEqLeftRec" #-} - canEqLeafFunEqLeftRec d fl (fn,xis1) xi2 + = {-# SCC "canEqLeafFunEq" #-} + canEqLeafFunEq d ev fn xis1 xi2 -canonicalize (CIrredEvCan { cc_ev = fl - , cc_depth = d - , cc_ty = xi }) - = canIrred d fl xi +canonicalize (CIrredEvCan { cc_ev = ev + , cc_loc = d }) + = canIrred d ev +canonicalize (CHoleCan { cc_ev = ev, cc_loc = d }) + = canHole d ev - -canEvVar :: SubGoalDepth - -> CtEvidence - -> TcS StopOrContinue +canEvNC :: CtLoc -> CtEvidence -> TcS StopOrContinue -- Called only for non-canonical EvVars -canEvVar d fl - = case classifyPredType (ctEvPred fl) of - ClassPred cls tys -> canClassNC d fl cls tys - EqPred ty1 ty2 -> canEqNC d fl ty1 ty2 - IrredPred ev_ty -> canIrred d fl ev_ty - TuplePred tys -> canTuple d fl tys +canEvNC d ev + = case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> canClassNC d ev cls tys + EqPred ty1 ty2 -> canEqNC d ev ty1 ty2 + TuplePred tys -> canTuple d ev tys + IrredPred {} -> canIrred d ev \end{code} @@ -223,20 +215,15 @@ canEvVar d fl %************************************************************************ \begin{code} -canTuple :: SubGoalDepth -- Depth - -> CtEvidence -> [PredType] -> TcS StopOrContinue -canTuple d fl tys +canTuple :: CtLoc -> CtEvidence -> [PredType] -> TcS StopOrContinue +canTuple d ev tys = do { traceTcS "can_pred" (text "TuplePred!") ; let xcomp = EvTupleMk xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..] - ; ctevs <- xCtFlavor fl tys (XEvTerm xcomp xdecomp) - ; mapM_ add_to_work ctevs - ; return Stop } - where - add_to_work fl = addToWork $ canEvVar d fl + ; ctevs <- xCtFlavor ev tys (XEvTerm xcomp xdecomp) + ; canEvVarsCreated d ctevs } \end{code} - %************************************************************************ %* * %* Class Canonicalization @@ -245,7 +232,7 @@ canTuple d fl tys \begin{code} canClass, canClassNC - :: SubGoalDepth -- Depth + :: CtLoc -> CtEvidence -> Class -> [Type] -> TcS StopOrContinue -- Precondition: EvVar is class evidence @@ -255,32 +242,27 @@ canClass, canClassNC -- for already-canonical class constraints (but which might have -- been subsituted or somthing), and hence do not need superclasses -canClassNC d fl cls tys - = canClass d fl cls tys +canClassNC d ev cls tys + = canClass d ev cls tys `andWhenContinue` emitSuperclasses -canClass d fl cls tys - = do { -- sctx <- getTcSContext - ; (xis, cos) <- flattenMany d FMFullFlatten fl tys +canClass d ev cls tys + = do { (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys ; let co = mkTcTyConAppCo (classTyCon cls) cos xi = mkClassPred cls xis - - ; mb <- rewriteCtFlavor fl xi co - + ; mb <- rewriteCtFlavor ev xi co ; case mb of - Just new_fl -> - let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_fl) - in continueWith $ - CDictCan { cc_ev = new_fl - , cc_tyargs = xis_for_dict, cc_class = cls, cc_depth = d } - Nothing -> return Stop } + Nothing -> return Stop + Just new_ev -> continueWith $ + CDictCan { cc_ev = new_ev, cc_loc = d + , cc_tyargs = xis, cc_class = cls } } emitSuperclasses :: Ct -> TcS StopOrContinue -emitSuperclasses ct@(CDictCan { cc_depth = d, cc_ev = fl +emitSuperclasses ct@(CDictCan { cc_loc = d, cc_ev = ev , cc_tyargs = xis_new, cc_class = cls }) -- Add superclasses of this one here, See Note [Adding superclasses]. -- But only if we are not simplifying the LHS of a rule. - = do { newSCWorkFromFlavored d fl cls xis_new + = do { newSCWorkFromFlavored d ev cls xis_new -- Arguably we should "seq" the coercions if they are derived, -- as we do below for emit_kind_constraint, to allow errors in -- superclasses to be executed if deferred to runtime! @@ -352,8 +334,7 @@ By adding superclasses definitely only once, during canonicalisation, this situa happen. \begin{code} - -newSCWorkFromFlavored :: SubGoalDepth -- Depth +newSCWorkFromFlavored :: CtLoc -- Depth -> CtEvidence -> Class -> [Xi] -> TcS () -- Returns superclasses, see Note [Adding superclasses] newSCWorkFromFlavored d flavor cls xis @@ -367,9 +348,7 @@ newSCWorkFromFlavored d flavor cls xis xev = XEvTerm { ev_comp = panic "Can't compose for given!" , ev_decomp = xev_decomp } ; ctevs <- xCtFlavor flavor sc_theta xev - - ; traceTcS "newSCWork/Given" $ ppr "ctevs =" <+> ppr ctevs - ; mapM_ emit_non_can ctevs } + ; emitWorkNC d ctevs } | isEmptyVarSet (tyVarsOfTypes xis) = return () -- Wanteds with no variables yield no deriveds. @@ -379,13 +358,8 @@ newSCWorkFromFlavored d flavor cls xis = do { let sc_rec_theta = transSuperClasses cls xis impr_theta = filter is_improvement_pty sc_rec_theta ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta - ; mapM_ emit_der impr_theta } - - where emit_der pty = newDerived (ctev_wloc flavor) pty >>= mb_emit - mb_emit Nothing = return () - mb_emit (Just ctev) = emit_non_can ctev - emit_non_can ctev = updWorkListTcS $ - extendWorkListCt (CNonCanonical ctev d) + ; mb_der_evs <- mapM newDerived impr_theta + ; emitWorkNC d (catMaybes mb_der_evs) } is_improvement_pty :: PredType -> Bool -- Either it's an equality, or has some functional dependency @@ -407,25 +381,35 @@ is_improvement_pty ty = go (classifyPredType ty) \begin{code} -canIrred :: SubGoalDepth -- Depth - -> CtEvidence -> TcType -> TcS StopOrContinue +canIrred :: CtLoc -> CtEvidence -> TcS StopOrContinue -- Precondition: ty not a tuple and no other evidence form -canIrred d fl ty - = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) - ; (xi,co) <- flatten d FMFullFlatten fl ty -- co :: xi ~ ty +canIrred d ev + = do { let ty = ctEvPred ev + ; traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) + ; (xi,co) <- flatten d FMFullFlatten (ctEvFlavour ev) ty -- co :: xi ~ ty ; let no_flattening = xi `eqType` ty - -- In this particular case it is not safe to - -- say 'isTcReflCo' because the new constraint may - -- be reducible! - ; mb <- rewriteCtFlavor fl xi co + -- We can't use isTcReflCo, because even if the coercion is + -- Refl, the output type might have had a substitution + -- applied to it. For example 'a' might now be 'C b' + + ; if no_flattening then + continueWith $ + CIrredEvCan { cc_ev = ev, cc_loc = d } + else do + { mb <- rewriteCtFlavor ev xi co + ; case mb of + Just new_ev -> canEvNC d new_ev -- Re-classify and try again + Nothing -> return Stop } } -- Found a cached copy + +canHole :: CtLoc -> CtEvidence -> TcS StopOrContinue +canHole d ev + = do { let ty = ctEvPred ev + ; (xi,co) <- flatten d FMFullFlatten (ctEvFlavour ev) ty -- co :: xi ~ ty + ; mb <- rewriteCtFlavor ev xi co ; case mb of - Just new_fl - | no_flattening - -> continueWith $ - CIrredEvCan { cc_ev = new_fl, cc_ty = xi, cc_depth = d } - | otherwise - -> canEvVar d new_fl - Nothing -> return Stop } + Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d}) + Nothing -> return () -- Found a cached copy; won't happen + ; return Stop } \end{code} %************************************************************************ @@ -476,16 +460,16 @@ unexpanded synonym. \begin{code} -data FlattenMode = FMSubstOnly - | FMFullFlatten +data FlattenMode = FMSubstOnly | FMFullFlatten -- Flatten a bunch of types all at once. -flattenMany :: SubGoalDepth -- Depth - -> FlattenMode - -> CtEvidence -> [Type] -> TcS ([Xi], [TcCoercion]) +flattenMany :: CtLoc -> FlattenMode + -> CtFlavour -> [Type] -> TcS ([Xi], [TcCoercion]) -- Coercions :: Xi ~ Type -- Returns True iff (no flattening happened) --- NB: The EvVar inside the flavor is unused, we merely want Given/Solved/Derived/Wanted info +-- NB: The EvVar inside the 'ctxt :: CtEvidence' is unused, +-- we merely want (a) Given/Solved/Derived/Wanted info +-- (b) the GivenLoc/WantedLoc for when we create new evidence flattenMany d f ctxt tys = -- pprTrace "flattenMany" empty $ go tys @@ -497,36 +481,35 @@ flattenMany d f ctxt tys -- Flatten a type to get rid of type function applications, returning -- the new type-function-free type, and a collection of new equality -- constraints. See Note [Flattening] for more detail. -flatten :: SubGoalDepth -- Depth - -> FlattenMode - -> CtEvidence -> TcType -> TcS (Xi, TcCoercion) +flatten :: CtLoc -> FlattenMode + -> CtFlavour -> TcType -> TcS (Xi, TcCoercion) -- Postcondition: Coercion :: Xi ~ TcType -flatten d f ctxt ty +flatten loc f ctxt ty | Just ty' <- tcView ty - = do { (xi, co) <- flatten d f ctxt ty' + = do { (xi, co) <- flatten loc f ctxt ty' ; if eqType xi ty then return (ty,co) else return (xi,co) } -- Small tweak for better error messages flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) -flatten d f ctxt (TyVarTy tv) - = flattenTyVar d f ctxt tv +flatten loc f ctxt (TyVarTy tv) + = flattenTyVar loc f ctxt tv -flatten d f ctxt (AppTy ty1 ty2) - = do { (xi1,co1) <- flatten d f ctxt ty1 - ; (xi2,co2) <- flatten d f ctxt ty2 +flatten loc f ctxt (AppTy ty1 ty2) + = do { (xi1,co1) <- flatten loc f ctxt ty1 + ; (xi2,co2) <- flatten loc f ctxt ty2 ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) } -flatten d f ctxt (FunTy ty1 ty2) - = do { (xi1,co1) <- flatten d f ctxt ty1 - ; (xi2,co2) <- flatten d f ctxt ty2 +flatten loc f ctxt (FunTy ty1 ty2) + = do { (xi1,co1) <- flatten loc f ctxt ty1 + ; (xi2,co2) <- flatten loc f ctxt ty2 ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) } -flatten d f fl (TyConApp tc tys) +flatten loc f ctxt (TyConApp tc tys) -- For a normal type constructor or data family application, we just -- recursively flatten the arguments. | not (isSynFamilyTyCon tc) - = do { (xis,cos) <- flattenMany d f fl tys + = do { (xis,cos) <- flattenMany loc f ctxt tys ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) } -- Otherwise, it's a type function application, and we have to @@ -534,23 +517,24 @@ flatten d f fl (TyConApp tc tys) -- between the application and a newly generated flattening skolem variable. | otherwise = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated - do { (xis, cos) <- flattenMany d f fl tys - ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis + do { (xis, cos) <- flattenMany loc f ctxt tys + ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis + (cos_args, cos_rest) = splitAt (tyConArity tc) cos -- The type function might be *over* saturated -- in which case the remaining arguments should -- be dealt with by AppTys fam_ty = mkTyConApp tc xi_args - ; (ret_co, rhs_xi, ct) <- + ; (ret_co, rhs_xi) <- case f of FMSubstOnly -> - return (mkTcReflCo fam_ty, fam_ty, []) + return (mkTcReflCo fam_ty, fam_ty) FMFullFlatten -> - do { flat_cache <- getFlatCache - ; case lookupTM fam_ty flat_cache of - Just ct - | let ctev = cc_ev ct - , ctev `canRewrite` fl + do { mb_ct <- lookupFlatEqn fam_ty + ; case mb_ct of + Just (ctev, rhs_ty) + | let flav = ctEvFlavour ctev + , flav `canRewrite` ctxt -> -- You may think that we can just return (cc_rhs ct) but not so. -- return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) -- The cached constraint resides in the cache so we have to flatten @@ -559,49 +543,23 @@ flatten d f fl (TyConApp tc tys) -- cache as well when we interact an equality with the inert. -- The design choice is: do we keep the flat cache rewritten or not? -- For now I say we don't keep it fully rewritten. - do { traceTcS "flatten/flat-cache hit" $ ppr ct - ; let rhs_xi = cc_rhs ct - ; (flat_rhs_xi,co) <- flatten (cc_depth ct) f ctev rhs_xi + do { traceTcS "flatten/flat-cache hit" $ ppr ctev + ; (rhs_xi,co) <- flatten loc f flav rhs_ty ; let final_co = evTermCoercion (ctEvTerm ctev) `mkTcTransCo` mkTcSymCo co - ; return (final_co, flat_rhs_xi,[]) } + ; return (final_co, rhs_xi) } - _ | isGiven fl -- Given: make new flatten skolem - -> do { traceTcS "flatten/flat-cache miss" $ empty - ; rhs_xi_var <- newFlattenSkolemTy fam_ty - ; let co = mkTcReflCo fam_ty - new_fl = Given { ctev_gloc = ctev_gloc fl - , ctev_pred = mkTcEqPred fam_ty rhs_xi_var - , ctev_evtm = EvCoercion co } - ct = CFunEqCan { cc_ev = new_fl - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } - -- Update the flat cache - ; updFlatCache ct - ; return (co, rhs_xi_var, [ct]) } - | otherwise -- Wanted or Derived: make new unification variable - -> do { traceTcS "flatten/flat-cache miss" $ empty - ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) - ; let pred = mkTcEqPred fam_ty rhs_xi_var - wloc = ctev_wloc fl - ; mw <- newWantedEvVar wloc pred - ; case mw of - Fresh ctev -> - do { let ct = CFunEqCan { cc_ev = ctev - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } - -- Update the flat cache: just an optimisation! - ; updFlatCache ct - ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var, [ct]) } - Cached {} -> panic "flatten TyConApp, var must be fresh!" } + _ -> do { traceTcS "flatten/flat-cache miss" $ ppr fam_ty + ; (ctev, rhs_xi) <- newFlattenSkolem ctxt fam_ty + ; let ct = CFunEqCan { cc_ev = ctev + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_xi + , cc_loc = loc } + ; updWorkListTcS $ extendWorkListFunEq ct + ; return (evTermCoercion (ctEvTerm ctev), rhs_xi) } } -- Emit the flat constraints - ; updWorkListTcS $ appendWorkListEqs ct - ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable -- cf Trac #5655 , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo tc cos_args) $ @@ -609,45 +567,89 @@ flatten d f fl (TyConApp tc tys) ) } -flatten d _f ctxt ty@(ForAllTy {}) +flatten loc _f ctxt ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. = do { let (tvs, rho) = splitForAllTys ty - ; (rho', co) <- flatten d FMSubstOnly ctxt rho + ; (rho', co) <- flatten loc FMSubstOnly ctxt rho + -- Substitute only under a forall + -- See Note [Flattening under a forall] ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } - \end{code} +Note [Flattening under a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under a forall, we + (a) MUST apply the inert subsitution + (b) MUST NOT flatten type family applications +Hence FMSubstOnly. + +For (a) consider c ~ a, a ~ T (forall b. (b, [c]) +If we don't apply the c~a substitution to the second constraint +we won't see the occurs-check error. + +For (b) consider (a ~ forall b. F a b), we don't want to flatten +to (a ~ forall b.fsk, F a b ~ fsk) +because now the 'b' has escaped its scope. We'd have to flatten to + (a ~ forall b. fsk b, forall b. F a b ~ fsk b) +and we have not begun to think about how to make that work! + \begin{code} -flattenTyVar :: SubGoalDepth - -> FlattenMode - -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion) +flattenTyVar, flattenFinalTyVar + :: CtLoc -> FlattenMode + -> CtFlavour -> TcTyVar -> TcS (Xi, TcCoercion) -- "Flattening" a type variable means to apply the substitution to it -flattenTyVar d f ctxt tv - = do { ieqs <- getInertEqs - ; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty - ; case mco of -- Done, but make sure the kind is zonked +-- The substitution is actually the union of the substitution in the TyBinds +-- for the unification variables that have been unified already with the inert +-- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract. +flattenTyVar loc f ctxt tv + | not (isTcTyVar tv) -- Happens when flatten under a (forall a. ty) + = flattenFinalTyVar loc f ctxt tv -- So ty contains referneces to the non-TcTyVar a + | otherwise + = do { mb_ty <- isFilledMetaTyVar_maybe tv + ; case mb_ty of { + Just ty -> flatten loc f ctxt ty ; Nothing -> - do { let knd = tyVarKind tv - ; (new_knd,_kind_co) <- flatten d f ctxt knd - ; let ty = mkTyVarTy (setVarType tv new_knd) - ; return (ty, mkTcReflCo ty) } - -- NB recursive call. - -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants] - -- In fact, because of flavors, it couldn't possibly be idempotent, - -- this is explained in Note [Non-idempotent inert substitution] + + -- Try in ty_binds + do { ty_binds <- getTcSTyBindsMap + ; case lookupVarEnv ty_binds tv of { + Just (_tv,ty) -> flatten loc f ctxt ty ; + -- NB: ty_binds coercions are all ReflCo, + -- so no need to transitively compose co' with another coercion, + -- unlike in 'flatten_from_inerts' + Nothing -> + + -- Try in the inert equalities + do { ieqs <- getInertEqs + ; let mco = tv_eq_subst ieqs tv -- co : v ~ ty + ; case mco of { Just (co,ty) -> - do { (ty_final,co') <- flatten d f ctxt ty - ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } } - where + do { (ty_final,co') <- flatten loc f ctxt ty + ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } ; + -- NB recursive call. + -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants] + -- In fact, because of flavors, it couldn't possibly be idempotent, + -- this is explained in Note [Non-idempotent inert substitution] + + Nothing -> flattenFinalTyVar loc f ctxt tv + } } } } } } + where tv_eq_subst subst tv | Just ct <- lookupVarEnv subst tv , let ctev = cc_ev ct - , ctev `canRewrite` ctxt + , ctEvFlavour ctev `canRewrite` ctxt = Just (evTermCoercion (ctEvTerm ctev), cc_rhs ct) -- NB: even if ct is Derived we are not going to -- touch the actual coercion so we are fine. | otherwise = Nothing + +flattenFinalTyVar loc f ctxt tv + = -- Done, but make sure the kind is zonked + do { let knd = tyVarKind tv + ; (new_knd,_kind_co) <- flatten loc f ctxt knd + ; let ty = mkTyVarTy (setVarType tv new_knd) + ; return (ty, mkTcReflCo ty) } \end{code} Note [Non-idempotent inert substitution] @@ -678,16 +680,6 @@ so that we can make sure that the inert substitution /is/ fully applied. Insufficient (non-recursive) rewriting was the reason for #5668. -\begin{code} - ------------------ -addToWork :: TcS StopOrContinue -> TcS () -addToWork tcs_action = tcs_action >>= stop_or_emit - where stop_or_emit Stop = return () - stop_or_emit (ContinueWith ct) = updWorkListTcS $ - extendWorkListCt ct -\end{code} - %************************************************************************ %* * @@ -696,185 +688,195 @@ addToWork tcs_action = tcs_action >>= stop_or_emit %************************************************************************ \begin{code} -canEqEvVarsCreated :: SubGoalDepth - -> [CtEvidence] -> TcS StopOrContinue -canEqEvVarsCreated _d [] = return Stop -canEqEvVarsCreated d (quad:quads) - = mapM_ (addToWork . do_quad) quads >> do_quad quad - -- Add all but one to the work list - -- and return the first (if any) for futher processing - where do_quad fl = let EqPred ty1 ty2 = classifyPredType $ ctEvPred fl - in canEqNC d fl ty1 ty2 - -- Note the "NC": these are fresh equalities so we must be - -- careful to add their kind constraints +canEvVarsCreated :: CtLoc -> [CtEvidence] -> TcS StopOrContinue +canEvVarsCreated _loc [] = return Stop + -- Add all but one to the work list + -- and return the first (if any) for futher processing +canEvVarsCreated loc (ev : evs) + = do { emitWorkNC loc evs; canEvNC loc ev } + -- Note the "NC": these are fresh goals, not necessarily canonical + +emitWorkNC :: CtLoc -> [CtEvidence] -> TcS () +emitWorkNC loc evs + | null evs = return () + | otherwise = updWorkListTcS (extendWorkListCts (map mk_nc evs)) + where + mk_nc ev = CNonCanonical { cc_ev = ev, cc_loc = loc } ------------------------- -canEqNC, canEq - :: SubGoalDepth - -> CtEvidence - -> Type -> Type -> TcS StopOrContinue +canEqNC, canEq :: CtLoc -> CtEvidence -> Type -> Type -> TcS StopOrContinue -canEqNC d fl ty1 ty2 - = canEq d fl ty1 ty2 +canEqNC loc ev ty1 ty2 + = canEq loc ev ty1 ty2 `andWhenContinue` emitKindConstraint -canEq _d fl ty1 ty2 +canEq _loc ev ty1 ty2 | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a - = if isWanted fl then - setEvBind (ctev_evar fl) (EvCoercion (mkTcReflCo ty1)) >> return Stop + = if isWanted ev then + setEvBind (ctev_evar ev) (EvCoercion (mkTcReflCo ty1)) >> return Stop else return Stop -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ -canEq d fl ty1@(TyVarTy {}) ty2 - = canEqLeaf d fl ty1 ty2 -canEq d fl ty1 ty2@(TyVarTy {}) - = canEqLeaf d fl ty1 ty2 +canEq loc ev ty1@(TyVarTy {}) ty2 + = canEqLeaf loc ev ty1 ty2 +canEq loc ev ty1 ty2@(TyVarTy {}) + = canEqLeaf loc ev ty1 ty2 -- See Note [Naked given applications] -canEq d fl ty1 ty2 - | Just ty1' <- tcView ty1 = canEq d fl ty1' ty2 - | Just ty2' <- tcView ty2 = canEq d fl ty1 ty2' +canEq loc ev ty1 ty2 + | Just ty1' <- tcView ty1 = canEq loc ev ty1' ty2 + | Just ty2' <- tcView ty2 = canEq loc ev ty1 ty2' -canEq d fl ty1@(TyConApp fn tys) ty2 +canEq loc ev ty1@(TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl ty1 ty2 -canEq d fl ty1 ty2@(TyConApp fn tys) + = canEqLeaf loc ev ty1 ty2 +canEq loc ev ty1 ty2@(TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl ty1 ty2 + = canEqLeaf loc ev ty1 ty2 -canEq d fl ty1 ty2 +canEq loc ev ty1 ty2 | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 - = -- Generate equalities for each of the corresponding arguments - if (tc1 /= tc2 || length tys1 /= length tys2) - -- Fail straight away for better error messages - then canEqFailure d fl - else - do { let xcomp xs = EvCoercion (mkTcTyConAppCo tc1 (map evTermCoercion xs)) - xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..] - xev = XEvTerm xcomp xdecomp - ; ctevs <- xCtFlavor fl (zipWith mkTcEqPred tys1 tys2) xev - ; canEqEvVarsCreated d ctevs } + = canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2 --- See Note [Equality between type applications] --- Note [Care with type applications] in TcUnify -canEq d fl ty1 ty2 -- e.g. F a b ~ Maybe c - -- where F has arity 1 - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = canEqAppTy d fl s1 t1 s2 t2 - -canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {}) +canEq loc ev s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2 - , Wanted { ctev_wloc = loc, ctev_evar = orig_ev } <- fl + , CtWanted { ctev_evar = orig_ev } <- ev = do { let (tvs1,body1) = tcSplitForAllTys s1 (tvs2,body2) = tcSplitForAllTys s2 ; if not (equalLength tvs1 tvs2) then - canEqFailure d fl + canEqFailure loc ev s1 s2 else - do { traceTcS "Creating implication for polytype equality" $ ppr fl + do { traceTcS "Creating implication for polytype equality" $ ppr ev ; deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) ; return Stop } } | otherwise = do { traceTcS "Ommitting decomposition of given polytype equality" $ - pprEq s1 s2 + pprEq s1 s2 -- See Note [Do not decompose given polytype equalities] ; return Stop } -canEq d fl _ _ = canEqFailure d fl ------------------------- --- Type application -canEqAppTy :: SubGoalDepth - -> CtEvidence - -> Type -> Type -> Type -> Type - -> TcS StopOrContinue -canEqAppTy d fl s1 t1 s2 t2 - = ASSERT( not (isKind t1) && not (isKind t2) ) - if isGiven fl then - do { traceTcS "canEq (app case)" $ - text "Ommitting decomposition of given equality between: " - <+> ppr (AppTy s1 t1) <+> text "and" <+> ppr (AppTy s2 t2) - -- We cannot decompose given applications - -- because we no longer have 'left' and 'right' +-- The last remaining source of success is an application +-- e.g. F a b ~ Maybe c where F has arity 1 +-- See Note [Equality between type applications] +-- Note [Care with type applications] in TcUnify +canEq loc ev ty1 ty2 + = do { let flav = ctEvFlavour ev + ; (s1, co1) <- flatten loc FMSubstOnly flav ty1 + ; (s2, co2) <- flatten loc FMSubstOnly flav ty2 + ; mb_ct <- rewriteCtFlavor ev (mkTcEqPred s1 s2) (mkHdEqPred s2 co1 co2) + ; case mb_ct of + Nothing -> return Stop + Just new_ev -> last_chance new_ev s1 s2 } + where + last_chance ev ty1 ty2 + | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 + , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 + = canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2 + + | Just (s1,t1) <- tcSplitAppTy_maybe ty1 + , Just (s2,t2) <- tcSplitAppTy_maybe ty2 + = do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y)) + xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen + xevdecomp x = let xco = evTermCoercion x + in [EvCoercion (mkTcLRCo CLeft xco), EvCoercion (mkTcLRCo CRight xco)] + ; ctevs <- xCtFlavor ev [mkTcEqPred s1 s2, mkTcEqPred t1 t2] (XEvTerm xevcomp xevdecomp) + ; canEvVarsCreated loc ctevs } + + | otherwise + = do { emitInsoluble (CNonCanonical { cc_ev = ev, cc_loc = loc }) ; return Stop } - else - do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y)) - xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen - xev = XEvTerm { ev_comp = xevcomp - , ev_decomp = error "canEqAppTy: can't happen" } - ; ctevs <- xCtFlavor fl [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xev - ; canEqEvVarsCreated d ctevs } -canEqFailure :: SubGoalDepth -> CtEvidence -> TcS StopOrContinue -canEqFailure d fl = emitFrozenError fl d >> return Stop +------------------------ +canDecomposableTyConApp :: CtLoc -> CtEvidence + -> TyCon -> [TcType] + -> TyCon -> [TcType] + -> TcS StopOrContinue +canDecomposableTyConApp loc ev tc1 tys1 tc2 tys2 + | tc1 /= tc2 || length tys1 /= length tys2 + -- Fail straight away for better error messages + = canEqFailure loc ev (mkTyConApp tc1 tys1) (mkTyConApp tc2 tys2) + | otherwise + = do { let xcomp xs = EvCoercion (mkTcTyConAppCo tc1 (map evTermCoercion xs)) + xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..] + xev = XEvTerm xcomp xdecomp + ; ctevs <- xCtFlavor ev (zipWith mkTcEqPred tys1 tys2) xev + ; canEvVarsCreated loc ctevs } + +canEqFailure :: CtLoc -> CtEvidence -> TcType -> TcType -> TcS StopOrContinue +-- See Note [Make sure that insolubles are fully rewritten] +canEqFailure loc ev ty1 ty2 + = do { let flav = ctEvFlavour ev + ; (s1, co1) <- flatten loc FMSubstOnly flav ty1 + ; (s2, co2) <- flatten loc FMSubstOnly flav ty2 + ; mb_ct <- rewriteCtFlavor ev (mkTcEqPred s1 s2) + (mkHdEqPred s2 co1 co2) + ; case mb_ct of + Just new_ev -> emitInsoluble (CNonCanonical { cc_ev = new_ev, cc_loc = loc }) + Nothing -> pprPanic "canEqFailure" (ppr ev $$ ppr ty1 $$ ppr ty2) + ; return Stop } ------------------------ emitKindConstraint :: Ct -> TcS StopOrContinue -emitKindConstraint ct +emitKindConstraint ct -- By now ct is canonical = case ct of - CTyEqCan { cc_depth = d - , cc_ev = fl, cc_tyvar = tv + CTyEqCan { cc_loc = loc + , cc_ev = ev, cc_tyvar = tv , cc_rhs = ty } - -> emit_kind_constraint d fl (mkTyVarTy tv) ty + -> emit_kind_constraint loc ev (mkTyVarTy tv) ty - CFunEqCan { cc_depth = d - , cc_ev = fl + CFunEqCan { cc_loc = loc + , cc_ev = ev , cc_fun = fn, cc_tyargs = xis1 , cc_rhs = xi2 } - -> emit_kind_constraint d fl (mkTyConApp fn xis1) xi2 + -> emit_kind_constraint loc ev (mkTyConApp fn xis1) xi2 _ -> continueWith ct where - emit_kind_constraint d fl ty1 ty2 + emit_kind_constraint loc _ev ty1 ty2 | compatKind k1 k2 -- True when ty1,ty2 are themselves kinds, = continueWith ct -- because then k1, k2 are BOX | otherwise = ASSERT( isKind k1 && isKind k2 ) - do { kev <- - do { mw <- newWantedEvVar kind_co_wloc (mkEqPred k1 k2) - ; case mw of - Cached ev_tm -> return ev_tm - Fresh ctev -> do { addToWork (canEq d ctev k1 k2) - ; return (ctEvTerm ctev) } } - - ; let xcomp [x] = mkEvKindCast x (evTermCoercion kev) - xcomp _ = panic "emit_kind_constraint:can't happen" - xdecomp x = [mkEvKindCast x (evTermCoercion kev)] - xev = XEvTerm xcomp xdecomp - - ; ctevs <- xCtFlavor_cache False fl [mkTcEqPred ty1 ty2] xev - -- Important: Do not cache original as Solved since we are supposed to - -- solve /exactly/ the same constraint later! Example: - -- (alpha :: kappa0) - -- (T :: *) - -- Equality is: (alpha ~ T), so we will emitConstraint (kappa0 ~ *) but - -- we don't want to say that (alpha ~ T) is now Solved! - - ; case ctevs of - [] -> return Stop - [new_ctev] -> continueWith (ct { cc_ev = new_ctev }) - _ -> panic "emitKindConstraint" } + do { mw <- newDerived (mkEqPred k1 k2) + ; case mw of + Nothing -> return () + Just kev -> emitWorkNC kind_co_loc [kev] + ; continueWith ct } where k1 = typeKind ty1 k2 = typeKind ty2 - ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2 -- Always create a Wanted kind equality even if -- you are decomposing a given constraint. -- NB: DV finds this reasonable for now. Maybe we have to revisit. - kind_co_wloc = pushErrCtxtSameOrigin ctxt wanted_loc - wanted_loc = case fl of - Wanted { ctev_wloc = wloc } -> wloc - Derived { ctev_wloc = wloc } -> wloc - Given { ctev_gloc = gloc } -> setCtLocOrigin gloc orig - orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + kind_co_loc = setCtLocOrigin loc (KindEqOrigin ty1 ty2 (ctLocOrigin loc)) \end{code} +Note [Make sure that insolubles are fully rewritten] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When an equality fails, we still want to rewrite the equality +all the way down, so that it accurately reflects + (a) the mutable reference substitution in force at start of solving + (b) any ty-binds in force at this point in solving +See Note [Kick out insolubles] in TcInteract. +And if we don't do this there is a bad danger that +TcSimplify.applyTyVarDefaulting will find a variable +that has in fact been substituted. + +Note [Do not decompose given polytype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? +No -- what would the evidence look like. So instead we simply discard +this given evidence. + + Note [Combining insoluble constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As this point we have an insoluble constraint, like Int~Bool. @@ -1017,18 +1019,14 @@ inert set is an idempotent subustitution... \begin{code} data TypeClassifier - = FskCls TcTyVar -- ^ Flatten skolem - | VarCls TcTyVar -- ^ Non-flatten-skolem variable + = VarCls TcTyVar -- ^ Type variable | FunCls TyCon [Type] -- ^ Type function, exactly saturated | OtherCls TcType -- ^ Neither of the above classify :: TcType -> TypeClassifier -classify (TyVarTy tv) - | isTcTyVar tv, - FlatSkol {} <- tcTyVarDetails tv = FskCls tv - | otherwise = VarCls tv +classify (TyVarTy tv) = ASSERT2( isTcTyVar tv, ppr tv ) VarCls tv classify (TyConApp tc tys) | isSynFamilyTyCon tc , tyConArity tc == length tys = FunCls tc tys @@ -1046,38 +1044,23 @@ reOrient :: CtEvidence -> TypeClassifier -> TypeClassifier -> Bool -- We try to say False if possible, to minimise evidence generation -- -- Postcondition: After re-orienting, first arg is not OTherCls -reOrient _fl (OtherCls {}) (FunCls {}) = True -reOrient _fl (OtherCls {}) (FskCls {}) = True -reOrient _fl (OtherCls {}) (VarCls {}) = True -reOrient _fl (OtherCls {}) (OtherCls {}) = panic "reOrient" -- One must be Var/Fun - -reOrient _fl (FunCls {}) (VarCls _tv) = False - -- But consider the following variation: isGiven fl && isMetaTyVar tv +reOrient _ev (OtherCls {}) cls2 = ASSERT( case cls2 of { OtherCls {} -> False; _ -> True } ) + True -- One must be Var/Fun +reOrient _ev (FunCls {}) _ = False -- Fun/Other on rhs + -- But consider the following variation: isGiven ev && isMetaTyVar tv -- See Note [No touchables as FunEq RHS] in TcSMonad -reOrient _fl (FunCls {}) _ = False -- Fun/Other on rhs - -reOrient _fl (VarCls {}) (FunCls {}) = True - -reOrient _fl (VarCls {}) (FskCls {}) = False -reOrient _fl (VarCls {}) (OtherCls {}) = False -reOrient _fl (VarCls tv1) (VarCls tv2) +reOrient _ev (VarCls {}) (FunCls {}) = True +reOrient _ev (VarCls {}) (OtherCls {}) = False +reOrient _ev (VarCls tv1) (VarCls tv2) | isMetaTyVar tv2 && not (isMetaTyVar tv1) = True | otherwise = False -- Just for efficiency, see CTyEqCan invariants -reOrient _fl (FskCls {}) (VarCls tv2) = isMetaTyVar tv2 - -- Just for efficiency, see CTyEqCan invariants - -reOrient _fl (FskCls {}) (FskCls {}) = False -reOrient _fl (FskCls {}) (FunCls {}) = True -reOrient _fl (FskCls {}) (OtherCls {}) = False - ------------------ -canEqLeaf :: SubGoalDepth -- Depth - -> CtEvidence +canEqLeaf :: CtLoc -> CtEvidence -> Type -> Type -> TcS StopOrContinue -- Canonicalizing "leaf" equality constraints which cannot be @@ -1085,155 +1068,117 @@ canEqLeaf :: SubGoalDepth -- Depth -- saturated type function application). -- Preconditions: --- * one of the two arguments is variable or family applications +-- * one of the two arguments is variable +-- or an exactly-saturated family application -- * the two types are not equal (looking through synonyms) -canEqLeaf d fl s1 s2 +canEqLeaf loc ev s1 s2 | cls1 `re_orient` cls2 - = do { traceTcS "canEqLeaf (reorienting)" $ ppr fl <+> dcolon <+> pprEq s1 s2 + = do { traceTcS "canEqLeaf (reorienting)" $ ppr ev <+> dcolon <+> pprEq s1 s2 ; let xcomp [x] = EvCoercion (mkTcSymCo (evTermCoercion x)) xcomp _ = panic "canEqLeaf: can't happen" xdecomp x = [EvCoercion (mkTcSymCo (evTermCoercion x))] xev = XEvTerm xcomp xdecomp - ; ctevs <- xCtFlavor fl [mkTcEqPred s2 s1] xev + ; ctevs <- xCtFlavor ev [mkTcEqPred s2 s1] xev ; case ctevs of [] -> return Stop - [ctev] -> canEqLeafOriented d ctev s2 s1 + [ctev] -> canEqLeafOriented loc ctev cls2 s1 _ -> panic "canEqLeaf" } | otherwise = do { traceTcS "canEqLeaf" $ ppr (mkTcEqPred s1 s2) - ; canEqLeafOriented d fl s1 s2 } + ; canEqLeafOriented loc ev cls1 s2 } where - re_orient = reOrient fl + re_orient = reOrient ev cls1 = classify s1 cls2 = classify s2 -canEqLeafOriented :: SubGoalDepth -- Depth - -> CtEvidence - -> TcType -> TcType -> TcS StopOrContinue +canEqLeafOriented :: CtLoc -> CtEvidence + -> TypeClassifier -> TcType -> TcS StopOrContinue -- By now s1 will either be a variable or a type family application -canEqLeafOriented d fl s1 s2 - = can_eq_split_lhs d fl s1 s2 - where can_eq_split_lhs d fl s1 s2 - | Just (fn,tys1) <- splitTyConApp_maybe s1 - = canEqLeafFunEqLeftRec d fl (fn,tys1) s2 - | Just tv <- getTyVar_maybe s1 - = canEqLeafTyVarLeftRec d fl tv s2 - | otherwise - = pprPanic "canEqLeafOriented" $ - text "Non-variable or non-family equality LHS" <+> ppr (ctEvPred fl) - -canEqLeafFunEqLeftRec :: SubGoalDepth - -> CtEvidence - -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue -canEqLeafFunEqLeftRec d fl (fn,tys1) ty2 -- fl :: F tys1 ~ ty2 - = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2 - ; (xis1,cos1) <- - {-# SCC "flattenMany" #-} - flattenMany d FMFullFlatten fl tys1 -- Flatten type function arguments - -- cos1 :: xis1 ~ tys1 +canEqLeafOriented loc ev (FunCls fn tys1) s2 = canEqLeafFunEq loc ev fn tys1 s2 +canEqLeafOriented loc ev (VarCls tv) s2 = canEqLeafTyVarEq loc ev tv s2 +canEqLeafOriented _ ev (OtherCls {}) _ = pprPanic "canEqLeafOriented" (ppr (ctEvPred ev)) + +canEqLeafFunEq :: CtLoc -> CtEvidence + -> TyCon -> [TcType] -> TcType -> TcS StopOrContinue +canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 + = do { traceTcS "canEqLeafFunEq" $ pprEq (mkTyConApp fn tys1) ty2 + ; let flav = ctEvFlavour ev + + -- Flatten type function arguments + -- cos1 :: xis1 ~ tys1 + -- co2 :: xi2 ~ ty2 + ; (xis1,cos1) <- flattenMany loc FMFullFlatten flav tys1 + ; (xi2, co2) <- flatten loc FMFullFlatten flav ty2 + -- Fancy higher-dimensional coercion between equalities! + -- SPJ asks why? Why not just co : F xis1 ~ F tys1? ; let fam_head = mkTyConApp fn xis1 - -- Fancy higher-dimensional coercion between equalities! - ; let co = mkTcTyConAppCo eqTyCon $ - [mkTcReflCo (defaultKind $ typeKind ty2), mkTcTyConAppCo fn cos1, mkTcReflCo ty2] - -- Why defaultKind? Same reason as the comment on TcType/mkTcEqPred. I trully hate this (DV) - -- co :: (F xis1 ~ ty2) ~ (F tys1 ~ ty2) + xco = mkHdEqPred ty2 (mkTcTyConAppCo fn cos1) co2 + -- xco :: (F xis1 ~ xi2) ~ (F tys1 ~ ty2) - ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head ty2) co - ; case mb of - Nothing -> return Stop - Just new_fl -> canEqLeafFunEqLeft d new_fl (fn,xis1) ty2 } - - -canEqLeafFunEqLeft :: SubGoalDepth -- Depth - -> CtEvidence - -> (TyCon,[Xi]) - -> TcType -> TcS StopOrContinue --- Precondition: No more flattening is needed for the LHS -canEqLeafFunEqLeft d fl (fn,xis1) s2 - = {-# SCC "canEqLeafFunEqLeft" #-} - do { traceTcS "canEqLeafFunEqLeft" $ pprEq (mkTyConApp fn xis1) s2 - ; (xi2,co2) <- - {-# SCC "flatten" #-} - flatten d FMFullFlatten fl s2 -- co2 :: xi2 ~ s2 - - ; let fam_head = mkTyConApp fn xis1 - -- Fancy coercion between equalities! But it should just work! - ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) - , mkTcReflCo fam_head, co2 ] - -- Why defaultKind? Same reason as the comment at TcType/mkTcEqPred - -- co :: (F xis1 ~ xi2) ~ (F xis1 ~ s2) - -- new pred old pred - ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head xi2) co - ; case mb of - Nothing -> return Stop - Just new_fl -> continueWith $ - CFunEqCan { cc_ev = new_fl, cc_depth = d - , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } - - -canEqLeafTyVarLeftRec :: SubGoalDepth - -> CtEvidence - -> TcTyVar -> TcType -> TcS StopOrContinue -canEqLeafTyVarLeftRec d fl tv s2 -- fl :: tv ~ s2 - = do { traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2 - ; (xi1,co1) <- flattenTyVar d FMFullFlatten fl tv -- co1 :: xi1 ~ tv - ; let is_still_var = isJust (getTyVar_maybe xi1) - - ; traceTcS "canEqLeafTyVarLeftRec2" $ empty - - ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) - , co1, mkTcReflCo s2] - -- co :: (xi1 ~ s2) ~ (tv ~ s2) - ; mb <- rewriteCtFlavor_cache (if is_still_var then False else True) fl (mkTcEqPred xi1 s2) co - -- See Note [Caching loops] - - ; traceTcS "canEqLeafTyVarLeftRec3" $ empty - - ; case mb of - Nothing -> return Stop - Just new_fl -> - case getTyVar_maybe xi1 of - Just tv' -> canEqLeafTyVarLeft d new_fl tv' s2 - Nothing -> canEq d new_fl xi1 s2 } - -canEqLeafTyVarLeft :: SubGoalDepth -- Depth - -> CtEvidence + ; mb <- rewriteCtFlavor ev (mkTcEqPred fam_head xi2) xco + ; case mb of { + Nothing -> return Stop ; + Just new_ev -> continueWith new_ct +-- | isTcReflCo xco -> continueWith new_ct +-- | otherwise -> do { updWorkListTcS (extendWorkListFunEq new_ct); return Stop } + where + new_ct = CFunEqCan { cc_ev = new_ev, cc_loc = loc + , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } } + + +canEqLeafTyVarEq :: CtLoc -> CtEvidence -> TcTyVar -> TcType -> TcS StopOrContinue --- Precondition LHS is fully rewritten from inerts (but not RHS) -canEqLeafTyVarLeft d fl tv s2 -- eqv : tv ~ s2 - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "canEqLeafTyVarLeft" (pprEq tv_ty s2) - ; (xi2, co2) <- flatten d FMFullFlatten fl s2 -- Flatten RHS co:xi2 ~ s2 - - ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv =" <+> ppr tv - , text "s2 =" <+> ppr s2 - , text "xi2 =" <+> ppr xi2])) - - -- Reflexivity exposed through flattening - ; if tv_ty `eqType` xi2 then - when (isWanted fl) (setEvBind (ctev_evar fl) (EvCoercion co2)) >> - return Stop - else do - -- Not reflexivity but maybe an occurs error - { let occ_check_result = occurCheckExpand tv xi2 - xi2' = fromMaybe xi2 occ_check_result - - not_occ_err = isJust occ_check_result - -- Delicate: don't want to cache as solved a constraint with occurs error! - co = mkTcTyConAppCo eqTyCon $ - [mkTcReflCo (defaultKind $ typeKind s2), mkTcReflCo tv_ty, co2] - ; mb <- rewriteCtFlavor_cache not_occ_err fl (mkTcEqPred tv_ty xi2') co - ; case mb of - Just new_fl -> if not_occ_err then - continueWith $ - CTyEqCan { cc_ev = new_fl, cc_depth = d - , cc_tyvar = tv, cc_rhs = xi2' } - else - canEqFailure d new_fl - Nothing -> return Stop - } } +canEqLeafTyVarEq loc ev tv s2 -- ev :: tv ~ s2 + = do { traceTcS "canEqLeafTyVarEq" $ pprEq (mkTyVarTy tv) s2 + ; let flav = ctEvFlavour ev + ; (xi1,co1) <- flattenTyVar loc FMFullFlatten flav tv -- co1 :: xi1 ~ tv + ; (xi2,co2) <- flatten loc FMFullFlatten flav s2 -- co2 :: xi2 ~ s2 + ; let co = mkHdEqPred s2 co1 co2 + -- co :: (xi1 ~ xi2) ~ (tv ~ s2) + + ; traceTcS "canEqLeafTyVarEq2" $ empty + ; case (getTyVar_maybe xi1, getTyVar_maybe xi2) of { + (Nothing, _) -> -- Rewriting the LHS did not yield a type variable + -- so go around again to canEq + do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co + ; case mb of + Nothing -> return Stop + Just new_ev -> canEq loc new_ev xi1 xi2 } ; + + (Just tv1', Just tv2') | tv1' == tv2' + -> do { when (isWanted ev) $ + setEvBind (ctev_evar ev) (mkEvCast (EvCoercion (mkTcReflCo xi1)) co) + ; return Stop } ; + + (Just tv1', _) -> + + -- LHS rewrote to a type variable, RHS to something else + case occurCheckExpand tv1' xi2 of + Nothing -> -- Occurs check error + do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co + ; case mb of + Nothing -> return Stop + Just new_ev -> canEqFailure loc new_ev xi1 xi2 } + + Just xi2' -> -- No occurs check, so we can continue; but make sure + -- that the new goal has enough type synonyms expanded by + -- by the occurCheckExpand + do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2') co + ; case mb of + Nothing -> return Stop + Just new_ev -> continueWith $ + CTyEqCan { cc_ev = new_ev, cc_loc = loc + , cc_tyvar = tv1', cc_rhs = xi2' } } + } } + +mkHdEqPred :: Type -> TcCoercion -> TcCoercion -> TcCoercion +-- Make a higher-dimensional equality +-- co1 :: s1~t1, co2 :: s2~t2 +-- Then (mkHdEqPred t2 co1 co2) :: (s1~s2) ~ (t1~t2) +mkHdEqPred t2 co1 co2 = mkTcTyConAppCo eqTyCon [mkTcReflCo (defaultKind (typeKind t2)), co1, co2] + -- Why defaultKind? Same reason as the comment on TcType/mkTcEqPred. I truly hate this (DV) \end{code} Note [Occurs check expansion] diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 209215e8ec..7df818efd2 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -197,10 +197,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) DefMeth dm_name -> tc_dm dm_name GenDefMeth dm_name -> tc_dm dm_name where - sel_name = idName sel_id - prags = prag_fn sel_name - dm_bind = findMethodBind sel_name binds_in - `orElse` pprPanic "tcDefMeth" (ppr sel_id) + sel_name = idName sel_id + prags = prag_fn sel_name + (dm_bind,bndr_loc) = findMethodBind sel_name binds_in + `orElse` pprPanic "tcDefMeth" (ppr sel_id) -- Eg. class C a where -- op :: forall b. Eq b => a -> [b] -> a @@ -211,11 +211,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) tc_dm dm_name = do { dm_id <- tcLookupId dm_name - ; local_dm_name <- newLocalName sel_name + ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name) -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here - ; dm_id_w_inline <- addInlinePrags dm_id prags ; spec_prags <- tcSpecPrags dm_id prags @@ -242,17 +241,13 @@ tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] tcInstanceMethodBody skol_info tyvars dfun_ev_vars meth_id local_meth_sig specs (L loc bind) - = do { -- Typecheck the binding, first extending the envt - -- so that when tcInstSig looks up the local_meth_id to find - -- its signature, we'll find it in the environment - let local_meth_id = sig_id local_meth_sig + = do { let local_meth_id = sig_id local_meth_sig lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ - tcExtendIdEnv [local_meth_id] $ - tcPolyCheck local_meth_sig no_prag_fn NonRecursive [lm_bind] + tcPolyCheck NotTopLevel NonRecursive no_prag_fn local_meth_sig [lm_bind] ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } @@ -308,13 +303,15 @@ lookupHsSig = lookupNameEnv --------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings - -> Maybe (LHsBind Name) -- The binding + -> Maybe (LHsBind Name, SrcSpan) + -- Returns the binding, and the binding + -- site of the method binder findMethodBind sel_name binds = foldlBag mplus Nothing (mapBag f binds) where - f bind@(L _ (FunBind { fun_id = L _ op_name })) + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) | op_name == sel_name - = Just bind + = Just (bind, bndr_loc) f _other = Nothing \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index fa4fc40ddc..3249f54bc1 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -25,6 +25,8 @@ module TcEnv( tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, + tcExtendIdBndrs, + tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, tcLookupLcl_maybe, @@ -375,27 +377,36 @@ tcExtendLetEnv closed ids thing_inside ; tc_extend_local_env [ (idName id, ATcId { tct_id = id , tct_closed = closed , tct_level = thLevel stage }) - | id <- ids] - thing_inside } + | id <- ids] $ + tcExtendIdBndrs [TcIdBndr id closed | id <- ids] thing_inside } tcExtendIdEnv :: [TcId] -> TcM a -> TcM a tcExtendIdEnv ids thing_inside - = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside + = tcExtendIdEnv2 [(idName id, id) | id <- ids] $ + tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids] + thing_inside tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a tcExtendIdEnv1 name id thing_inside - = tcExtendIdEnv2 [(name,id)] thing_inside + = tcExtendIdEnv2 [(name,id)] $ + tcExtendIdBndrs [TcIdBndr id NotTopLevel] + thing_inside tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +-- Do *not* extend the tcl_bndrs stack +-- The tct_closed flag really doesn't matter -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) tcExtendIdEnv2 names_w_ids thing_inside = do { stage <- getStage ; tc_extend_local_env [ (name, ATcId { tct_id = id , tct_closed = NotTopLevel , tct_level = thLevel stage }) - | (name,id) <- names_w_ids] + | (name,id) <- names_w_ids] $ thing_inside } +tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a +tcExtendIdBndrs bndrs = updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) + tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction -- Note especially that we bind them at diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index bbf5ae6181..4f95abc933 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -8,16 +8,16 @@ -- for details module TcErrors( - reportUnsolved, ErrEnv, + reportUnsolved, reportAllUnsolved, warnDefaulting, - flattenForAllErrorTcS, solverDepthErrorTcS ) where #include "HsVersions.h" import TcCanonical( occurCheckExpand ) +import TcRnTypes import TcRnMonad import TcMType import TcType @@ -30,18 +30,18 @@ import InstEnv import TyCon import TcEvidence import Name -import NameEnv -import Id ( idType ) +import Id import Var import VarSet import VarEnv import Bag import Maybes import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) -import SrcLoc ( noSrcSpan ) +import BasicTypes import Util import FastString import Outputable +import SrcLoc import DynFlags import Data.List ( partition, mapAccumL ) \end{code} @@ -56,45 +56,88 @@ ToDo: for these error messages, should we note the location as coming from the insts, or just whatever seems to be around in the monad just now? -\begin{code} --- We keep an environment mapping coercion ids to the error messages they --- trigger; this is handy for -fwarn--type-errors -type ErrEnv = VarEnv [ErrMsg] +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in TcUnify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co -reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind) -reportUnsolved runtimeCoercionErrors wanted +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in TcErrors. TcErrors.reportTidyWanteds does not print the errors +and does not fail if -fwarn-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. + +\begin{code} +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer <- doptM Opt_DeferTypeErrors + ; report_unsolved (Just binds_var) defer wanted + ; getTcEvBinds binds_var } + +reportAllUnsolved :: WantedConstraints -> TcM () +-- Report all unsolved goals, even if -fdefer-type-errors is on +-- See Note [Deferring coercion errors to runtime] +reportAllUnsolved wanted = report_unsolved Nothing False wanted + +report_unsolved :: Maybe EvBindsVar -- cec_binds + -> Bool -- cec_defer + -> WantedConstraints -> TcM () +-- Important precondition: +-- WantedConstraints are fully zonked and unflattened, that is, +-- zonkWC has already been applied to these constraints. +report_unsolved mb_binds_var defer wanted | isEmptyWC wanted - = return emptyBag + = return () | otherwise - = do { -- Zonk to un-flatten any flatten-skols - wanted <- zonkWC wanted + = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted) ; env0 <- tcInitTidyEnv - ; defer <- if runtimeCoercionErrors - then do { ev <- newTcEvBinds - ; return (Just ev) } - else return Nothing - - ; errs_so_far <- ifErrsM (return True) (return False) + + -- If we are deferring we are going to need /all/ evidence around, + -- including the evidence produced by unflattening (zonkWC) +-- ; errs_so_far <- ifErrsM (return True) (return False) ; let tidy_env = tidyFreeTyVars env0 free_tvs free_tvs = tyVarsOfWC wanted err_ctxt = CEC { cec_encl = [] - , cec_insol = errs_so_far || insolubleWC wanted - -- Don't report ambiguity errors if - -- there are any other solid errors - -- to report - , cec_extra = empty , cec_tidy = tidy_env - , cec_defer = defer } - - ; traceTc "reportUnsolved:" (vcat [ pprTvBndrs (varSetElems free_tvs) - , ppr wanted ]) + , cec_defer = defer + , cec_suppress = insolubleWC wanted + -- Suppress all but insolubles if there are + -- any insoulubles, or earlier errors + , cec_binds = mb_binds_var } - ; reportWanteds err_ctxt wanted + ; traceTc "reportUnsolved (after unflattening):" $ + vcat [ pprTvBndrs (varSetElems free_tvs) + , ppr wanted ] - ; case defer of - Nothing -> return emptyBag - Just ev -> getTcEvBinds ev } + ; reportWanteds err_ctxt wanted } -------------------------------------------- -- Internal functions @@ -105,106 +148,85 @@ data ReportErrCtxt -- (innermost first) -- ic_skols and givens are tidied, rest are not , cec_tidy :: TidyEnv - , cec_extra :: SDoc -- Add this to each error message - , cec_insol :: Bool -- True <=> do not report errors involving - -- ambiguous errors - , cec_defer :: Maybe EvBindsVar - -- Nothinng <=> errors are, well, errors - -- Just ev <=> make errors into warnings, and emit evidence - -- bindings into 'ev' for unsolved constraints + , cec_binds :: Maybe EvBindsVar + -- Nothinng <=> Report all errors, including holes; no bindings + -- Just ev <=> make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'ev' for unsolved constraints + + , cec_defer :: Bool -- True <=> -fdefer-type-errors + -- Irrelevant if cec_binds = Nothing + , cec_suppress :: Bool -- True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings } reportImplic :: ReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given , ic_wanted = wanted, ic_binds = evb - , ic_insol = insoluble, ic_loc = loc }) - | BracketSkol <- ctLocOrigin loc - , not insoluble -- For Template Haskell brackets report only - = return () -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints + , ic_insol = ic_insoluble, ic_info = info }) + | BracketSkol <- info + , not ic_insoluble -- For Template Haskell brackets report only + = return () -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints | otherwise = reportWanteds ctxt' wanted where (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs + (env2, info') = tidySkolemInfo env1 info implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_loc = tidyGivenLoc env1 loc } - ctxt' = ctxt { cec_tidy = env1 + , ic_given = map (tidyEvVar env2) given + , ic_info = info' } + ctxt' = ctxt { cec_tidy = env2 , cec_encl = implic' : cec_encl ctxt - , cec_defer = case cec_defer ctxt of + , cec_binds = case cec_binds ctxt of Nothing -> Nothing Just {} -> Just evb } reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) - = reportTidyWanteds ctxt tidy_insols tidy_flats implics + = do { reportFlats (ctxt { cec_suppress = False }) (mapBag (tidyCt env) insols) + ; reportFlats ctxt (mapBag (tidyCt env) flats) + ; mapBagM_ (reportImplic ctxt) implics } where env = cec_tidy ctxt - tidy_insols = mapBag (tidyCt env) insols - tidy_flats = mapBag (tidyCt env) (keepWanted flats) +-- tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats) + -- All the Derived ones have been filtered out alrady + -- by the constraint solver. This is ok; we don't want + -- to report unsolved Derived goals as error -- See Note [Do not report derived but soluble errors] -reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM () -reportTidyWanteds ctxt insols flats implics - | Just ev_binds_var <- cec_defer ctxt - = do { -- Defer errors to runtime - -- See Note [Deferring coercion errors to runtime] in TcSimplify - mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) - (flats `unionBags` insols) - ; mapBagM_ (reportImplic ctxt) implics } - - | otherwise - = do { reportInsolsAndFlats ctxt insols flats - ; mapBagM_ (reportImplic ctxt) implics } - - -deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) - -> Ct -> TcM () -deferToRuntime ev_binds_var ctxt mk_err_msg ct - | Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct - = do { err <- setCtLoc loc $ - mk_err_msg ctxt ct - ; dflags <- getDynFlags - ; let err_msg = pprLocErrMsg err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" - - -- Create the binding - ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) - - -- And emit a warning - ; reportWarning (makeIntoWarning err) } - - | otherwise -- Do not set any evidence for Given/Derived - = return () - -reportInsolsAndFlats :: ReportErrCtxt -> Cts -> Cts -> TcM () -reportInsolsAndFlats ctxt insols flats - = tryReporters +reportFlats :: ReportErrCtxt -> Cts -> TcM () +reportFlats ctxt flats -- Here 'flats' includes insolble goals + = traceTc "reportFlats" (ppr flats) >> + tryReporters [ -- First deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons) -- or Int ~ t a (AppTy on one side) - ("Utterly wrong", utterly_wrong, groupErrs (mkEqErr ctxt)) + ("Utterly wrong", utterly_wrong, mkGroupReporter mkEqErr) + , ("Holes", is_hole, mkUniReporter mkHoleError) -- Report equalities of form (a~ty). They are usually -- skolem-equalities, and they cause confusing knock-on -- effects in other errors; see test T4093b. - , ("Skolem equalities", skolem_eq, mkReporter (mkEqErr1 ctxt)) - - , ("Unambiguous", unambiguous, reportFlatErrs ctxt) ] - (reportAmbigErrs ctxt) - (bagToList (insols `unionBags` flats)) + , ("Skolem equalities", skolem_eq, mkUniReporter mkEqErr1) ] +-- , ("Unambiguous", unambiguous, reportFlatErrs) ] + reportFlatErrs + ctxt (bagToList flats) where - utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool - + utterly_wrong, skolem_eq :: Ct -> PredTree -> Bool utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 utterly_wrong _ _ = False + is_hole ct _ = isHoleCt ct + skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 skolem_eq _ _ = False +{- + unambiguous :: Ct -> PredTree -> Bool unambiguous ct pred | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct))) = True @@ -212,6 +234,7 @@ reportInsolsAndFlats ctxt insols flats = case pred of EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2) _ -> False +-} --------------- isRigid, isRigidOrSkol :: Type -> Bool @@ -231,63 +254,18 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of _ -> Nothing ----------------- -type Reporter = [Ct] -> TcM () - -mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM () --- Reports errors one at a time -mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_ev ct) $ - mk_err ct; - ; reportError err }) - -tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter --- Use the first reporter in the list whose predicate says True -tryReporters reporters deflt cts - = do { traceTc "tryReporters {" (ppr cts) - ; go reporters cts - ; traceTc "tryReporters }" empty } - where - go [] cts = deflt cts - go ((str, pred, reporter) : rs) cts - | null yeses = traceTc "tryReporters: no" (text str) >> - go rs cts - | otherwise = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> - reporter yeses - where - yeses = filter keep_me cts - keep_me ct = pred ct (classifyPredType (ctPred ct)) - ------------------ -mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg --- Context is already set -mkFlatErr ctxt ct -- The constraint is always wanted - | isIPPred (ctPred ct) = mkIPErr ctxt [ct] - | otherwise - = case classifyPredType (ctPred ct) of - ClassPred {} -> mkDictErr ctxt [ct] - IrredPred {} -> mkIrredErr ctxt [ct] - EqPred {} -> mkEqErr1 ctxt ct - TuplePred {} -> panic "mkFlat" - -reportAmbigErrs :: ReportErrCtxt -> Reporter -reportAmbigErrs ctxt cts - | cec_insol ctxt = return () - | otherwise = reportFlatErrs ctxt cts - -- Only report ambiguity if no other errors (at all) happened - -- See Note [Avoiding spurious errors] in TcSimplify - -reportFlatErrs :: ReportErrCtxt -> Reporter +reportFlatErrs :: Reporter -- Called once for non-ambigs, once for ambigs -- Report equality errors, and others only if we've done all -- the equalities. The equality errors are more basic, and -- can lead to knock on type-class errors -reportFlatErrs ctxt cts +reportFlatErrs = tryReporters - [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ] - (\cts -> do { let (dicts, ips, irreds) = go cts [] [] [] - ; groupErrs (mkIPErr ctxt) ips - ; groupErrs (mkIrredErr ctxt) irreds - ; groupErrs (mkDictErr ctxt) dicts }) - cts + [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ] + (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] [] + ; mkGroupReporter mkIPErr ctxt ips + ; mkGroupReporter mkIrredErr ctxt irreds + ; mkGroupReporter mkDictErr ctxt dicts }) where is_equality _ (EqPred {}) = True is_equality _ _ = False @@ -295,53 +273,111 @@ reportFlatErrs ctxt cts go [] dicts ips irreds = (dicts, ips, irreds) go (ct:cts) dicts ips irreds - | isIPPred (ctPred ct) = go cts dicts (ct:ips) irreds + | isIPPred (ctPred ct) + = go cts dicts (ct:ips) irreds | otherwise = case classifyPredType (ctPred ct) of ClassPred {} -> go cts (ct:dicts) ips irreds IrredPred {} -> go cts dicts ips (ct:irreds) - _ -> panic "mkFlat" + _ -> panic "reportFlatErrs" -- TuplePreds should have been expanded away by the constraint -- simplifier, so they shouldn't show up at this point -- And EqPreds are dealt with by the is_equality test -------------------------------------------- --- Support code +-- Reporters -------------------------------------------- -groupErrs :: ([Ct] -> TcM ErrMsg) -- Deal with one group - -> [Ct] -- Unsolved wanteds - -> TcM () +type Reporter = ReportErrCtxt -> [Ct] -> TcM () + +mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter +-- Reports errors one at a time +mkUniReporter mk_err ctxt + = mapM_ $ \ct -> + do { err <- mk_err ctxt ct + ; maybeReportError ctxt err ct + ; maybeAddDeferredBinding ctxt err ct } + +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) + -- Make error message for a group + -> Reporter -- Deal with lots of constraints -- Group together insts from same location -- We want to report them together in error messages -groupErrs _ [] +mkGroupReporter _ _ [] = return () -groupErrs mk_err (ct1 : rest) - = do { err <- setCtFlavorLoc flavor $ mk_err cts - ; reportError err - ; groupErrs mk_err others } +mkGroupReporter mk_err ctxt (ct1 : rest) + = do { err <- mk_err ctxt cts + ; maybeReportError ctxt err ct1 + ; mapM_ (maybeAddDeferredBinding ctxt err) (ct1:rest) + -- Add deferred bindings for all + ; mkGroupReporter mk_err ctxt others } where - flavor = cc_ev ct1 + loc = cc_loc ct1 cts = ct1 : friends (friends, others) = partition is_friend rest - is_friend friend = cc_ev friend `same_group` flavor + is_friend friend = cc_loc friend `same_loc` loc - same_group :: CtEvidence -> CtEvidence -> Bool - same_group (Given {ctev_gloc = l1}) (Given {ctev_gloc = l2}) = same_loc l1 l2 - same_group (Wanted {ctev_wloc = l1}) (Wanted {ctev_wloc = l2}) = same_loc l1 l2 - same_group (Derived {ctev_wloc = l1}) (Derived {ctev_wloc = l2}) = same_loc l1 l2 - same_group _ _ = False + same_loc :: CtLoc -> CtLoc -> Bool + same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2 + +maybeReportError :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +-- Report the error and/or make a deferred binding for it +maybeReportError ctxt err ct + | cec_suppress ctxt + = return () + | isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors + = reportWarning (makeIntoWarning err) + | otherwise + = reportError err + +maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () +-- See Note [Deferring coercion errors to runtime] +maybeAddDeferredBinding ctxt err ct + | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct + -- Only add deferred bindings for Wanted constraints + , isHoleCt ct || cec_defer ctxt -- And it's a hole or we have -fdefer-type-errors + , Just ev_binds_var <- cec_binds ctxt -- We hvae somewhere to put the bindings + = do { dflags <- getDynFlags + ; let err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc dflags $ + err_msg $$ text "(deferred type error)" - same_loc :: CtLoc o -> CtLoc o -> Bool - same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2 + -- Create the binding + ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) } + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] + -> Reporter -> Reporter +-- Use the first reporter in the list whose predicate says True +tryReporters reporters deflt ctxt cts + = do { traceTc "tryReporters {" (ppr cts) + ; go ctxt reporters cts + ; traceTc "tryReporters }" empty } + where + go ctxt [] cts = deflt ctxt cts + go ctxt ((str, pred, reporter) : rs) cts + | null yeses = do { traceTc "tryReporters: no" (text str) + ; go ctxt rs cts } + | otherwise = do { traceTc "tryReporters: yes" (text str <+> ppr yeses) + ; reporter ctxt yeses :: TcM () + ; go (ctxt { cec_suppress = True }) rs nos } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have + -- -fdefer-type-errors + -- But suppress their error messages + where + (yeses, nos) = partition keep_me cts + keep_me ct = pred ct (classifyPredType (ctPred ct)) -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc addArising orig msg = hang msg 2 (pprArising orig) -pprWithArising :: [Ct] -> (WantedLoc, SDoc) +pprWithArising :: [Ct] -> (CtLoc, SDoc) -- Print something like -- (Eq a) arising from a use of x at y -- (Show a) arising from a use of p at q @@ -351,26 +387,30 @@ pprWithArising [] = panic "pprWithArising" pprWithArising (ct:cts) | null cts - = (loc, addArising (ctLocOrigin (ctWantedLoc ct)) + = (loc, addArising (ctLocOrigin loc) (pprTheta [ctPred ct])) | otherwise = (loc, vcat (map ppr_one (ct:cts))) where - loc = ctWantedLoc ct + loc = cc_loc ct ppr_one ct = hang (parens (pprType (ctPred ct))) - 2 (pprArisingAt (ctWantedLoc ct)) + 2 (pprArisingAt (cc_loc ct)) -mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg -mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) +mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg +mkErrorMsg ctxt ct msg + = do { let tcl_env = ctLocEnv (cc_loc ct) + ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) + ; mkLongErrAt (tcl_loc tcl_env) msg err_info } -type UserGiven = ([EvVar], GivenLoc) +type UserGiven = ([EvVar], SkolemInfo, SrcSpan) getUserGivens :: ReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) = reverse $ - [ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt - , not (null givens) ] + [ (givens, info, tcl_loc env) + | Implic {ic_given = givens, ic_env = env, ic_info = info } <- ctxt + , not (null givens) ] \end{code} Note [Do not report derived but soluble errors] @@ -432,29 +472,44 @@ solve it. \begin{code} mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIrredErr ctxt cts - = mkErrorReport ctxt msg + = do { (ctxt, binds_msg) <- relevantBindings ctxt ct1 + ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) } where (ct1:_) = cts - orig = ctLocOrigin (ctWantedLoc ct1) + orig = ctLocOrigin (cc_loc ct1) givens = getUserGivens ctxt msg = couldNotDeduce givens (map ctPred cts, orig) -\end{code} +---------------- +mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg +mkHoleError ctxt ct@(CHoleCan {}) + = do { let tyvars = varSetElems (tyVarsOfCt ct) + tyvars_msg = map loc_msg tyvars + msg = (text "Found hole" <+> quotes (text "_") + <+> text "with type") <+> pprType (ctEvPred (cc_ev ct)) + $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg) + ; (ctxt, binds_doc) <- relevantBindings ctxt ct + ; mkErrorMsg ctxt ct (msg $$ binds_doc) } + where + loc_msg tv + = case tcTyVarDetails tv of + SkolemTv {} -> quotes (ppr tv) <+> skol_msg + MetaTv {} -> quotes (ppr tv) <+> text "is a free type variable" + det -> pprTcTyVarDetails det + where + skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) -%************************************************************************ -%* * - Implicit parameter errors -%* * -%************************************************************************ +mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) -\begin{code} +---------------- mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkIPErr ctxt cts - = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts - ; mkErrorReport ctxt' (msg $$ ambig_err) } + = do { (ctxt, _, ambig_err) <- mkAmbigMsg ctxt cts + ; (ctxt, bind_msg) <- relevantBindings ctxt ct1 + ; mkErrorMsg ctxt ct1 (msg $$ ambig_err $$ bind_msg) } where (ct1:_) = cts - orig = ctLocOrigin (ctWantedLoc ct1) + orig = ctLocOrigin (cc_loc ct1) preds = map ctPred cts givens = getUserGivens ctxt msg | null givens @@ -482,111 +537,110 @@ mkEqErr _ [] = panic "mkEqErr" mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -- Wanted constraints only! mkEqErr1 ctxt ct - = if isGiven flav then - let ctx2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg flav } - in mkEqErr_help ctx2 ct False ty1 ty2 - else - do { let orig = ctLocOrigin (getWantedLoc flav) - ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig - ; mk_err ctxt1 orig' } + = do { (ctxt, binds_msg) <- relevantBindings ctxt ct + ; (ctxt, orig) <- zonkTidyOrigin ctxt orig + ; let (is_oriented, wanted_msg) = mk_wanted_extra orig + ; if isGiven ev then + mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct Nothing ty1 ty2 + else + mkEqErr_help ctxt (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 } where - - flav = cc_ev ct - - inaccessible_msg (Given { ctev_gloc = loc }) - = hang (ptext (sLit "Inaccessible code in")) - 2 (ppr (ctLocOrigin loc)) - -- If a Solved then we should not report inaccessible code - inaccessible_msg _ = empty - + ev = cc_ev ct + orig = ctLocOrigin (cc_loc ct) (ty1, ty2) = getEqPredTys (ctPred ct) + inaccessible_msg orig = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr orig) + -- If the types in the error message are the same as the types -- we are unifying, don't add the extra expected/actual message - mk_err ctxt1 (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) - | act `pickyEqType` ty1 - , exp `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty2 ty1 - | exp `pickyEqType` ty1 - , act `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty1 ty2 - | otherwise = mkEqErr_help ctxt2 ct False ty1 ty2 + mk_wanted_extra orig@(TypeEqOrigin {}) + = mkExpectedActualMsg ty1 ty2 orig + + + mk_wanted_extra (KindEqOrigin cty1 cty2 sub_o) + = (Nothing, msg1 $$ msg2) where - ctxt2 = ctxt1 { cec_extra = msg $$ cec_extra ctxt1 } - msg = mkExpectedActualMsg exp act - mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2 + msg1 = hang (ptext (sLit "When matching types")) + 2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ]) + msg2 = case sub_o of + TypeEqOrigin {} -> snd (mkExpectedActualMsg cty1 cty2 sub_o) + _ -> empty + + mk_wanted_extra _ = (Nothing, empty) mkEqErr_help, reportEqErr - :: ReportErrCtxt + :: ReportErrCtxt -> SDoc -> Ct - -> Bool -- True <=> Types are correct way round; - -- report "expected ty1, actual ty2" - -- False <=> Just report a mismatch without orientation - -- The ReportErrCtxt has expected/actual + -> Maybe SwapFlag -- Nothing <=> not sure -> TcType -> TcType -> TcM ErrMsg -mkEqErr_help ctxt ct oriented ty1 ty2 - | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1 - | otherwise = reportEqErr ctxt ct oriented ty1 ty2 +mkEqErr_help ctxt extra ct oriented ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt extra ct oriented tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt extra ct oriented tv2 ty1 + | otherwise = reportEqErr ctxt extra ct oriented ty1 ty2 -reportEqErr ctxt ct oriented ty1 ty2 - = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2 - ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) } +reportEqErr ctxt extra1 ct oriented ty1 ty2 + = do { (ctxt', extra2) <- mkEqInfoMsg ctxt ct ty1 ty2 + ; mkErrorMsg ctxt' ct (vcat [ misMatchOrCND ctxt' ct oriented ty1 ty2 + , extra2, extra1]) } -mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg +mkTyVarEqErr :: ReportErrCtxt -> SDoc -> Ct -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt ct oriented tv1 ty2 - | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would - -- be oriented the other way round; see TcCanonical.reOrient +mkTyVarEqErr ctxt extra ct oriented tv1 ty2 + -- Occurs check + | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; see TcCanonical.reOrient || isSigTyVar tv1 && not (isTyVarTy ty2) - = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) - (misMatchOrCND ctxt ct oriented ty1 ty2) + = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2 + , extraTyVarInfo ctxt ty1 ty2 + , extra ]) -- So tv is a meta tyvar, and presumably it is -- an *untouchable* meta tyvar, else it'd have been unified | not (k2 `tcIsSubKind` k1) -- Kind error - = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) + = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra) - -- Occurs check | isNothing (occurCheckExpand tv1 ty2) = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 - (sep [ppr ty1, char '=', ppr ty2]) - in mkErrorReport ctxt occCheckMsg + (sep [ppr ty1, char '~', ppr ty2]) + in mkErrorMsg ctxt ct (occCheckMsg $$ extra) -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic) - implic_loc = ic_loc implic + , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic + , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols , not (null esc_skols) - = setCtLoc implic_loc $ -- Override the error message location from the - -- place the equality arose to the implication site - do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1) - ; let msg = misMatchMsg oriented ty1 ty2 + = do { let msg = misMatchMsg oriented ty1 ty2 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols <+> pprQuotedList esc_skols , ptext (sLit "would escape") <+> if isSingleton esc_skols then ptext (sLit "its scope") else ptext (sLit "their scope") ] - extra1 = vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then ptext (sLit "This (rigid, skolem) type variable is") - else ptext (sLit "These (rigid, skolem) type variables are")) - <+> ptext (sLit "bound by") - , nest 2 $ ppr (ctLocOrigin implic_loc) ] ] - ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } + tv_extra = vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then ptext (sLit "This (rigid, skolem) type variable is") + else ptext (sLit "These (rigid, skolem) type variables are")) + <+> ptext (sLit "bound by") + , nest 2 $ ppr skol_info + , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ] + ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) } -- Nastiest case: attempt to unify an untouchable variable | (implic:_) <- cec_encl ctxt -- Get the innermost context - , let implic_loc = ic_loc implic - given = ic_given implic - = setCtLoc (ic_loc implic) $ - do { let msg = misMatchMsg oriented ty1 ty2 - extra = quotes (ppr tv1) - <+> sep [ ptext (sLit "is untouchable") - , ptext (sLit "inside the constraints") <+> pprEvVarTheta given - , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] - ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } + , Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic + = do { let msg = misMatchMsg oriented ty1 ty2 + untch_extra + = nest 2 $ + sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable") + , nest 2 $ ptext (sLit "inside the constraints") <+> pprEvVarTheta given + , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info + , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] + tv_extra = extraTyVarInfo ctxt ty1 ty2 + ; mkErrorMsg ctxt ct (vcat [msg, untch_extra, tv_extra, extra]) } | otherwise - = reportEqErr ctxt ct oriented (mkTyVarTy tv1) ty2 + = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2 -- This *can* happen (Trac #6123, and test T2627b) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, becuase F is a type function. @@ -595,7 +649,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2 k2 = typeKind ty2 ty1 = mkTyVarTy tv1 -mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM ReportErrCtxt +mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM (ReportErrCtxt, SDoc) -- Report (a) ambiguity if either side is a type function application -- e.g. F a0 ~ Int -- (b) warning about injectivity if both sides are the same @@ -605,7 +659,7 @@ mkEqInfoMsg ctxt ct ty1 ty2 = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2 then mkAmbigMsg ctxt [ct] else return (ctxt, False, empty) - ; return (ctxt' { cec_extra = tyfun_msg $$ ambig_msg $$ cec_extra ctxt' }) } + ; return (ctxt', tyfun_msg $$ ambig_msg) } where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2 @@ -616,12 +670,23 @@ mkEqInfoMsg ctxt ct ty1 ty2 <+> ptext (sLit "is a type function, and may not be injective") | otherwise = empty -misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc +isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool +-- See Note [Reporting occurs-check errors] +isUserSkolem ctxt tv + = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt) + where + is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info }) + = tv `elem` sks && is_user_skol_info skol_info + + is_user_skol_info (InferSkol {}) = False + is_user_skol_info _ = True + +misMatchOrCND :: ReportErrCtxt -> Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc -- If oriented then ty1 is expected, ty2 is actual misMatchOrCND ctxt ct oriented ty1 ty2 | null givens || (isRigid ty1 && isRigid ty2) || - isGiven (cc_ev ct) + isGivenCt ct -- If the equality is unconditionally insoluble -- or there is no context, don't report the context = misMatchMsg oriented ty1 ty2 @@ -629,29 +694,30 @@ misMatchOrCND ctxt ct oriented ty1 ty2 = couldNotDeduce givens ([mkEqPred ty1 ty2], orig) where givens = getUserGivens ctxt - orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + orig = TypeEqOrigin ty1 ty2 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds) , vcat (pp_givens givens)] -pp_givens :: [([EvVar], GivenLoc)] -> [SDoc] +pp_givens :: [UserGiven] -> [SDoc] pp_givens givens = case givens of [] -> [] (g:gs) -> ppr_given (ptext (sLit "from the context")) g : map (ppr_given (ptext (sLit "or from"))) gs - where ppr_given herald (gs,loc) + where + ppr_given herald (gs, skol_info, loc) = hang (herald <+> pprEvVarTheta gs) - 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) - , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) + 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info + , ptext (sLit "at") <+> ppr loc]) -addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt +extraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> SDoc -- Add on extra info about the types themselves -- NB: The types themselves are already tidied -addExtraTyVarInfo ctxt ty1 ty2 - = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } +extraTyVarInfo ctxt ty1 ty2 + = nest 2 (extra1 $$ extra2) where extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1 extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2 @@ -663,21 +729,13 @@ tyVarExtraInfoMsg implics ty , isTcTyVar tv, isSkolemTyVar tv , let pp_tv = quotes (ppr tv) = case tcTyVarDetails tv of - SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv) + SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv) FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") MetaTv {} -> empty | otherwise -- Normal case = empty - where - ppr_skol given_loc tv_loc - = case skol_info of - UnkSkol -> ptext (sLit "is an unknown type variable") - _ -> sep [ ptext (sLit "is a rigid type variable bound by"), - sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] - where - skol_info = ctLocOrigin given_loc kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy kindErrorMsg ty1 ty2 @@ -689,10 +747,12 @@ kindErrorMsg ty1 ty2 k2 = typeKind ty2 -------------------- -misMatchMsg :: Bool -> TcType -> TcType -> SDoc -- Types are already tidy +misMatchMsg :: Maybe SwapFlag -> TcType -> TcType -> SDoc -- Types are already tidy -- If oriented then ty1 is expected, ty2 is actual -misMatchMsg oriented ty1 ty2 - | oriented +misMatchMsg oriented ty1 ty2 + | Just IsSwapped <- oriented + = misMatchMsg (Just NotSwapped) ty2 ty1 + | Just NotSwapped <- oriented = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1) , nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ] | otherwise @@ -702,12 +762,36 @@ misMatchMsg oriented ty1 ty2 what | isKind ty1 = ptext (sLit "kind") | otherwise = ptext (sLit "type") -mkExpectedActualMsg :: Type -> Type -> SDoc -mkExpectedActualMsg exp_ty act_ty - = vcat [ text "Expected type:" <+> ppr exp_ty - , text " Actual type:" <+> ppr act_ty ] +mkExpectedActualMsg :: Type -> Type -> CtOrigin -> (Maybe SwapFlag, SDoc) +mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp }) + | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (Just IsSwapped, empty) + | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (Just NotSwapped, empty) + | otherwise = (Nothing, msg) + where + msg = vcat [ text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act ] + +mkExpectedActualMsg _ _ _ = panic "mkExprectedAcutalMsg" \end{code} +Note [Reporting occurs-check errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied +type signature, then the best thing is to report that we can't unify +a with [a], because a is a skolem variable. That avoids the confusing +"occur-check" error message. + +But nowadays when inferring the type of a function with no type signature, +even if there are errors inside, we still generalise its signature and +carry on. For example + f x = x:x +Here we will infer somethiing like + f :: forall a. a -> [a] +with a suspended error of (a ~ [a]). So 'a' is now a skolem, but not +one bound by the programmer! Here we really should report an occurs check. + +So isUserSkolem distinguishes the two. + Note [Non-injective type functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's very confusing to get a message like @@ -739,8 +823,9 @@ mkDictErr ctxt cts -- have the same source-location origin, to try avoid a cascade -- of error from one location ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorReport ctxt err } + ; mkErrorMsg ctxt ct1 err } where + ct1:_ = cts no_givens = null (getUserGivens ctxt) is_no_inst (ct, (matches, unifiers, _)) = no_givens @@ -755,13 +840,15 @@ mkDictErr ctxt cts (clas, tys) = getClassPredTys (ctPred ct) mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM (ReportErrCtxt, SDoc) + -> TcM (ReportErrCtxt, SDoc) -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) | null matches -- No matches but perhaps several unifiers - = do { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct] - ; return (ctxt', cannot_resolve_msg is_ambig ambig_msg) } + = do { (ctxt, is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct] + ; (ctxt, binds_msg) <- relevantBindings ctxt ct + ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg) + ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) } | not safe_haskell -- Some matches => overlap errors = return (ctxt, overlap_msg) @@ -769,22 +856,20 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) | otherwise = return (ctxt, safe_haskell_msg) where - orig = ctLocOrigin (ctWantedLoc ct) + orig = ctLocOrigin (cc_loc ct) pred = ctPred ct (clas, tys) = getClassPredTys pred ispecs = [ispec | (ispec, _) <- matches] givens = getUserGivens ctxt all_tyvars = all isTyVarTy tys - cannot_resolve_msg has_ambig_tvs ambig_msg + cannot_resolve_msg has_ambig_tvs binds_msg ambig_msg = vcat [ addArising orig (no_inst_herald <+> pprParendType pred) , vcat (pp_givens givens) - , if has_ambig_tvs && (not (null unifiers) || not (null givens)) - then ambig_msg $$ potential_msg + , if (has_ambig_tvs && not (null unifiers && null givens)) + then vcat [ ambig_msg, binds_msg, potential_msg ] else empty - , show_fixes (inst_decl_fixes - ++ add_to_ctxt_fixes has_ambig_tvs - ++ drv_fixes) ] + , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ] potential_msg | null unifiers = empty @@ -808,19 +893,14 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) ppr_skol skol_info = ppr skol_info -- Do not suggest adding constraints to an *inferred* type signature! - get_good_orig ic = case ctLocOrigin (ic_loc ic) of - SigSkol (InfSigCtxt {}) _ -> Nothing - origin -> Just origin + get_good_orig ic = case ic_info ic of + SigSkol (InfSigCtxt {}) _ -> Nothing + origin -> Just origin no_inst_herald | null givens && null matches = ptext (sLit "No instance for") | otherwise = ptext (sLit "Could not deduce") - inst_decl_fixes - | all_tyvars = [] - | otherwise = [ sep [ ptext (sLit "add an instance declaration for") - , pprParendType pred] ] - drv_fixes = case orig of DerivOrigin -> [drv_fix] _ -> [] @@ -869,12 +949,12 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) givens = getUserGivens ctxt matching_givens = mapCatMaybes matchable givens - matchable (evvars,gloc) + matchable (evvars,skol_info,loc) = case ev_vars_matching of [] -> Nothing _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc) - , ptext (sLit "at") <+> ppr (ctLocSpan gloc)]) + 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info + , ptext (sLit "at") <+> ppr loc]) where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) ev_var_matches ty = case getClassPredTys_maybe ty of Just (clas', tys') @@ -972,9 +1052,17 @@ mkAmbigMsg ctxt cts = return (ctxt, False, empty) | otherwise = do { dflags <- getDynFlags - ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set - ; return (ctxt', True, mk_msg dflags gbl_docs) } + + ; prs <- mapSndM zonkTcType $ + [ (id, idType id) | TcIdBndr id top_lvl <- ct1_bndrs + , isTopLevel top_lvl ] + ; let ambig_ids = [id | (id, zonked_ty) <- prs + , tyVarsOfType zonked_ty `intersectsVarSet` ambig_tv_set] + ; return (ctxt, True, mk_msg dflags ambig_ids) } where + ct1:_ = cts + ct1_bndrs = tcl_bndrs (ctLocEnv (cc_loc ct1)) + ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) emptyVarSet cts ambig_tvs = varSetElems ambig_tv_set @@ -982,7 +1070,7 @@ mkAmbigMsg ctxt cts is_or_are | isSingleton ambig_tvs = text "is" | otherwise = text "are" - mk_msg dflags docs + mk_msg dflags ambig_ids | any isRuntimeUnkSkol ambig_tvs -- See Note [Runtime skolems] = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs <+> pprQuotedList ambig_tvs @@ -991,17 +1079,17 @@ mkAmbigMsg ctxt cts = vcat [ text "The type variable" <> plural ambig_tvs <+> pprQuotedList ambig_tvs <+> is_or_are <+> text "ambiguous" - , mk_extra_msg dflags docs ] + , mk_extra_msg dflags ambig_ids ] - mk_extra_msg dflags docs - | null docs + mk_extra_msg dflags ambig_ids + | null ambig_ids = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)") -- This happens in things like -- f x = show (read "foo") -- where monomorphism doesn't play any role | otherwise - = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:") - , nest 2 (vcat docs) + = vcat [ hang (ptext (sLit "Possible cause: the monomorphism restriction applied to:")) + 2 (pprWithCommas (quotes . ppr) ambig_ids) , ptext (sLit "Probable fix:") <+> vcat [ ptext (sLit "give these definition(s) an explicit type signature") , if xopt Opt_MonomorphismRestriction dflags @@ -1010,89 +1098,80 @@ mkAmbigMsg ctxt cts -- if it is not already set! ] -getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc + +pprSkol :: SkolemInfo -> SrcLoc -> SDoc +pprSkol UnkSkol _ + = ptext (sLit "is an unknown type variable") +pprSkol skol_info tv_loc + = sep [ ptext (sLit "is a rigid type variable bound by"), + sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] + +getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo -- Get the skolem info for a type variable -- from the implication constraint that binds it getSkolemInfo [] tv - = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) - CtLoc UnkSkol noSrcSpan [] + = pprPanic "No skolem info:" (ppr tv) getSkolemInfo (implic:implics) tv - | tv `elem` ic_skols implic = ic_loc implic + | tv `elem` ic_skols implic = ic_info implic | otherwise = getSkolemInfo implics tv ----------------------- --- findGlobals looks at the value environment and finds values whose +-- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be -- careful to zonk the Id's type first, so it has to be in the monad. -- We must be careful to pass it a zonked type variable, too. -mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc -mkEnvSigMsg what env_sigs - | null env_sigs = empty - | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what - , nest 2 (vcat env_sigs) ] - -findGlobals :: ReportErrCtxt - -> TcTyVarSet - -> TcM (ReportErrCtxt, [SDoc]) - -findGlobals ctxt tvs - = do { lcl_ty_env <- case cec_encl ctxt of - [] -> getLclTypeEnv - (i:_) -> return (ic_env i) - ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) } +relevantBindings :: ReportErrCtxt -> Ct + -> TcM (ReportErrCtxt, SDoc) +relevantBindings ctxt ct + = do { (tidy_env', docs) <- go (cec_tidy ctxt) (6, emptyVarSet) + (reverse (tcl_bndrs lcl_env)) + -- The 'reverse' makes us work from outside in + -- Blargh; maybe have a flag for this "6" + + ; traceTc "relevantBindings" (ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env]) + ; let doc = hang (ptext (sLit "Relevant bindings include")) + 2 (vcat docs) + ; if null docs + then return (ctxt, empty) + else do { traceTc "rb" doc + ; return (ctxt { cec_tidy = tidy_env' }, doc) } } where - go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc) - go tidy_env acc (thing : things) - = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing - ; case maybe_doc of - Just d -> go tidy_env1 (d:acc) things - Nothing -> go tidy_env1 acc things } - - ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty + lcl_env = ctLocEnv (cc_loc ct) + ct_tvs = tyVarsOfCt ct + + go :: TidyEnv -> (Int, TcTyVarSet) + -> [TcIdBinder] -> TcM (TidyEnv, [SDoc]) + go tidy_env (_,_) [] + = return (tidy_env, []) + go tidy_env (n_left,tvs_seen) (TcIdBndr id _ : tc_bndrs) + | n_left <= 0, ct_tvs `subVarSet` tvs_seen + = -- We have run out of n_left, and we + -- already have bindings mentioning all of ct_tvs + go tidy_env (n_left,tvs_seen) tc_bndrs + | otherwise + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) + ; let id_tvs = tyVarsOfType tidy_ty + doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (ptext (sLit "bound at") + <+> ppr (getSrcLoc id)))] + ; if id_tvs `intersectsVarSet` ct_tvs + && (n_left > 0 || not (id_tvs `subVarSet` tvs_seen)) + -- Either we n_left is big enough, + -- or this binding mentions a new type variable + then do { (env', docs) <- go tidy_env' (n_left - 1, tvs_seen `unionVarSet` id_tvs) tc_bndrs + ; return (env', doc:docs) } + else go tidy_env (n_left, tvs_seen) tc_bndrs } ----------------------- -find_thing :: TidyEnv -> (TcType -> Bool) - -> TcTyThing -> TcM (TidyEnv, Maybe SDoc) -find_thing tidy_env ignore_it (ATcId { tct_id = id }) - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) - ; if ignore_it tidy_ty then - return (tidy_env, Nothing) - else do - { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (ptext (sLit "bound at") <+> - ppr (getSrcLoc id)))] - ; return (tidy_env', Just msg) } } - -find_thing tidy_env ignore_it (ATyVar name tv) - = do { ty <- zonkTcTyVar tv - ; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty - ; if ignore_it tidy_ty then - return (tidy_env, Nothing) - else do - { let -- The name tv is scoped, so we don't need to tidy it - msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff - , nest 2 bound_at] - - eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty - , getOccName name == getOccName tv' = empty - | otherwise = equals <+> ppr tidy_ty - -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name) - - ; return (tidy_env1, Just msg) } } - -find_thing _ _ thing = pprPanic "find_thing" (ppr thing) - -warnDefaulting :: [Ct] -> Type -> TcM () +warnDefaulting :: Cts -> Type -> TcM () warnDefaulting wanteds default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv - ; let wanted_bag = listToBag wanteds - tidy_env = tidyFreeTyVars env0 $ - tyVarsOfCts wanted_bag - tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag + ; let tidy_env = tidyFreeTyVars env0 $ + tyVarsOfCts wanteds + tidy_wanteds = mapBag (tidyCt tidy_env) wanteds (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds) warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) @@ -1114,58 +1193,19 @@ are created by in RtClosureInspect.zonkRTTIType. %************************************************************************ \begin{code} -solverDepthErrorTcS :: Int -> [Ct] -> TcM a -solverDepthErrorTcS depth stack - | null stack -- Shouldn't happen unless you say -fcontext-stack=0 - = failWith msg - | otherwise - = setCtFlavorLoc (cc_ev top_item) $ - do { zstack <- mapM zonkCt stack - ; env0 <- tcInitTidyEnv - ; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack - tidy_env = tidyFreeTyVars env0 zstack_tvs - tidy_cts = map (tidyCt tidy_env) zstack - ; failWithTcM (tidy_env, hang msg 2 (vcat (map (ppr . ctPred) tidy_cts))) } - where - top_item = head stack - msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth - , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] - -{- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ... - = setCtFlavorLoc (cc_ev top_item) $ - do { ev_vars <- mapM (zonkEvVar . cc_id) stack +solverDepthErrorTcS :: Ct -> TcM a +solverDepthErrorTcS ct + = setCtLoc loc $ + do { ct <- zonkCt ct ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) - tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars - ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) } + ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfCt ct) + tidy_ct = tidyCt tidy_env ct + ; failWithTcM (tidy_env, hang msg 2 (ppr tidy_ct)) } where - top_item = head stack + loc = cc_loc ct + depth = ctLocDepth loc msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] --} - - -flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a -flattenForAllErrorTcS fl ty - = setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; let (env1, ty') = tidyOpenType env0 ty - msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:") - , ppr ty' ] - ; failWithTcM (env1, msg) } -\end{code} - -%************************************************************************ -%* * - Setting the context -%* * -%************************************************************************ - -\begin{code} -setCtFlavorLoc :: CtEvidence -> TcM a -> TcM a -setCtFlavorLoc (Wanted { ctev_wloc = loc }) thing = setCtLoc loc thing -setCtFlavorLoc (Derived { ctev_wloc = loc }) thing = setCtLoc loc thing -setCtFlavorLoc (Given { ctev_gloc = loc }) thing = setCtLoc loc thing \end{code} %************************************************************************ @@ -1180,10 +1220,19 @@ zonkTidyTcType env ty = do { ty' <- zonkTcType ty ; return (tidyOpenType env ty') } zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin) -zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) - = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act +zonkTidyOrigin ctxt (GivenOrigin skol_info) + = do { skol_info1 <- zonkSkolemInfo skol_info + ; let (env1, skol_info2) = tidySkolemInfo (cec_tidy ctxt) skol_info1 + ; return (ctxt { cec_tidy = env1 }, GivenOrigin skol_info2) } +zonkTidyOrigin ctxt (TypeEqOrigin { uo_actual = act, uo_expected = exp }) + = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act ; (env2, exp') <- zonkTidyTcType env1 exp ; return ( ctxt { cec_tidy = env2 } - , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } + , TypeEqOrigin { uo_actual = act', uo_expected = exp' }) } +zonkTidyOrigin ctxt (KindEqOrigin ty1 ty2 orig) + = do { (env1, ty1') <- zonkTidyTcType (cec_tidy ctxt) ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; (ctxt2, orig') <- zonkTidyOrigin (ctxt { cec_tidy = env2 }) orig + ; return (ctxt2, KindEqOrigin ty1' ty2' orig') } zonkTidyOrigin ctxt orig = return (ctxt, orig) \end{code} diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 321809f91d..b160c3282c 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -16,14 +16,14 @@ module TcEvidence ( EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, - EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast, + EvTerm(..), mkEvCast, evVarsOfTerm, EvLit(..), evTermCoercion, -- TcCoercion - TcCoercion(..), + TcCoercion(..), LeftOrRight(..), pickLR, mkTcReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo, mkTcAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcInstCos, + mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcInstCos, tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo, isTcReflCo, isTcReflCo_maybe, getTcCoVar_maybe, liftTcCoSubstWith @@ -32,7 +32,7 @@ module TcEvidence ( #include "HsVersions.h" import Var - +import Coercion( LeftOrRight(..), pickLR ) import PprCore () -- Instance OutputableBndr TyVar import TypeRep -- Knows type representation import TcType @@ -102,6 +102,7 @@ data TcCoercion | TcSymCo TcCoercion | TcTransCo TcCoercion TcCoercion | TcNthCo Int TcCoercion + | TcLRCo LeftOrRight TcCoercion | TcCastCo TcCoercion TcCoercion -- co1 |> co2 | TcLetCo TcEvBinds TcCoercion deriving (Data.Data, Data.Typeable) @@ -167,6 +168,10 @@ mkTcNthCo :: Int -> TcCoercion -> TcCoercion mkTcNthCo n (TcRefl ty) = TcRefl (tyConAppArgN n ty) mkTcNthCo n co = TcNthCo n co +mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion +mkTcLRCo lr (TcRefl ty) = TcRefl (pickLR lr (tcSplitAppTy ty)) +mkTcLRCo lr co = TcLRCo lr co + mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys @@ -211,6 +216,7 @@ tcCoercionKind co = go co go (TcSymCo co) = swap (go co) go (TcTransCo co1 co2) = Pair (pFst (go co1)) (pSnd (go co2)) go (TcNthCo d co) = tyConAppArgN d <$> go co + go (TcLRCo lr co) = (pickLR lr . tcSplitAppTy) <$> go co -- c.f. Coercion.coercionKind go_inst (TcInstCo co ty) tys = go_inst co (ty:tys) @@ -239,6 +245,7 @@ coVarsOfTcCo tc_co go (TcSymCo co) = go co go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2 go (TcNthCo _ co) = go co + go (TcLRCo _ co) = go co go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs `minusVarSet` get_bndrs bs go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call @@ -306,6 +313,7 @@ ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $ <+> ppr_co FunPrec co2 ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co] ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co] +ppr_co p (TcLRCo lr co) = pprPrefixApp p (ppr lr) [pprParendTcCo co] ppr_fun_co :: Prec -> TcCoercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) @@ -475,8 +483,6 @@ data EvTerm -- dictionaries, even though the former have no -- selector Id. We count up from _0_ - | EvKindCast EvTerm TcCoercion -- See Note [EvKindCast] - | EvLit EvLit -- Dictionary for class "SingI" for type lits. -- Note [EvLit] @@ -502,29 +508,17 @@ We do quite often need to get a TcCoercion from an EvTerm; see INVARIANT: The evidence for any constraint with type (t1~t2) is a coercion evidence term. Consider for example - [G] g :: F Int a + [G] d :: F Int a If we have ax7 a :: F Int a ~ (a ~ Bool) then we do NOT generate the constraint - [G} (g |> ax7 a) :: a ~ Bool -because that does not satisfy the invariant. Instead we make a binding + [G} (d |> ax7 a) :: a ~ Bool +because that does not satisfy the invariant (d is not a coercion variable). +Instead we make a binding g1 :: a~Bool = g |> ax7 a and the constraint [G] g1 :: a~Bool -See Trac [7238] - -Note [EvKindCast] -~~~~~~~~~~~~~~~~~ -EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2) -but the kinds of s1 and s2 (k1 and k2 respectively) don't match but -are rather equal by a coercion. You may think that this coercion will -always turn out to be ReflCo, so why is this needed? Because sometimes -we will want to defer kind errors until the runtime and in these cases -that coercion will be an 'error' term, which we want to evaluate rather -than silently forget about! - -The relevant (and only) place where such a coercion is produced in -the simplifier is in TcCanonical.emitKindConstraint. +See Trac [7238] and Note [Bind new Givens immediately] in TcSMonad Note [EvBinds/EvTerm] ~~~~~~~~~~~~~~~~~~~~~ @@ -587,11 +581,6 @@ mkEvCast ev lco | isTcReflCo lco = ev | otherwise = EvCast ev lco -mkEvKindCast :: EvTerm -> TcCoercion -> EvTerm -mkEvKindCast ev lco - | isTcReflCo lco = ev - | otherwise = EvKindCast ev lco - emptyTcEvBinds :: TcEvBinds emptyTcEvBinds = EvBinds emptyBag @@ -617,7 +606,6 @@ evVarsOfTerm (EvSuperClass v _) = evVarsOfTerm v evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co evVarsOfTerm (EvTupleMk evs) = evVarsOfTerms evs evVarsOfTerm (EvDelayedError _ _) = emptyVarSet -evVarsOfTerm (EvKindCast v co) = coVarsOfTcCo co `unionVarSet` evVarsOfTerm v evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerms :: [EvTerm] -> VarSet @@ -675,7 +663,6 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvId v) = ppr v ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co - ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 51b5eb3fa7..d2ebc74ed6 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -231,6 +231,15 @@ tcExpr (HsType ty) _ -- so it's not enabled yet. -- Can't eliminate it altogether from the parser, because the -- same parser parses *patterns*. +tcExpr HsHole res_ty + = do { ty <- newFlexiTyVarTy liftedTypeKind + ; traceTc "tcExpr.HsHole" (ppr ty) + ; ev <- mkSysLocalM (mkFastString "_") ty + ; loc <- getCtLoc HoleOrigin + ; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc } + ; traceTc "tcExpr.HsHole emitting" (ppr can) + ; emitInsoluble can + ; tcWrapResult (HsVar ev) ty res_ty } \end{code} @@ -304,20 +313,28 @@ tcExpr (OpApp arg1 op fix arg2) res_ty ; let doc = ptext (sLit "The first argument of ($) takes") ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty - -- arg2_ty maybe polymorphic; that's the point + -- arg1_ty = arg2_ty -> op_res_ty + -- And arg2_ty maybe polymorphic; that's the point -- Make sure that the argument and result types have kind '*' -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 - ; _ <- unifyKind (typeKind arg2_ty) liftedTypeKind - ; _ <- unifyKind (typeKind res_ty) liftedTypeKind + -- ($) :: forall ab. (a->b) -> a -> b + ; a_ty <- newFlexiTyVarTy liftedTypeKind + ; b_ty <- newFlexiTyVarTy liftedTypeKind ; arg2' <- tcArg op (arg2, arg2_ty, 2) - ; co_res <- unifyType op_res_ty res_ty - ; op_id <- tcLookupId op_name - ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id)) - ; return $ mkHsWrapCo co_res $ - OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' } + ; co_res <- unifyType b_ty res_ty -- b ~ res + ; co_a <- unifyType arg2_ty a_ty -- arg2 ~ a + ; co_b <- unifyType op_res_ty b_ty -- op_res ~ b + ; op_id <- tcLookupId op_name + + ; let op' = L loc (HsWrap (mkWpTyApps [a_ty, b_ty]) (HsVar op_id)) + ; return $ mkHsWrapCo (co_res) $ + OpApp (mkLHsWrapCo (mkTcFunCo co_a co_b) $ + mkLHsWrapCo co_arg1 arg1') + op' fix + (mkLHsWrapCo co_a arg2') } | otherwise = do { traceTc "Non Application rule" (ppr op) diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 84907fb306..ab784eca67 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -713,6 +713,9 @@ zonkExpr env (HsWrap co_fn expr) zonkExpr env1 expr `thenM` \ new_expr -> return (HsWrap new_co_fn new_expr) +zonkExpr _ HsHole + = return HsHole + zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) @@ -1114,11 +1117,6 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm ; co' <- zonkTcLCoToLCo env co ; return (mkEvCast tm' co') } - -zonkEvTerm env (EvKindCast v co) = do { v' <- zonkEvTerm env v - ; co' <- zonkTcLCoToLCo env co - ; return (mkEvKindCast v' co') } - zonkEvTerm env (EvTupleSel tm n) = do { tm' <- zonkEvTerm env tm ; return (EvTupleSel tm' n) } zonkEvTerm env (EvTupleMk tms) = do { tms' <- mapM (zonkEvTerm env) tms @@ -1158,29 +1156,17 @@ zonkEvBinds env binds zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind zonkEvBind env (EvBind var term) - = case term of - -- Special-case fast paths for small coercions - -- NB: could be optimized further! (e.g. SymCo cv) - -- See Note [Optimized Evidence Binding Zonking] - EvCoercion co - | Just ty <- isTcReflCo_maybe co - -> do { zty <- zonkTcTypeToType env ty - ; let var' = setVarType var (mkEqPred zty zty) - -- Here we save the task of zonking var's type, - -- because we know just what it is! - ; return (EvBind var' (EvCoercion (mkTcReflCo zty))) } - - | Just cv <- getTcCoVar_maybe co - -> do { let cv' = zonkIdOcc env cv -- Just lazily look up - term' = EvCoercion (TcCoVarCo cv') - var' = setVarType var (varType cv') - ; return (EvBind var' term') } - - -- The default path - _ -> do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var - ; term' <- zonkEvTerm env term - ; return (EvBind var' term') - } + = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var + + -- Optimise the common case of Refl coercions + -- 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 (ty1, ty2) | ty1 `eqType` ty2 + -> return (EvBind var' (EvCoercion (mkTcReflCo ty1))) + _other -> do { term' <- zonkEvTerm env term + ; return (EvBind var' term') } } \end{code} %************************************************************************ @@ -1235,8 +1221,8 @@ The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and we have a type or a kind variable; for kind variables we just return AnyK (and not the ill-kinded Any BOX). -Note [Optimized Evidence Binding Zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Optimise coercion zonkind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When optimising evidence binds we may come across situations where a coercion looks like cv = ReflCo ty @@ -1244,10 +1230,11 @@ or cv1 = cv2 where the type 'ty' is big. In such cases it is a waste of time to zonk both * The variable on the LHS * The coercion on the RHS -Rather, we can zonk the coercion, take its type and use that for -the variable. For big coercions this might be a lose, though, so we -just have a fast case for a couple of special cases. +Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just +use Refl on the right, ignoring the actual coercion on the RHS. +This can have a very big effect, because the constraint solver sometimes does go +to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030) \begin{code} zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType @@ -1257,16 +1244,17 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv SkolemTv {} -> lookup_in_env RuntimeUnk {} -> lookup_in_env FlatSkol ty -> zonkTcTypeToType env ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> do { kind <- {-# SCC "zonkKind1" #-} - zonkTcTypeToType env (tyVarKind tv) - ; zonk_unbound_tyvar (setTyVarKind tv kind) } - Indirect ty -> do { zty <- zonkTcTypeToType env ty - -- Small optimisation: shortern-out indirect steps - -- so that the old type may be more easily collected. - ; writeMutVar ref (Indirect zty) - ; return zty } } + MetaTv { mtv_ref = ref } + -> do { cts <- readMutVar ref + ; case cts of + Flexi -> do { kind <- {-# SCC "zonkKind1" #-} + zonkTcTypeToType env (tyVarKind tv) + ; zonk_unbound_tyvar (setTyVarKind tv kind) } + Indirect ty -> do { zty <- zonkTcTypeToType env ty + -- Small optimisation: shortern-out indirect steps + -- so that the old type may be more easily collected. + ; writeMutVar ref (Indirect zty) + ; return zty } } | otherwise = lookup_in_env where @@ -1353,6 +1341,7 @@ zonkTcLCoToLCo env co ; return (TcCastCo co1' co2') } go (TcSymCo co) = do { co' <- go co; return (mkTcSymCo co') } go (TcNthCo n co) = do { co' <- go co; return (mkTcNthCo n co') } + go (TcLRCo lr co) = do { co' <- go co; return (mkTcLRCo lr co') } go (TcTransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 ; return (mkTcTransCo co1' co2') } go (TcForAllCo tv co) = ASSERT( isImmutableTyVar tv ) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 9650b059e9..2f397a06fc 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -29,8 +29,7 @@ module TcHsType ( tcLHsType, tcCheckLHsType, tcHsContext, tcInferApps, tcHsArgTys, - ExpKind(..), ekConstraint, expArgKind, checkExpectedKind, - kindGeneralize, + kindGeneralize, checkKind, -- Sort-checking kinds tcLHsKind, @@ -967,7 +966,7 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside ; return (n, exp_k) } kc_tv (L _ (KindedTyVar n hs_k)) exp_k = do { k <- tcLHsKind hs_k - ; _ <- unifyKind k exp_k + ; checkKind k exp_k ; check_in_scope n exp_k ; return (n, k) } @@ -979,7 +978,7 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside = do { mb_thing <- tcLookupLcl_maybe n ; case mb_thing of Nothing -> return () - Just (AThing k) -> discardResult (unifyKind k exp_k) + Just (AThing k) -> checkKind k exp_k Just thing -> pprPanic "check_in_scope" (ppr thing) } ----------------------- @@ -1014,7 +1013,7 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside where tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k - ; _ <- unifyKind kind tc_kind + ; checkKind kind tc_kind ; return (mkTyVar n kind) } ----------------------------------- @@ -1201,7 +1200,7 @@ Consider Here * The pattern (T p1 p2) creates a *skolem* type variable 'a_sk', It must be a skolem so that that it retains its identity, and - TcErrors.getSkolemInfo can therreby find the binding site for the skolem. + TcErrors.getSkolemInfo can thereby find the binding site for the skolem. * The type signature pattern (f :: a->Int) binds "a" -> a_sig in the envt @@ -1274,66 +1273,75 @@ unifyKinds fun act_kinds ; mapM_ check (zip [1..] act_kinds) ; return kind } +checkKind :: TcKind -> TcKind -> TcM () +checkKind act_kind exp_kind + = do { mb_subk <- unifyKindX act_kind exp_kind + ; case mb_subk of + Just EQ -> return () + _ -> unifyKindMisMatch act_kind exp_kind } + checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () --- A fancy wrapper for 'unifyKind', which tries +-- A fancy wrapper for 'unifyKindX', which tries -- to give decent error messages. -- (checkExpectedKind ty act_kind exp_kind) -- checks that the actual kind act_kind is compatible -- with the expected kind exp_kind -- The first argument, ty, is used only in the error message generation -checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do - traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr ek) - (_errs, mb_r) <- tryTc (unifyKind act_kind exp_kind) - case mb_r of - Just _ -> return () -- Unification succeeded - Nothing -> do - - -- So there's definitely an error - -- Now to find out what sort - exp_kind <- zonkTcKind exp_kind - act_kind <- zonkTcKind act_kind - - env0 <- tcInitTidyEnv - let (exp_as, _) = splitKindFunTys exp_kind - (act_as, _) = splitKindFunTys act_kind - n_exp_as = length exp_as - n_act_as = length act_as - n_diff_as = n_act_as - n_exp_as - - (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind - (env2, tidy_act_kind) = tidyOpenKind env1 act_kind - - err | n_exp_as < n_act_as -- E.g. [Maybe] - = ptext (sLit "Expecting") <+> - speakN n_diff_as <+> ptext (sLit "more argument") <> - (if n_diff_as > 1 then char 's' else empty) <+> - ptext (sLit "to") <+> quotes (ppr ty) - - -- Now n_exp_as >= n_act_as. In the next two cases, - -- n_exp_as == 0, and hence so is n_act_as - | isConstraintKind tidy_act_kind - = text "Predicate" <+> quotes (ppr ty) <+> text "used as a type" - - | isConstraintKind tidy_exp_kind - = text "Type of kind" <+> ppr tidy_act_kind <+> text "used as a constraint" - - | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind - = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) - <+> ptext (sLit "is unlifted") - - | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind - = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty) - <+> ptext (sLit "is lifted") - - | otherwise -- E.g. Monad [Int] - = ptext (sLit "Kind mis-match") $$ more_info - - more_info = sep [ ek_ctxt <+> ptext (sLit "kind") - <+> quotes (pprKind tidy_exp_kind) <> comma, - ptext (sLit "but") <+> quotes (ppr ty) <+> - ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)] - - failWithTcM (env2, err) +checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) + = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr ek) + ; mb_subk <- unifyKindX act_kind exp_kind + + -- Kind unification only generates definite errors + ; case mb_subk of { + Just LT -> return () ; -- act_kind is a sub-kind of exp_kind + Just EQ -> return () ; -- The two are equal + _other -> do + + { -- So there's an error + -- Now to find out what sort + exp_kind <- zonkTcKind exp_kind + ; act_kind <- zonkTcKind act_kind + ; env0 <- tcInitTidyEnv + ; let (exp_as, _) = splitKindFunTys exp_kind + (act_as, _) = splitKindFunTys act_kind + n_exp_as = length exp_as + n_act_as = length act_as + n_diff_as = n_act_as - n_exp_as + + (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind + (env2, tidy_act_kind) = tidyOpenKind env1 act_kind + + err | n_exp_as < n_act_as -- E.g. [Maybe] + = ptext (sLit "Expecting") <+> + speakN n_diff_as <+> ptext (sLit "more argument") <> + (if n_diff_as > 1 then char 's' else empty) <+> + ptext (sLit "to") <+> quotes (ppr ty) + + -- Now n_exp_as >= n_act_as. In the next two cases, + -- n_exp_as == 0, and hence so is n_act_as + | isConstraintKind tidy_act_kind + = text "Predicate" <+> quotes (ppr ty) <+> text "used as a type" + + | isConstraintKind tidy_exp_kind + = text "Type of kind" <+> ppr tidy_act_kind <+> text "used as a constraint" + + | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind + = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is unlifted") + + | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind + = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is lifted") + + | otherwise -- E.g. Monad [Int] + = ptext (sLit "Kind mis-match") $$ more_info + + more_info = sep [ ek_ctxt <+> ptext (sLit "kind") + <+> quotes (pprKind tidy_exp_kind) <> comma, + ptext (sLit "but") <+> quotes (ppr ty) <+> + ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)] + + ; failWithTcM (env2, err) } } } \end{code} %************************************************************************ @@ -1488,5 +1496,15 @@ badPatSigTvs sig_ty bad_tvs ptext (sLit "but are actually discarded by a type synonym") ] , ptext (sLit "To fix this, expand the type synonym") , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] + +unifyKindMisMatch :: TcKind -> TcKind -> TcM a +unifyKindMisMatch ki1 ki2 = do + ki1' <- zonkTcKind ki1 + ki2' <- zonkTcKind ki2 + let msg = hang (ptext (sLit "Couldn't match kind")) + 2 (sep [quotes (ppr ki1'), + ptext (sLit "against"), + quotes (ppr ki2')]) + failWithTc msg \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 140e1c88a9..b4a27b5376 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -560,7 +560,6 @@ tcFamInstDecl top_lvl decl -- Look up the family TyCon and check for validity including -- check that toplevel type instances are not for associated types. ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; when (isTopLevel top_lvl && isTyConAssoc fam_tc) (addErr $ assocInClassErr fam_tc_lname) @@ -573,7 +572,13 @@ tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst -- "type instance" tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name , fid_defn = TySynonym {} }) - = do { -- (1) do the work of verifying the synonym + = do { -- (0) Check it's an open type family + checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isOpenSynFamilyTyCon fam_tc) + (notOpenFamily fam_tc) + + -- (1) do the work of verifying the synonym ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl -- (2) check the well-formedness of the instance @@ -840,10 +845,9 @@ tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcSigInfo) mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id - = do { uniq <- newUnique - ; loc <- getSrcSpanM - ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name - ; local_meth_name <- newLocalName sel_name + = do { let sel_occ = nameOccName sel_name + ; meth_name <- newName (mkClassOpAuxOcc sel_occ) + ; local_meth_name <- newName sel_occ -- Base the local_meth_name on the selector name, becuase -- type errors from tcInstanceMethodBody come from here @@ -853,7 +857,8 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; instTcTySig hs_ty sig_ty local_meth_name } Nothing -- No type signature - -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) + -> do { loc <- getSrcSpanM + ; instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) } -- Absent a type sig, there are no new scoped type variables here -- Only the ones from the instance decl itself, which are already -- in scope. Example: @@ -942,7 +947,7 @@ immediate superclasses of the dictionary we are trying to construct. In our example: dfun :: forall a. C [a] -> D [a] -> D [a] dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... -Notice teh extra (dc :: C [a]) argument compared to the previous version. +Notice the extra (dc :: C [a]) argument compared to the previous version. This gives us: @@ -962,9 +967,13 @@ dictionary constructor). No superclass is hidden inside a dfun application. The extra arguments required to satisfy the DFun Superclass Invariant -always come first, and are called the "silent" arguments. DFun types -are built (only) by MkId.mkDictFunId, so that is where we decide -what silent arguments are to be added. +always come first, and are called the "silent" arguments. You can +find out how many silent arguments there are using Id.dfunNSilent; +and then you can just drop that number of arguments to see the ones +that were in the original instance declaration. + +DFun types are built (only) by MkId.mkDictFunId, so that is where we +decide what silent arguments are to be added. In our example, if we had [Wanted] dw :: D [a] we would get via the instance: dw := dfun d1 d2 @@ -1067,16 +1076,18 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of - Just user_bind -> tc_body sig_fn sel_id standalone_deriv user_bind - Nothing -> traceTc "tc_def" (ppr sel_id) >> - tc_default sig_fn sel_id dm_info + Just (user_bind, bndr_loc) + -> tc_body sig_fn sel_id standalone_deriv user_bind bndr_loc + Nothing -> do { traceTc "tc_def" (ppr sel_id) + ; tc_default sig_fn sel_id dm_info } ---------------------- - tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) - tc_body sig_fn sel_id generated_code rn_bind + tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name + -> SrcSpan -> TcM (TcId, LHsBind Id) + tc_body sig_fn sel_id generated_code rn_bind bndr_loc = add_meth_ctxt sel_id generated_code rn_bind $ do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) - ; (meth_id, local_meth_sig) <- setSrcSpan (getLoc rn_bind) $ + ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; let prags = prag_fn (idName sel_id) @@ -1094,22 +1105,23 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name - ; tc_body sig_fn sel_id False {- Not generated code? -} meth_bind } + ; tc_body sig_fn sel_id False {- Not generated code? -} + meth_bind inst_loc } tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) ; warnMissingMethodOrAT "method" (idName sel_id) ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars - inst_tys sel_id + inst_tys sel_id ; dflags <- getDynFlags ; return (meth_id, mkVarBind meth_id $ mkLHsWrap lam_wrapper (error_rhs dflags)) } where - error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags) - error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L loc (HsLit (HsStringPrim (unsafeMkFastBytesString (error_string dflags)))) + error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) + error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID + error_msg dflags = L inst_loc (HsLit (HsStringPrim (unsafeMkFastBytesString (error_string dflags)))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) - error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ]) + error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method @@ -1126,14 +1138,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars)) ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars - inst_tys sel_id + inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ HsVar dm_id local_meth_id = sig_id local_meth_sig - meth_bind = mkVarBind local_meth_id (L loc rhs) + meth_bind = mkVarBind local_meth_id (L inst_loc rhs) meth_id1 = meth_id `setInlinePragma` dm_inline_prag -- Copy the inline pragma (if any) from the default -- method to this version. Note [INLINE and default methods] @@ -1151,7 +1163,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- currently they are rejected with -- "INLINE pragma lacks an accompanying binding" - ; return (meth_id1, L loc bind) } + ; return (meth_id1, L inst_loc bind) } ---------------------- mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags @@ -1171,10 +1183,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- and the specialisation would do nothing. (Indeed it'll provoke -- a warning from the desugarer | otherwise - = [ L loc (SpecPrag meth_id wrap inl) - | L loc (SpecPrag _ wrap inl) <- spec_inst_prags] + = [ L inst_loc (SpecPrag meth_id wrap inl) + | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] - loc = getSrcSpan dfun_id + inst_loc = getSrcSpan dfun_id -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error @@ -1442,4 +1454,8 @@ badFamInstDecl tc_name = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] + +notOpenFamily :: TyCon -> SDoc +notOpenFamily tc + = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) \end{code} diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 2c2dc54c1b..db7f36297f 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -8,7 +8,7 @@ module TcInteract ( solveInteractGiven, -- Solves [EvVar],GivenLoc - solveInteractCts, -- Solves [Cts] + solveInteract, -- Solves Cts ) where #include "HsVersions.h" @@ -24,7 +24,7 @@ import Coercion( mkAxInstRHS ) import Var import TcType -import PrelNames (singIClassName) +import PrelNames (singIClassName, ipClassNameKey ) import Class import TyCon @@ -46,10 +46,10 @@ import Bag import Control.Monad ( foldM ) import VarEnv -import qualified Data.Traversable as Traversable import Control.Monad( when, unless ) import Pair () +import Unique( hasKey ) import UniqFM import FastString ( sLit ) import DynFlags @@ -85,49 +85,53 @@ Note [Basic Simplifier Plan] If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail. \begin{code} - -solveInteractCts :: [Ct] -> TcS (Bag Implication) --- Returns a bag of residual implications that have arisen while solving --- this particular worklist. -solveInteractCts cts - = do { traceTcS "solveInteractCtS" (vcat [ text "cts =" <+> ppr cts ]) - ; updWorkListTcS (appendWorkListCt cts) >> solveInteract - ; impls <- getTcSImplics - ; updTcSImplics (const emptyBag) -- Nullify residual implications - ; return impls } - -solveInteractGiven :: GivenLoc -> [EvVar] -> TcS (Bag Implication) +solveInteractGiven :: CtLoc -> [TcTyVar] -> [EvVar] -> TcS () -- In principle the givens can kick out some wanteds from the inert -- resulting in solving some more wanted goals here which could emit -- implications. That's why I return a bag of implications. Not sure -- if this can happen in practice though. -solveInteractGiven gloc evs - = solveInteractCts (map mk_noncan evs) +solveInteractGiven loc fsks givens + = do { implics <- solveInteract (fsk_bag `unionBags` given_bag) + ; ASSERT( isEmptyBag implics ) + return () } -- We do not decompose *given* polymorphic equalities + -- (forall a. t1 ~ forall a. t2) + -- What would the evidence look like?! + -- See Note [Do not decompose given polytype equalities] + -- in TcCanonical where - mk_noncan ev = CNonCanonical { cc_ev = Given { ctev_gloc = gloc - , ctev_evtm = EvId ev - , ctev_pred = evVarPred ev } - , cc_depth = 0 } + given_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvId ev_id + , ctev_pred = evVarPred ev_id } + | ev_id <- givens ] + + fsk_bag = listToBag [ mkNonCanonical loc $ CtGiven { ctev_evtm = EvCoercion (mkTcReflCo tv_ty) + , ctev_pred = pred } + | tv <- fsks + , let FlatSkol fam_ty = tcTyVarDetails tv + tv_ty = mkTyVarTy tv + pred = mkTcEqPred fam_ty tv_ty + ] -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- -solveInteract :: TcS () --- Returns the final InertSet in TcS, WorkList will be eventually empty. -solveInteract +solveInteract :: Cts -> TcS (Bag Implication) +-- Returns the final InertSet in TcS +-- Has no effect on work-list or residual-iplications +solveInteract cts = {-# SCC "solveInteract" #-} + withWorkList cts $ do { dyn_flags <- getDynFlags - ; let max_depth = ctxtStkDepth dyn_flags - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem max_depth - ; case sel of - NoWorkRemaining -- Done, successfuly (modulo frozen) - -> return () - MaxDepthExceeded ct -- Failure, depth exceeded - -> wrapErrTcS $ solverDepthErrorTcS (cc_depth ct) [ct] - NextWorkItem ct -- More work, loop around! - -> runSolverPipeline thePipeline ct >> solve_loop } - ; solve_loop } + ; solve_loop (ctxtStkDepth dyn_flags) } + where + solve_loop max_depth + = {-# SCC "solve_loop" #-} + do { sel <- selectNextWorkItem max_depth + ; case sel of + NoWorkRemaining -- Done, successfuly (modulo frozen) + -> return () + MaxDepthExceeded ct -- Failure, depth exceeded + -> wrapErrTcS $ solverDepthErrorTcS ct + NextWorkItem ct -- More work, loop around! + -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } } type WorkItem = Ct type SimplifierStage = WorkItem -> TcS StopOrContinue @@ -147,14 +151,15 @@ selectNextWorkItem max_depth = updWorkListTcS_return pick_next where pick_next :: WorkList -> (SelectWorkItem, WorkList) - pick_next wl = case selectWorkItem wl of - (Nothing,_) - -> (NoWorkRemaining,wl) -- No more work - (Just ct, new_wl) - | cc_depth ct > max_depth -- Depth exceeded - -> (MaxDepthExceeded ct,new_wl) - (Just ct, new_wl) - -> (NextWorkItem ct, new_wl) -- New workitem and worklist + pick_next wl + = case selectWorkItem wl of + (Nothing,_) + -> (NoWorkRemaining,wl) -- No more work + (Just ct, new_wl) + | ctLocDepth (cc_loc ct) > max_depth -- Depth exceeded + -> (MaxDepthExceeded ct,new_wl) + (Just ct, new_wl) + -> (NextWorkItem ct, new_wl) -- New workitem and worklist runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline -> WorkItem -- The work item @@ -166,6 +171,7 @@ runSolverPipeline pipeline workItem vcat [ ptext (sLit "work item = ") <+> ppr workItem , ptext (sLit "inerts = ") <+> ppr initial_is] + ; bumpStepCountTcS -- One step for each constraint processed ; final_res <- run_pipeline pipeline (ContinueWith workItem) ; final_is <- getTcSInerts @@ -173,10 +179,11 @@ runSolverPipeline pipeline workItem Stop -> do { traceTcS "End solver pipeline (discharged) }" (ptext (sLit "inerts = ") <+> ppr final_is) ; return () } - ContinueWith ct -> do { traceTcS "End solver pipeline (not discharged) }" $ + ContinueWith ct -> do { traceFireTcS ct (ptext (sLit "Kept as inert:") <+> ppr ct) + ; traceTcS "End solver pipeline (not discharged) }" $ vcat [ ptext (sLit "final_item = ") <+> ppr ct , ptext (sLit "inerts = ") <+> ppr final_is] - ; updInertSetTcS ct } + ; insertInertItemTcS ct } } where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue -> TcS StopOrContinue run_pipeline [] res = return res @@ -215,39 +222,13 @@ React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canoni \begin{code} thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("lookup-in-inerts", lookupInInertsStage) - , ("canonicalization", canonicalizationStage) +thePipeline = [ ("canonicalization", TcCanonical.canonicalize) , ("spontaneous solve", spontaneousSolveStage) , ("interact with inerts", interactWithInertsStage) , ("top-level reactions", topReactionsStage) ] \end{code} -\begin{code} - --- A quick lookup everywhere to see if we know about this constraint --------------------------------------------------------------------- -lookupInInertsStage :: SimplifierStage -lookupInInertsStage ct - | Wanted { ctev_evar = ev_id, ctev_pred = pred } <- cc_ev ct - = do { is <- getTcSInerts - ; case lookupInInerts is pred of - Just ctev - | not (isDerived ctev) - -> do { setEvBind ev_id (ctEvTerm ctev) - ; return Stop } - _ -> continueWith ct } - | otherwise -- I could do something like that for givens - -- as well I suppose but it is not a big deal - = continueWith ct - - --- The canonicalization stage, see TcCanonical for details ----------------------------------------------------------- -canonicalizationStage :: SimplifierStage -canonicalizationStage = TcCanonical.canonicalize -\end{code} - ********************************************************************************* * * The spontaneous-solve Stage @@ -277,134 +258,93 @@ Case 2: Functional Dependencies \begin{code} spontaneousSolveStage :: SimplifierStage spontaneousSolveStage workItem - = do { mSolve <- trySpontaneousSolve workItem - ; spont_solve mSolve } - where spont_solve SPCantSolve - | isCTyEqCan workItem -- Unsolved equality - = do { kickOutRewritableInerts workItem -- NB: will add workItem in inerts - ; return Stop } - | otherwise - = continueWith workItem - spont_solve (SPSolved workItem') -- Post: workItem' must be equality - = do { bumpStepCountTcS - ; traceFireTcS (cc_depth workItem) $ - ptext (sLit "Spontaneous:") <+> ppr workItem - - -- NB: will add the item in the inerts - ; kickOutRewritableInerts workItem' - -- .. and Stop - ; return Stop } - -kickOutRewritableInerts :: Ct -> TcS () --- Pre: ct is a CTyEqCan --- Post: The TcS monad is left with the thinner non-rewritable inerts; but which --- contains the new constraint. --- The rewritable end up in the worklist -kickOutRewritableInerts ct - = {-# SCC "kickOutRewritableInerts" #-} - do { traceTcS "kickOutRewritableInerts" $ text "workitem = " <+> ppr ct - ; (wl,ieqs) <- {-# SCC "kick_out_rewritable" #-} - modifyInertTcS (kick_out_rewritable ct) - ; traceTcS "Kicked out the following constraints" $ ppr wl - ; is <- getTcSInerts - ; traceTcS "Remaining inerts are" $ ppr is - - -- Step 1: Rewrite as many of the inert_eqs on the spot! - -- NB: if it is a given constraint just use the cached evidence - -- to optimize e.g. mkRefl coercions from spontaneously solved cts. - ; bnds <- getTcEvBindsMap - ; let ct_coercion = getCtCoercion bnds ct - - ; new_ieqs <- {-# SCC "rewriteInertEqsFromInertEq" #-} - rewriteInertEqsFromInertEq (cc_tyvar ct, - ct_coercion,cc_ev ct) ieqs - ; let upd_eqs is = is { inert_cans = new_ics } - where ics = inert_cans is - new_ics = ics { inert_eqs = new_ieqs } - ; modifyInertTcS (\is -> ((), upd_eqs is)) - - ; is <- getTcSInerts - ; traceTcS "Final inerts are" $ ppr is - - -- Step 2: Add the new guy in - ; updInertSetTcS ct - - ; traceTcS "Kick out" (ppr ct $$ ppr wl) - ; updWorkListTcS (unionWorkList wl) } - -rewriteInertEqsFromInertEq :: (TcTyVar, TcCoercion, CtEvidence) -- A new substitution - -> TyVarEnv Ct -- All the inert equalities - -> TcS (TyVarEnv Ct) -- The new inert equalities -rewriteInertEqsFromInertEq (subst_tv, _subst_co, subst_fl) ieqs --- The goal: traverse the inert equalities and throw some of them back to the worklist --- if you have to rewrite and recheck them for occurs check errors. --- To see which ones we must throw out see Note [Delicate equality kick-out] - = do { mieqs <- Traversable.mapM do_one ieqs - ; traceTcS "Original inert equalities:" (ppr ieqs) - ; let flatten_justs elem venv - | Just act <- elem = extendVarEnv venv (cc_tyvar act) act - | otherwise = venv - final_ieqs = foldVarEnv flatten_justs emptyVarEnv mieqs - ; traceTcS "Remaining inert equalities:" (ppr final_ieqs) - ; return final_ieqs } - - where do_one ct - | subst_fl `canRewrite` fl && (subst_tv `elemVarSet` tyVarsOfCt ct) - = if fl `canRewrite` subst_fl then - -- If also the inert can rewrite the subst then there is no danger of - -- occurs check errors sor keep it there. No need to rewrite the inert equality - -- (as we did in the past) because of point (8) of - -- Note [Detailed InertCans Invariants] and - return (Just ct) - -- used to be: rewrite_on_the_spot ct >>= ( return . Just ) - else -- We have to throw inert back to worklist for occurs checks - updWorkListTcS (extendWorkListEq ct) >> return Nothing - | otherwise -- Just keep it there - = return (Just ct) - where - fl = cc_ev ct - -kick_out_rewritable :: Ct - -> InertSet - -> ((WorkList, TyVarEnv Ct),InertSet) --- Post: returns ALL inert equalities, to be dealt with later --- -kick_out_rewritable ct is@(IS { inert_cans = - IC { inert_eqs = eqmap - , inert_eq_tvs = inscope - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds } - , inert_frozen = frozen }) - = ((kicked_out,eqmap), remaining) + = do { mb_solved <- trySpontaneousSolve workItem + ; case mb_solved of + SPCantSolve + | CTyEqCan { cc_tyvar = tv, cc_ev = fl } <- workItem + -- Unsolved equality + -> do { n_kicked <- kickOutRewritable (ctEvFlavour fl) tv + ; traceFireTcS workItem $ + ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked <> colon + <+> ppr workItem + ; insertInertItemTcS workItem + ; return Stop } + | otherwise + -> continueWith workItem + + SPSolved new_tv + -- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well + -- see Note [Spontaneously solved in TyBinds] + -> do { n_kicked <- kickOutRewritable Given new_tv + ; traceFireTcS workItem $ + ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked <> colon + <+> ppr workItem + ; return Stop } } + +ppr_kicked :: Int -> SDoc +ppr_kicked 0 = empty +ppr_kicked n = parens (int n <+> ptext (sLit "kicked out")) +\end{code} +Note [Spontaneously solved in TyBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we encounter a constraint ([W] alpha ~ tau) which can be spontaneously solved, +we record the equality on the TyBinds of the TcSMonad. In the past, we used to also +add a /given/ version of the constraint ([G] alpha ~ tau) to the inert +canonicals -- and potentially kick out other equalities that mention alpha. + +Then, the flattener only had to look in the inert equalities during flattening of a +type (TcCanonical.flattenTyVar). + +However it is a bit silly to record these equalities /both/ in the inerts AND the +TyBinds, so we have now eliminated spontaneously solved equalities from the inerts, +and only record them in the TyBinds of the TcS monad. The flattener is now consulting +these binds /and/ the inerts for potentially unsolved or other given equalities. + +\begin{code} +kickOutRewritable :: CtFlavour -- Flavour of the equality that is + -- being added to the inert set + -> TcTyVar -- The new equality is tv ~ ty + -> TcS Int +kickOutRewritable new_flav new_tv + = do { wl <- modifyInertTcS kick_out + ; traceTcS "kickOutRewritable" $ + vcat [ text "tv = " <+> ppr new_tv + , ptext (sLit "Kicked out =") <+> ppr wl] + ; updWorkListTcS (appendWorkList wl) + ; return (workListSize wl) } where - rest_out = fro_out `andCts` dicts_out `andCts` irs_out - kicked_out = WorkList { wl_eqs = [] - , wl_funeqs = bagToList feqs_out - , wl_rest = bagToList rest_out } - - remaining = is { inert_cans = IC { inert_eqs = emptyVarEnv - , inert_eq_tvs = inscope - -- keep the same, safe and cheap - , inert_dicts = dicts_in - , inert_funeqs = feqs_in - , inert_irreds = irs_in } - , inert_frozen = fro_in } + kick_out :: InertSet -> (WorkList, InertSet) + kick_out (is@(IS { inert_cans = IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insols = insols } })) + = (kicked_out, is { inert_cans = inert_cans_in }) -- NB: Notice that don't rewrite - -- inert_solved, inert_flat_cache and inert_solved_funeqs + -- inert_solved_dicts, and inert_solved_funeqs -- optimistically. But when we lookup we have to take the -- subsitution into account - fl = cc_ev ct - tv = cc_tyvar ct - - (feqs_out, feqs_in) = partCtFamHeadMap rewritable funeqmap - (dicts_out, dicts_in) = partitionCCanMap rewritable dictmap - - (irs_out, irs_in) = partitionBag rewritable irreds - (fro_out, fro_in) = partitionBag rewritable frozen - - rewritable ct = (fl `canRewrite` cc_ev ct) && - (tv `elemVarSet` tyVarsOfCt ct) + where + inert_cans_in = IC { inert_eqs = tv_eqs_in + , inert_dicts = dicts_in + , inert_funeqs = feqs_in + , inert_irreds = irs_in + , inert_insols = insols_in } + + kicked_out = WorkList { wl_eqs = varEnvElts tv_eqs_out + , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out + , wl_rest = bagToList (dicts_out `andCts` irs_out + `andCts` insols_out) } + + (tv_eqs_out, tv_eqs_in) = partitionVarEnv kick_out_eq tv_eqs + (feqs_out, feqs_in) = partCtFamHeadMap kick_out_ct funeqmap + (dicts_out, dicts_in) = partitionCCanMap kick_out_ct dictmap + (irs_out, irs_in) = partitionBag kick_out_ct irreds + (insols_out, insols_in) = partitionBag kick_out_ct insols + -- Kick out even insolubles; see Note [Kick out insolubles] + + kick_out_ct inert_ct = new_flav `canRewrite` (ctFlavour inert_ct) && + (new_tv `elemVarSet` tyVarsOfCt inert_ct) -- NB: tyVarsOfCt will return the type -- variables /and the kind variables/ that are -- directly visible in the type. Hence we will @@ -414,11 +354,26 @@ kick_out_rewritable ct is@(IS { inert_cans = -- constraints that mention type variables whose -- kinds could contain this variable! + kick_out_eq inert_ct = kick_out_ct inert_ct && + not (ctFlavour inert_ct `canRewrite` new_flav) + -- If also the inert can rewrite the subst then there is no danger of + -- occurs check errors sor keep it there. No need to rewrite the inert equality + -- (as we did in the past) because of point (8) of + -- See Note [Detailed InertCans Invariants] + -- and Note [Delicate equality kick-out] \end{code} +Note [Kick out insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an insoluble alpha ~ [alpha], which is insoluble +because an occurs check. And then we unify alpha := [Int]. +Then we really want to rewrite the insouluble to [Int] ~ [[Int]]. +Now it can be decomposed. Otherwise we end up with a "Can't match +[Int] ~ [[Int]]" which is true, but a bit confusing because the +outer type constructors match. + Note [Delicate equality kick-out] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Delicate: When kicking out rewritable constraints, it would be safe to simply kick out all rewritable equalities, but instead we only kick out those @@ -443,7 +398,8 @@ but this is no longer necessary see Note [Non-idempotent inert substitution]. \begin{code} data SPSolveResult = SPCantSolve - | SPSolved WorkItem + | SPSolved TcTyVar + -- We solved this /unification/ variable to some type using reflexivity -- SPCantSolve means that we can't do the unification because e.g. the variable is untouchable -- SPSolved workItem' gives us a new *given* to go on @@ -453,22 +409,24 @@ data SPSolveResult = SPCantSolve -- See Note [Touchables and givens] trySpontaneousSolve :: WorkItem -> TcS SPSolveResult trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw - , cc_tyvar = tv1, cc_rhs = xi, cc_depth = d }) + , cc_tyvar = tv1, cc_rhs = xi, cc_loc = d }) | isGiven gw = return SPCantSolve | Just tv2 <- tcGetTyVar_maybe xi - = do { tch1 <- isTouchableMetaTyVar tv1 - ; tch2 <- isTouchableMetaTyVar tv2 + = do { tch1 <- isTouchableMetaTyVarTcS tv1 + ; tch2 <- isTouchableMetaTyVarTcS tv2 ; case (tch1, tch2) of (True, True) -> trySpontaneousEqTwoWay d gw tv1 tv2 (True, False) -> trySpontaneousEqOneWay d gw tv1 xi (False, True) -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1) _ -> return SPCantSolve } | otherwise - = do { tch1 <- isTouchableMetaTyVar tv1 + = do { tch1 <- isTouchableMetaTyVarTcS tv1 ; if tch1 then trySpontaneousEqOneWay d gw tv1 xi - else do { traceTcS "Untouchable LHS, can't spontaneously solve workitem:" $ - ppr workItem + else do { untch <- getUntouchables + ; traceTcS "Untouchable LHS, can't spontaneously solve workitem" $ + vcat [text "Untouchables =" <+> ppr untch + , text "Workitem =" <+> ppr workItem ] ; return SPCantSolve } } @@ -478,25 +436,28 @@ trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw trySpontaneousSolve _ = return SPCantSolve ---------------- -trySpontaneousEqOneWay :: SubGoalDepth - -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult +trySpontaneousEqOneWay :: CtLoc -> CtEvidence + -> TcTyVar -> Xi -> TcS SPSolveResult -- tv is a MetaTyVar, not untouchable trySpontaneousEqOneWay d gw tv xi | not (isSigTyVar tv) || isTyVarTy xi + , typeKind xi `tcIsSubKind` tyVarKind tv = solveWithIdentity d gw tv xi | otherwise -- Still can't solve, sig tyvar and non-variable rhs = return SPCantSolve ---------------- -trySpontaneousEqTwoWay :: SubGoalDepth - -> CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult +trySpontaneousEqTwoWay :: CtLoc -> CtEvidence + -> TcTyVar -> TcTyVar -> TcS SPSolveResult -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here trySpontaneousEqTwoWay d gw tv1 tv2 - = do { let k1_sub_k2 = k1 `tcIsSubKind` k2 - ; if k1_sub_k2 && nicer_to_update_tv2 - then solveWithIdentity d gw tv2 (mkTyVarTy tv1) - else solveWithIdentity d gw tv1 (mkTyVarTy tv2) } + | k1 `tcIsSubKind` k2 && nicer_to_update_tv2 + = solveWithIdentity d gw tv2 (mkTyVarTy tv1) + | k2 `tcIsSubKind` k1 + = solveWithIdentity d gw tv1 (mkTyVarTy tv2) + | otherwise + = return SPCantSolve where k1 = tyVarKind tv1 k2 = tyVarKind tv2 @@ -504,7 +465,7 @@ trySpontaneousEqTwoWay d gw tv1 tv2 \end{code} Note [Kind errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~ Consider the wanted problem: alpha ~ (# Int, Int #) where alpha :: ArgKind and (# Int, Int #) :: (#). We can't spontaneously solve this constraint, @@ -575,8 +536,7 @@ unification variables as RHS of type family equations: F xis ~ alpha. \begin{code} ---------------- -solveWithIdentity :: SubGoalDepth - -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult +solveWithIdentity :: CtLoc -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult -- Solve with the identity coercion -- Precondition: kind(xi) is a sub-kind of kind(tv) -- Precondition: CtEvidence is Wanted or Derived @@ -589,10 +549,10 @@ solveWithIdentity :: SubGoalDepth -- arises from a CTyEqCan, a *canonical* constraint. Its invariants -- say that in (a ~ xi), the type variable a does not appear in xi. -- See TcRnTypes.Ct invariants. -solveWithIdentity d wd tv xi +solveWithIdentity _d wd tv xi = do { let tv_ty = mkTyVarTy tv ; traceTcS "Sneaky unification:" $ - vcat [text "Constraint:" <+> ppr wd, + vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi, text "Coercion:" <+> pprEq tv_ty xi, text "Left Kind is:" <+> ppr (typeKind tv_ty), text "Right Kind is:" <+> ppr (typeKind xi) ] @@ -604,18 +564,11 @@ solveWithIdentity d wd tv xi ; setWantedTyBind tv xi' ; let refl_evtm = EvCoercion (mkTcReflCo xi') - refl_pred = mkTcEqPred tv_ty xi' ; when (isWanted wd) $ setEvBind (ctev_evar wd) refl_evtm - ; let given_fl = Given { ctev_gloc = mkGivenLoc (ctev_wloc wd) UnkSkol - , ctev_pred = refl_pred - , ctev_evtm = refl_evtm } - - ; return $ - SPSolved (CTyEqCan { cc_ev = given_fl - , cc_tyvar = tv, cc_rhs = xi', cc_depth = d }) } + ; return (SPSolved tv) } \end{code} @@ -656,21 +609,10 @@ or, equivalently, -- Interaction result of WorkItem <~> Ct data InteractResult - = IRWorkItemConsumed { ir_fire :: String } - | IRInertConsumed { ir_fire :: String } - | IRKeepGoing { ir_fire :: String } - -irWorkItemConsumed :: String -> TcS InteractResult -irWorkItemConsumed str = return (IRWorkItemConsumed str) - -irInertConsumed :: String -> TcS InteractResult -irInertConsumed str = return (IRInertConsumed str) - -irKeepGoing :: String -> TcS InteractResult -irKeepGoing str = return (IRKeepGoing str) --- You can't discard neither workitem or inert, but you must keep --- going. It's possible that new work is waiting in the TcS worklist. - + = IRWorkItemConsumed { ir_fire :: String } -- Work item discharged by interaction; stop + | IRReplace { ir_fire :: String } -- Inert item replaced by work item; stop + | IRInertConsumed { ir_fire :: String } -- Inert item consumed, keep going with work item + | IRKeepGoing { ir_fire :: String } -- Inert item remains, keep going with work item interactWithInertsStage :: WorkItem -> TcS StopOrContinue -- Precondition: if the workitem is a CTyEqCan then it will not be able to @@ -682,7 +624,7 @@ interactWithInertsStage wi ; foldlBagM interact_next (ContinueWith wi) rels } where interact_next Stop atomic_inert - = updInertSetTcS atomic_inert >> return Stop + = do { insertInertItemTcS atomic_inert; return Stop } interact_next (ContinueWith wi) atomic_inert = do { ir <- doInteractWithInert atomic_inert wi ; let mk_msg rule keep_doc @@ -691,21 +633,22 @@ interactWithInertsStage wi , ptext (sLit "WorkItem =") <+> ppr wi ] ; case ir of IRWorkItemConsumed { ir_fire = rule } - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth wi) - (mk_msg rule (text "WorkItemConsumed")) - ; updInertSetTcS atomic_inert + -> do { traceFireTcS wi (mk_msg rule (text "WorkItemConsumed")) + ; insertInertItemTcS atomic_inert + ; return Stop } + IRReplace { ir_fire = rule } + -> do { traceFireTcS atomic_inert + (mk_msg rule (text "InertReplace")) + ; insertInertItemTcS wi ; return Stop } IRInertConsumed { ir_fire = rule } - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth atomic_inert) + -> do { traceFireTcS atomic_inert (mk_msg rule (text "InertItemConsumed")) ; return (ContinueWith wi) } - IRKeepGoing {} -- Should we do a bumpStepCountTcS? No for now. - -> do { updInertSetTcS atomic_inert + IRKeepGoing {} + -> do { insertInertItemTcS atomic_inert ; return (ContinueWith wi) } } - \end{code} \begin{code} @@ -713,57 +656,60 @@ interactWithInertsStage wi doInteractWithInert :: Ct -> Ct -> TcS InteractResult -- Identical class constraints. -doInteractWithInert - inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyargs = tys1 }) - workItem@(CDictCan { cc_ev = fl2, cc_class = cls2, cc_tyargs = tys2 }) - +doInteractWithInert inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyargs = tys1, cc_loc = loc1 }) + workItem@(CDictCan { cc_ev = fl2, cc_class = cls2, cc_tyargs = tys2, cc_loc = loc2 }) | cls1 == cls2 = do { let pty1 = mkClassPred cls1 tys1 pty2 = mkClassPred cls2 tys2 - inert_pred_loc = (pty1, pprFlavorArising fl1) - work_item_pred_loc = (pty2, pprFlavorArising fl2) + inert_pred_loc = (pty1, pprArisingAt loc1) + work_item_pred_loc = (pty2, pprArisingAt loc2) - ; traceTcS "doInteractWithInert" (vcat [ text "inertItem = " <+> ppr inertItem - , text "workItem = " <+> ppr workItem ]) - ; let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc - ; any_fundeps <- rewriteWithFunDeps fd_eqns tys2 fl2 + ; fd_work <- rewriteWithFunDeps fd_eqns loc2 -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok -- NB: We do create FDs for given to report insoluble equations that arise -- from pairs of Givens, and also because of floating when we approximate -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs -- Also see Note [When improvement happens] - -- - ; case any_fundeps of + ; traceTcS "doInteractWithInert:dict" + (vcat [ text "inertItem =" <+> ppr inertItem + , text "workItem =" <+> ppr workItem + , text "fundeps =" <+> ppr fd_work ]) + + ; case fd_work of -- No Functional Dependencies - Nothing - | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" fl1 workItem - | otherwise -> irKeepGoing "NOP" + [] | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" fl1 workItem + | otherwise -> return (IRKeepGoing "NOP") -- Actual Functional Dependencies - Just (_rewritten_tys2, fd_work) - -- Standard thing: create derived fds and keep on going. Importantly we don't + _ | cls1 `hasKey` ipClassNameKey + , isGiven fl1, isGiven fl2 -- See Note [Shadowing of Implicit Parameters] + -> return (IRReplace ("Replace IP")) + + -- Standard thing: create derived fds and keep on going. Importantly we don't -- throw workitem back in the worklist because this can cause loops. See #5236. - -> do { emitFDWorkAsDerived fd_work (cc_depth workItem) - ; irKeepGoing "Cls/Cls (new fundeps)" } -- Just keep going without droping the inert + | otherwise + -> do { updWorkListTcS (extendWorkListEqs fd_work) + ; return (IRKeepGoing "Cls/Cls (new fundeps)") } -- Just keep going without droping the inert } -- Two pieces of irreducible evidence: if their types are *exactly identical* -- we can rewrite them. We can never improve using this: -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not -- mean that (ty1 ~ ty2) -doInteractWithInert (CIrredEvCan { cc_ev = ifl, cc_ty = ty1 }) - workItem@(CIrredEvCan { cc_ty = ty2 }) - | ty1 `eqType` ty2 +doInteractWithInert (CIrredEvCan { cc_ev = ifl }) + workItem@(CIrredEvCan { cc_ev = wfl }) + | ctEvPred ifl `eqType` ctEvPred wfl = solveOneFromTheOther "Irred/Irred" ifl workItem -doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1 - , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) - wi@(CFunEqCan { cc_ev = fl2, cc_fun = tc2 - , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 }) - | fl1 `canSolve` fl2 && lhss_match - = do { traceTcS "interact with inerts: FunEq/FunEq" $ +doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1 + , cc_tyargs = args1, cc_rhs = xi1, cc_loc = d1 }) + wi@(CFunEqCan { cc_ev = ev2, cc_fun = tc2 + , cc_tyargs = args2, cc_rhs = xi2, cc_loc = d2 }) + | fl1 `canSolve` fl2 + = ASSERT( lhss_match ) -- extractRelevantInerts ensures this + do { traceTcS "interact with inerts: FunEq/FunEq" $ vcat [ text "workItem =" <+> ppr wi , text "inertItem=" <+> ppr ii ] @@ -774,14 +720,15 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1 -- xdecomp : (F args ~ xi2) -> [(xi2 ~ xi1)] xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` co1)] - ; ctevs <- xCtFlavor_cache False fl2 [mkTcEqPred xi2 xi1] xev - -- Why not simply xCtFlavor? See Note [Cache-caused loops] + ; ctevs <- xCtFlavor ev2 [mkTcEqPred xi2 xi1] xev + -- No caching! See Note [Cache-caused loops] -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] - ; add_to_work d2 ctevs - ; irWorkItemConsumed "FunEq/FunEq" } + ; emitWorkNC d2 ctevs + ; return (IRWorkItemConsumed "FunEq/FunEq") } - | fl2 `canSolve` fl1 && lhss_match - = do { traceTcS "interact with inerts: FunEq/FunEq" $ + | fl2 `canSolve` fl1 + = ASSERT( lhss_match ) -- extractRelevantInerts ensures this + do { traceTcS "interact with inerts: FunEq/FunEq" $ vcat [ text "workItem =" <+> ppr wi , text "inertItem=" <+> ppr ii ] @@ -792,23 +739,20 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1 -- xdecomp : (F args ~ xi1) -> [(xi2 ~ xi1)] xdecomp x = [EvCoercion (mkTcSymCo co2 `mkTcTransCo` evTermCoercion x)] - ; ctevs <- xCtFlavor_cache False fl1 [mkTcEqPred xi2 xi1] xev - -- Why not simply xCtFlavor? See Note [Cache-caused loops] - -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] + ; ctevs <- xCtFlavor ev1 [mkTcEqPred xi2 xi1] xev + -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] - ; add_to_work d1 ctevs - ; irInertConsumed "FunEq/FunEq"} + ; emitWorkNC d1 ctevs + ; return (IRInertConsumed "FunEq/FunEq") } where - add_to_work d [ctev] = updWorkListTcS $ extendWorkListEq $ - CNonCanonical {cc_ev = ctev, cc_depth = d} - add_to_work _ _ = return () - lhss_match = tc1 == tc2 && eqTypes args1 args2 - co1 = evTermCoercion $ ctEvTerm fl1 - co2 = evTermCoercion $ ctEvTerm fl2 + co1 = evTermCoercion $ ctEvTerm ev1 + co2 = evTermCoercion $ ctEvTerm ev2 mk_sym_co x = mkTcSymCo (evTermCoercion x) + fl1 = ctEvFlavour ev1 + fl2 = ctEvFlavour ev2 -doInteractWithInert _ _ = irKeepGoing "NOP" +doInteractWithInert _ _ = return (IRKeepGoing "NOP") \end{code} @@ -864,13 +808,6 @@ I can think of two ways to fix this: error if we get multiple givens for the same implicit parameter. - - - - - - - Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in our @@ -903,7 +840,6 @@ just an optimization so we don't lose anything in terms of completeness of solving. \begin{code} - solveOneFromTheOther :: String -- Info -> CtEvidence -- Inert -> Ct -- WorkItem @@ -913,26 +849,61 @@ solveOneFromTheOther :: String -- Info -- 2) ip/class/irred evidence (no coercions) only solveOneFromTheOther info ifl workItem | isDerived wfl - = irWorkItemConsumed ("Solved[DW] " ++ info) + = return (IRWorkItemConsumed ("Solved[DW] " ++ info)) | isDerived ifl -- The inert item is Derived, we can just throw it away, -- The workItem is inert wrt earlier inert-set items, -- so it's safe to continue on from this point - = irInertConsumed ("Solved[DI] " ++ info) + = return (IRInertConsumed ("Solved[DI] " ++ info)) - | otherwise - = ASSERT( ifl `canSolve` wfl ) - -- Because of Note [The Solver Invariant], plus Derived dealt with - do { case wfl of - Wanted { ctev_evar = ev_id } -> setEvBind ev_id (ctEvTerm ifl) - _ -> return () - -- Overwrite the binding, if one exists - -- If both are Given, we already have evidence; no need to duplicate - ; irWorkItemConsumed ("Solved " ++ info) } + | CtWanted { ctev_evar = ev_id } <- wfl + = do { setEvBind ev_id (ctEvTerm ifl); return (IRWorkItemConsumed ("Solved(w) " ++ info)) } + + | CtWanted { ctev_evar = ev_id } <- ifl + = do { setEvBind ev_id (ctEvTerm wfl); return (IRInertConsumed ("Solved(g) " ++ info)) } + + | otherwise -- If both are Given, we already have evidence; no need to duplicate + -- But the work item *overrides* the inert item (hence IRReplace) + -- See Note [Shadowing of Implicit Parameters] + = return (IRReplace ("Replace(gg) " ++ info)) where wfl = cc_ev workItem \end{code} +Note [Shadowing of Implicit Parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in +two incompatible ways: either by using the parameter from the +signature, or by using the local definition. Our intention is +that the local definition should "shadow" the parameter of the +signature, and we implement this as follows: when we nest implications, +we remove any implicit parameters in the outer implication, that +have the same name as givens of the inner implication. + +Here is another variation of the example: + +f :: (?x :: Int) => Char +f = let ?x = 'x' in ?x + +This program should also be accepted: the two constraints `?x :: Int` +and `?x :: Char` never exist in the same context, so they don't get to +interact to cause failure. + Note [Superclasses and recursive dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Overlaps with Note [SUPERCLASS-LOOP 1] @@ -1039,7 +1010,7 @@ So our problem is this We may add the given in the inert set, along with its superclasses [assuming we don't fail because there is a matching instance, see - tryTopReact, given case ] + topReactionsStage, given case ] Inert: d0 :_g Foo t WorkList @@ -1297,48 +1268,36 @@ To achieve this required some refactoring of FunDeps.lhs (nicer now!). \begin{code} -rewriteWithFunDeps :: [Equation] - -> [Xi] - -> CtEvidence - -> TcS (Maybe ([Xi], [CtEvidence])) - -- Not quite a WantedEvVar unfortunately - -- Because our intention could be to make - -- it derived at the end of the day --- NB: The flavor of the returned EvVars will be decided by the caller +rewriteWithFunDeps :: [Equation] -> CtLoc -> TcS [Ct] +-- NB: The returned constraints are all Derived -- Post: returns no trivial equalities (identities) and all EvVars returned are fresh -rewriteWithFunDeps eqn_pred_locs xis fl - = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs - ; let fd_ev_pos :: [(Int,CtEvidence)] - fd_ev_pos = concat fd_ev_poss - rewritten_xis = rewriteDictParams fd_ev_pos xis - ; if null fd_ev_pos then return Nothing - else return (Just (rewritten_xis, map snd fd_ev_pos)) } - where wloc | Given { ctev_gloc = gl } <- fl - = setCtLocOrigin gl FunDepOrigin - | otherwise - = ctev_wloc fl - -instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,CtEvidence)] +rewriteWithFunDeps eqn_pred_locs loc + = do { fd_cts <- mapM (instFunDepEqn loc) eqn_pred_locs + ; return (concat fd_cts) } + +instFunDepEqn :: CtLoc -> Equation -> TcS [Ct] -- Post: Returns the position index as well as the corresponding FunDep equality -instFunDepEqn wl (FDEqn { fd_qtvs = tvs, fd_eqs = eqs - , fd_pred1 = d1, fd_pred2 = d2 }) +instFunDepEqn loc (FDEqn { fd_qtvs = tvs, fd_eqs = eqs + , fd_pred1 = d1, fd_pred2 = d2 }) = do { (subst, _) <- instFlexiTcS tvs -- Takes account of kind substitution ; foldM (do_one subst) [] eqs } where - do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) - = let sty1 = Type.substTy subst ty1 - sty2 = Type.substTy subst ty2 - in if eqType sty1 sty2 then return ievs -- Return no trivial equalities - else do { mb_eqv <- newDerived (push_ctx wl) (mkTcEqPred sty1 sty2) - ; case mb_eqv of - Just ctev -> return $ (i,ctev):ievs - Nothing -> return ievs } - -- We are eventually going to emit FD work back in the work list so - -- it is important that we only return the /freshly created/ and not - -- some existing equality! - push_ctx :: WantedLoc -> WantedLoc - push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc - + der_loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc + + do_one subst ievs (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 }) + | eqType sty1 sty2 + = return ievs -- Return no trivial equalities + | otherwise + = do { mb_eqv <- newDerived (mkTcEqPred sty1 sty2) + ; case mb_eqv of + Just ev -> return (mkNonCanonical der_loc ev : ievs) + Nothing -> return ievs } + -- We are eventually going to emit FD work back in the work list so + -- it is important that we only return the /freshly created/ and not + -- some existing equality! + where + sty1 = Type.substTy subst ty1 + sty2 = Type.substTy subst ty2 mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) @@ -1351,31 +1310,6 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] ; return (tidy_env, msg) } - -rewriteDictParams :: [(Int,CtEvidence)] -- A set of coercions : (pos, ty' ~ ty) - -> [Type] -- A sequence of types: tys - -> [Type] -rewriteDictParams param_eqs tys - = zipWith do_one tys [0..] - where - do_one :: Type -> Int -> Type - do_one ty n = case lookup n param_eqs of - Just wev -> get_fst_ty wev - Nothing -> ty - - get_fst_ty ctev - | Just (ty1, _) <- getEqPredTys_maybe (ctEvPred ctev) - = ty1 - | otherwise - = panic "rewriteDictParams: non equality fundep!?" - - -emitFDWorkAsDerived :: [CtEvidence] -- All Derived - -> SubGoalDepth -> TcS () -emitFDWorkAsDerived evlocs d - = updWorkListTcS $ appendWorkListEqs (map mk_fd_ct evlocs) - where - mk_fd_ct der_ev = CNonCanonical { cc_ev = der_ev, cc_depth = d } \end{code} @@ -1388,21 +1322,14 @@ emitFDWorkAsDerived evlocs d ********************************************************************************* \begin{code} - -topReactionsStage :: SimplifierStage -topReactionsStage workItem - = tryTopReact workItem - - -tryTopReact :: WorkItem -> TcS StopOrContinue -tryTopReact wi +topReactionsStage :: WorkItem -> TcS StopOrContinue +topReactionsStage wi = do { inerts <- getTcSInerts ; tir <- doTopReact inerts wi ; case tir of NoTopInt -> return (ContinueWith wi) SomeTopInt rule what_next - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth wi) $ + -> do { traceFireTcS wi $ vcat [ ptext (sLit "Top react:") <+> text rule , text "WorkItem =" <+> ppr wi ] ; return what_next } } @@ -1427,44 +1354,48 @@ doTopReact inerts workItem = do { traceTcS "doTopReact" (ppr workItem) ; case workItem of CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis - , cc_depth = d } + , cc_loc = d } -> doTopReactDict inerts workItem fl cls xis d CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args - , cc_rhs = xi, cc_depth = d } - -> doTopReactFunEq fl tc args xi d + , cc_rhs = xi, cc_loc = d } + -> doTopReactFunEq workItem fl tc args xi d _ -> -- Any other work item does not react with any top-level equations return NoTopInt } -------------------- doTopReactDict :: InertSet -> WorkItem -> CtEvidence -> Class -> [Xi] - -> SubGoalDepth -> TcS TopInteractResult -doTopReactDict inerts workItem fl cls xis depth + -> CtLoc -> TcS TopInteractResult +doTopReactDict inerts workItem fl cls xis loc = do { instEnvs <- getInstEnvs - ; let fd_eqns = improveFromInstEnv instEnvs - (mkClassPred cls xis, arising_sdoc) + ; let pred = mkClassPred cls xis + fd_eqns = improveFromInstEnv instEnvs (pred, arising_sdoc) - ; m <- rewriteWithFunDeps fd_eqns xis fl - ; case m of - Just (_xis',fd_work) -> - do { emitFDWorkAsDerived fd_work depth - ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" - , tir_new_item = ContinueWith workItem } } - Nothing - | isWanted fl - -> do { lkup_inst_res <- matchClassInst inerts cls xis (getWantedLoc fl) - ; case lkup_inst_res of - GenInst wtvs ev_term -> - addToSolved fl >> doSolveFromInstance wtvs ev_term - NoInstance -> return NoTopInt } - | otherwise - -> return NoTopInt } + ; fd_work <- rewriteWithFunDeps fd_eqns loc + ; if not (null fd_work) then + do { updWorkListTcS (extendWorkListEqs fd_work) + ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" + , tir_new_item = ContinueWith workItem } } + else if not (isWanted fl) then + return NoTopInt + else do + + { solved_dicts <- getTcSInerts >>= (return . inert_solved_dicts) + ; case lookupSolvedDict solved_dicts pred of { + Just ev -> do { setEvBind dict_id (ctEvTerm ev); + ; return $ + SomeTopInt { tir_rule = "Dict/Top (cached)" + , tir_new_item = Stop } } ; + Nothing -> do + + { lkup_inst_res <- matchClassInst inerts cls xis loc + ; case lkup_inst_res of + GenInst wtvs ev_term -> do { addSolvedDict fl + ; doSolveFromInstance wtvs ev_term } + NoInstance -> return NoTopInt } } } } where - arising_sdoc - | isGiven fl = pprArisingAt $ getGivenLoc fl - | otherwise = pprArisingAt $ getWantedLoc fl - + arising_sdoc = pprArisingAt loc dict_id = ctEvId fl doSolveFromInstance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult @@ -1482,59 +1413,59 @@ doTopReactDict inerts workItem fl cls xis depth ppr dict_id ; setEvBind dict_id ev_term ; let mk_new_wanted ev - = CNonCanonical { cc_ev = ev - , cc_depth = depth + 1 } - ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) + = CNonCanonical { cc_ev = ev + , cc_loc = bumpCtLocDepth loc } + ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs)) ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, more work)" , tir_new_item = Stop } } -------------------- -doTopReactFunEq :: CtEvidence -> TyCon -> [Xi] -> Xi - -> SubGoalDepth -> TcS TopInteractResult -doTopReactFunEq fl tc args xi d - = ASSERT (isSynFamilyTyCon tc) -- No associated data families have - -- reached that far - - -- First look in the cache of solved funeqs +doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi + -> CtLoc -> TcS TopInteractResult +doTopReactFunEq _ct fl fun_tc args xi loc + = ASSERT (isSynFamilyTyCon fun_tc) -- No associated data families have + -- reached this far + -- Look in the cache of solved funeqs do { fun_eq_cache <- getTcSInerts >>= (return . inert_solved_funeqs) - ; case lookupFamHead fun_eq_cache (mkTyConApp tc args) of { - Just ctev -> ASSERT( not (isDerived ctev) ) - ASSERT( isEqPred (ctEvPred ctev) ) - succeed_with (evTermCoercion (ctEvTerm ctev)) - (snd (getEqPredTys (ctEvPred ctev))) ; - Nothing -> - - -- No cached solved, so look up in top-level instances - do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS] + ; case lookupFamHead fun_eq_cache fam_ty of { + Just (ctev, rhs_ty) + | ctEvFlavour ctev `canRewrite` ctEvFlavour fl + -> ASSERT( not (isDerived ctev) ) + succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ; + _other -> + + -- Look up in top-level instances + do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS] ; case match_res of { Nothing -> return NoTopInt ; Just (famInst, rep_tys) -> -- Found a top-level instance do { -- Add it to the solved goals - unless (isDerived fl) $ - do { addSolvedFunEq fl - ; addToSolved fl } + unless (isDerived fl) (addSolvedFunEq fam_ty fl xi) ; let coe_ax = famInstAxiom famInst - ; succeed_with (mkTcAxInstCo coe_ax rep_tys) + ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax rep_tys) (mkAxInstRHS coe_ax rep_tys) } } } } } where - succeed_with :: TcCoercion -> TcType -> TcS TopInteractResult - succeed_with coe rhs_ty + fam_ty = mkTyConApp fun_tc args + + succeed_with :: String -> TcCoercion -> TcType -> TcS TopInteractResult + succeed_with str co rhs_ty -- co :: fun_tc args ~ rhs_ty = do { ctevs <- xCtFlavor fl [mkTcEqPred rhs_ty xi] xev + ; traceTcS ("doTopReactFunEq " ++ str) (ppr ctevs) ; case ctevs of [ctev] -> updWorkListTcS $ extendWorkListEq $ CNonCanonical { cc_ev = ctev - , cc_depth = d+1 } + , cc_loc = bumpCtLocDepth loc } ctevs -> -- No subgoal (because it's cached) ASSERT( null ctevs) return () - ; return $ SomeTopInt { tir_rule = "Fun/Top" + ; return $ SomeTopInt { tir_rule = str , tir_new_item = Stop } } where - xdecomp x = [EvCoercion (mkTcSymCo coe `mkTcTransCo` evTermCoercion x)] - xcomp [x] = EvCoercion (coe `mkTcTransCo` evTermCoercion x) + xdecomp x = [EvCoercion (mkTcSymCo co `mkTcTransCo` evTermCoercion x)] + xcomp [x] = EvCoercion (co `mkTcTransCo` evTermCoercion x) xcomp _ = panic "No more goals!" xev = XEvTerm xcomp xdecomp \end{code} @@ -1743,7 +1674,7 @@ data LookupInstResult = NoInstance | GenInst [CtEvidence] EvTerm -matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult +matchClassInst :: InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult matchClassInst _ clas [ _, ty ] _ | className clas == singIClassName @@ -1786,7 +1717,7 @@ matchClassInst inerts clas tys loc ; if null theta then return (GenInst [] (EvDFunApp dfun_id tys [])) else do - { evc_vars <- instDFunConstraints loc theta + { evc_vars <- instDFunConstraints theta ; let new_ev_vars = freshGoals evc_vars -- new_ev_vars are only the real new variables that can be emitted dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars) @@ -1798,14 +1729,14 @@ matchClassInst inerts clas tys loc = lookupUFM (cts_given (inert_dicts $ inert_cans inerts)) clas `orElse` emptyCts - given_overlap :: TcsUntouchables -> Bool + given_overlap :: Untouchables -> Bool given_overlap untch = anyBag (matchable untch) givens_for_this_clas matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys , cc_ev = fl }) | isGiven fl = ASSERT( clas_g == clas ) - case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && + case tcUnifyTys (\tv -> if isTouchableMetaTyVar untch tv && tv `elemVarSet` tyVarsOfTypes tys then BindMe else Skolem) tys sys of -- We can't learn anything more about any variable at this point, so the only diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 67ed96731d..7a3db58e7c 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -25,10 +25,10 @@ module TcMType ( newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] newMetaKindVar, newMetaKindVars, mkKindSigVar, - mkTcTyVarName, + mkTcTyVarName, cloneMetaTyVar, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - isFilledMetaTyVar, isFlexiMetaTyVar, + newMetaDetails, isFilledMetaTyVar, isFlexiMetaTyVar, -------------------------------- -- Creating new evidence variables @@ -65,8 +65,8 @@ module TcMType ( zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, - zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts, - zonkImplication, zonkEvVar, zonkWC, zonkId, + zonkTcKind, defaultKindVarToStar, + zonkEvVar, zonkWC, zonkId, zonkCt, zonkCts, zonkSkolemInfo, tcGetGlobalTyVars, ) where @@ -76,6 +76,7 @@ module TcMType ( -- friends: import TypeRep import TcType +import TcEvidence import Type import Kind import Class @@ -112,10 +113,18 @@ import Data.List ( (\\), partition, mapAccumL ) %************************************************************************ \begin{code} +mkKindName :: Unique -> Name +mkKindName unique = mkSystemName unique kind_var_occ + +kind_var_occ :: OccName -- Just one for all MetaKindVars + -- They may be jiggled by tidying +kind_var_occ = mkOccName tvName "k" + newMetaKindVar :: TcM TcKind -newMetaKindVar = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } +newMetaKindVar = do { uniq <- newUnique + ; details <- newMetaDetails TauTv + ; let kv = mkTcTyVar (mkKindName uniq) superKind details + ; return (mkTyVarTy kv) } newMetaKindVars :: Int -> TcM [TcKind] newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) @@ -146,17 +155,17 @@ newWantedEvVars theta = mapM newWantedEvVar theta newEvVar :: TcPredType -> TcM EvVar -- Creates new *rigid* variables for predicates -newEvVar ty = do { name <- newName (predTypeOccName ty) +newEvVar ty = do { name <- newSysName (predTypeOccName ty) ; return (mkLocalId name ty) } newEq :: TcType -> TcType -> TcM EvVar newEq ty1 ty2 - = do { name <- newName (mkVarOccFS (fsLit "cobox")) + = do { name <- newSysName (mkVarOccFS (fsLit "cobox")) ; return (mkLocalId name (mkTcEqPred ty1 ty2)) } newDict :: Class -> [TcType] -> TcM DictId newDict cls tys - = do { name <- newName (mkDictOcc (getOccName cls)) + = do { name <- newSysName (mkDictOcc (getOccName cls)) ; return (mkLocalId name (mkClassPred cls tys)) } predTypeOccName :: PredType -> OccName @@ -266,12 +275,18 @@ tcInstSigTyVar subst tv newSigTyVar :: Name -> Kind -> TcM TcTyVar newSigTyVar name kind - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi + = do { uniq <- newUnique ; let name' = setNameUnique name uniq -- Use the same OccName so that the tidy-er -- doesn't gratuitously rename 'a' to 'a0' etc - ; return (mkTcTyVar name' kind (MetaTv SigTv ref)) } + ; details <- newMetaDetails SigTv + ; return (mkTcTyVar name' kind details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; untch <- getUntouchables + ; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) } \end{code} Note [Kind substitution when instantiating] @@ -300,14 +315,24 @@ instead of the buggous newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -- Make a new meta tyvar out of thin air newMetaTyVar meta_info kind - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi + = do { uniq <- newUnique ; let name = mkTcTyVarName uniq s s = case meta_info of TauTv -> fsLit "t" - TcsTv -> fsLit "u" SigTv -> fsLit "a" - ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } + ; details <- newMetaDetails meta_info + ; return (mkTcTyVar name kind details) } + +cloneMetaTyVar :: TcTyVar -> TcM TcTyVar +cloneMetaTyVar tv + = ASSERT( isTcTyVar tv ) + do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; let name' = setNameUnique (tyVarName tv) uniq + details' = case tcTyVarDetails tv of + details@(MetaTv {}) -> details { mtv_ref = ref } + _ -> pprPanic "cloneMetaTyVar" (ppr tv) + ; return (mkTcTyVar name' (tyVarKind tv) details') } mkTcTyVarName :: Unique -> FastString -> Name -- Make sure that fresh TcTyVar names finish with a digit @@ -323,7 +348,7 @@ isFilledMetaTyVar :: TyVar -> TcM Bool -- True of a filled-in (Indirect) meta type variable isFilledMetaTyVar tv | not (isTcTyVar tv) = return False - | MetaTv _ ref <- tcTyVarDetails tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref ; return (isIndirect details) } | otherwise = return False @@ -332,7 +357,7 @@ isFlexiMetaTyVar :: TyVar -> TcM Bool -- True of a un-filled-in (Flexi) meta type variable isFlexiMetaTyVar tv | not (isTcTyVar tv) = return False - | MetaTv _ ref <- tcTyVarDetails tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref ; return (isFlexi details) } | otherwise = return False @@ -351,7 +376,7 @@ writeMetaTyVar tyvar ty = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar ) return () - | MetaTv _ ref <- tcTyVarDetails tyvar + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar = writeMetaTyVarRef tyvar ref ty | otherwise @@ -433,11 +458,11 @@ tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. tcInstTyVarX subst tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi + = do { uniq <- newUnique + ; details <- newMetaDetails TauTv ; let name = mkSystemName uniq (getOccName tyvar) kind = substTy subst (tyVarKind tyvar) - new_tv = mkTcTyVar name kind (MetaTv TauTv ref) + new_tv = mkTcTyVar name kind details ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } \end{code} @@ -548,7 +573,7 @@ zonkQuantifiedTyVar tv -- It might be a skolem type variable, -- for example from a user type signature - MetaTv _ ref -> + MetaTv { mtv_ref = ref } -> do when debugIsOn $ do -- [Sept 04] Check for non-empty. -- See note [Silly Type Synonym] @@ -593,60 +618,148 @@ skolemiseSigTv tv \begin{code} zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_skols = skols - , ic_given = given +zonkImplication implic@(Implic { ic_untch = untch + , ic_binds = binds_var + , ic_skols = skols + , ic_given = given , ic_wanted = wanted - , ic_loc = loc }) + , ic_info = info }) = do { skols' <- mapM zonkTcTyVarBndr skols -- Need to zonk their kinds! -- as Trac #7230 showed ; given' <- mapM zonkEvVar given - ; loc' <- zonkGivenLoc loc - ; wanted' <- zonkWC wanted + ; info' <- zonkSkolemInfo info + ; wanted' <- zonkWCRec binds_var untch wanted ; return (implic { ic_skols = skols' , ic_given = given' + , ic_fsks = [] -- Zonking removes all FlatSkol tyvars , ic_wanted = wanted' - , ic_loc = loc' }) } + , ic_info = info' }) } zonkEvVar :: EvVar -> TcM EvVar zonkEvVar var = do { ty' <- zonkTcType (varType var) ; return (setVarType var ty') } -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = do { flat' <- mapBagM zonkCt flat +zonkWC :: EvBindsVar -- May add new bindings for wanted family equalities in here + -> WantedConstraints -> TcM WantedConstraints +zonkWC binds_var wc + = do { untch <- getUntouchables + ; zonkWCRec binds_var untch wc } + +zonkWCRec :: EvBindsVar + -> Untouchables + -> WantedConstraints -> TcM WantedConstraints +zonkWCRec binds_var untch (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) + = do { flat' <- zonkFlats binds_var untch flat ; implic' <- mapBagM zonkImplication implic - ; insol' <- mapBagM zonkCt insol + ; insol' <- zonkCts insol -- No need to do the more elaborate zonkFlats thing ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) } -zonkCt :: Ct -> TcM Ct --- Zonking a Ct conservatively gives back a CNonCanonical -zonkCt ct - = do { fl' <- zonkCtEvidence (cc_ev ct) - ; return $ - CNonCanonical { cc_ev = fl' - , cc_depth = cc_depth ct } } +zonkFlats :: EvBindsVar -> Untouchables -> Cts -> TcM Cts +-- This zonks and unflattens a bunch of flat constraints +-- See Note [Unflattening while zonking] +zonkFlats binds_var untch cts + = do { -- See Note [How to unflatten] + cts <- foldrBagM unflatten_one emptyCts cts + ; zonkCts cts } + where + unflatten_one orig_ct cts + = do { zct <- zonkCt orig_ct -- First we need to fully zonk + ; mct <- try_zonk_fun_eq orig_ct zct -- Then try to solve if family equation + ; return $ maybe cts (`consBag` cts) mct } + + try_zonk_fun_eq orig_ct zct -- See Note [How to unflatten] + | EqPred ty_lhs ty_rhs <- classifyPredType (ctPred zct) + -- NB: zonking de-classifies the constraint, + -- so we can't look for CFunEqCan + , Just tv <- getTyVar_maybe ty_rhs + , ASSERT2( not (isFloatedTouchableMetaTyVar untch tv), ppr tv ) + isTouchableMetaTyVar untch tv + , typeKind ty_lhs `tcIsSubKind` tyVarKind tv + , not (tv `elemVarSet` tyVarsOfType ty_lhs) +-- , Just ty_lhs' <- occurCheck tv ty_lhs + = ASSERT2( isWantedCt orig_ct, ppr orig_ct ) + ASSERT2( case tcSplitTyConApp_maybe ty_lhs of { Just (tc,_) -> isSynFamilyTyCon tc; _ -> False }, ppr orig_ct ) + do { writeMetaTyVar tv ty_lhs + ; let evterm = EvCoercion (mkTcReflCo ty_lhs) + evvar = ctev_evar (cc_ev zct) + ; addTcEvBind binds_var evvar evterm + ; traceTc "zonkFlats/unflattening" $ + vcat [ text "zct = " <+> ppr zct, + text "binds_var = " <+> ppr binds_var ] + ; return Nothing } + | otherwise + = return (Just zct) +\end{code} + +Note [Unflattening while zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bunch of wanted constraints could contain wanted equations of the form +(F taus ~ alpha) where alpha is either an ordinary unification variable, or +a flatten unification variable. + +These are ordinary wanted constraints and can/should be solved by +ordinary unification alpha := F taus. However the constraint solving +algorithm does not do that, as their 'inert' form is F taus ~ alpha. + +Hence, we need an extra step to 'unflatten' these equations by +performing unification. This unification, if it happens at the end of +constraint solving, cannot produce any more interactions in the +constraint solver so it is safe to do it as the very very last step. + +We choose therefore to do it during zonking, in the function +zonkFlats. This is in analgoy to the zonking of given flatten skolems +which are eliminated in favor of the underlying type that they are +equal to. + +Note that, because we now have to affect *evidence* while zonking +(setting some evidence binds to identities), we have to pass to the +zonkWC function an evidence variable to collect all the extra +variables. + +Note [How to unflatten] +~~~~~~~~~~~~~~~~~~~~~~~ +How do we unflatten during zonking. Consider a bunch of flat constraints. +Consider them one by one. For each such constraint C + * Zonk C (to apply current substitution) + * If C is of form F tys ~ alpha, + where alpha is touchable + and alpha is not mentioned in tys + then unify alpha := F tys + and discard C + +After processing all the flat constraints, zonk them again to propagate +the inforamtion from later ones to earlier ones. Eg + Start: (F alpha ~ beta, G Int ~ alpha) + Then we get beta := F alpha + alpha := G Int + but we must apply the second unification to the first constraint. + + +\begin{code} zonkCts :: Cts -> TcM Cts zonkCts = mapBagM zonkCt +zonkCt :: Ct -> TcM Ct +zonkCt ct@(CHoleCan { cc_ev = ev }) + = do { ev' <- zonkCtEvidence ev + ; return $ ct { cc_ev = ev' } } +zonkCt ct + = do { fl' <- zonkCtEvidence (cc_ev ct) + ; return (CNonCanonical { cc_ev = fl' + , cc_loc = cc_loc ct }) } + zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev@(Given { ctev_gloc = loc, ctev_pred = pred }) - = do { loc' <- zonkGivenLoc loc - ; pred' <- zonkTcType pred - ; return (ctev { ctev_gloc = loc', ctev_pred = pred'}) } -zonkCtEvidence ctev@(Wanted { ctev_pred = pred }) +zonkCtEvidence ctev@(CtGiven { ctev_pred = pred }) + = do { pred' <- zonkTcType pred + ; return (ctev { ctev_pred = pred'}) } +zonkCtEvidence ctev@(CtWanted { ctev_pred = pred }) = do { pred' <- zonkTcType pred ; return (ctev { ctev_pred = pred' }) } -zonkCtEvidence ctev@(Derived { ctev_pred = pred }) +zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) = do { pred' <- zonkTcType pred ; return (ctev { ctev_pred = pred' }) } -zonkGivenLoc :: GivenLoc -> TcM GivenLoc --- GivenLocs may have unification variables inside them! -zonkGivenLoc (CtLoc skol_info span ctxt) - = do { skol_info' <- zonkSkolemInfo skol_info - ; return (CtLoc skol_info' span ctxt) } - zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty ; return (SigSkol cx ty') } @@ -789,10 +902,11 @@ zonkTcTyVar tv SkolemTv {} -> zonk_kind_and_return RuntimeUnk {} -> zonk_kind_and_return FlatSkol ty -> zonkTcType ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> zonkTcType ty } + MetaTv { mtv_ref = ref } + -> do { cts <- readMutVar ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> zonkTcType ty } where zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv ; return (TyVarTy z_tv) } diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 0d00fb68c2..d48be70038 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -771,19 +771,20 @@ checkBootTyCon tc1 tc2 eqListBy eqSig op_stuff1 op_stuff2 && eqListBy eqAT ats1 ats2) - | isSynTyCon tc1 && isSynTyCon tc2 + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 = ASSERT(tc1 == tc2) let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2 env = rnBndrs2 env0 tvs1 tvs2 - eqSynRhs SynFamilyTyCon SynFamilyTyCon - = True + eqSynRhs (SynFamilyTyCon a1 b1) (SynFamilyTyCon a2 b2) + = a1 == a2 && b1 == b2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = eqTypeX env t1 t2 eqSynRhs _ _ = False in equalLength tvs1 tvs2 && - eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2) + eqSynRhs syn_rhs1 syn_rhs2 | isAlgTyCon tc1 && isAlgTyCon tc2 = ASSERT(tc1 == tc2) @@ -1522,14 +1523,14 @@ tcRnExpr hsc_env ictxt rdr_expr -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - (((_tc_expr, res_ty), untch), lie) <- captureConstraints $ - captureUntouchables (tcInferRho rn_expr) ; + ((_tc_expr, res_ty), lie) <- captureConstraints $ + tcInferRho rn_expr ; ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} simplifyInfer True {- Free vars are closed -} False {- No MR for now -} [(fresh_it, res_ty)] - (untch,lie) ; + lie ; _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 3cfc7044c6..68301f7972 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -42,7 +42,6 @@ import NameSet import Bag import Outputable import UniqSupply -import Unique import UniqFM import DynFlags import Maybes @@ -78,7 +77,6 @@ initTc :: HscEnv initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; - meta_var <- newIORef initTyVarUnique ; tvs_var <- newIORef emptyVarSet ; keep_var <- newIORef emptyNameSet ; used_rdr_var <- newIORef Set.empty ; @@ -148,11 +146,11 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_th_ctxt = topStage, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, + tcl_bndrs = [], tcl_tidy = emptyTidyEnv, tcl_tyvars = tvs_var, tcl_lie = lie_var, - tcl_meta = meta_var, - tcl_untch = initTyVarUnique + tcl_untch = noUntouchables } ; } ; @@ -345,16 +343,6 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) %************************************************************************ \begin{code} -newMetaUnique :: TcM Unique --- The uniques for TcMetaTyVars are allocated specially --- in guaranteed linear order, starting at zero for each module -newMetaUnique - = do { env <- getLclEnv - ; let meta_var = tcl_meta env - ; uniq <- readMutVar meta_var - ; writeMutVar meta_var (incrUnique uniq) - ; return uniq } - newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; @@ -379,15 +367,8 @@ newUniqueSupply writeMutVar u_var us1 ; return us2 }}} -newLocalName :: Name -> TcRnIf gbl lcl Name -newLocalName name -- Make a clone - = do { uniq <- newUnique - ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) } - -newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] -newSysLocalIds fs tys - = do { us <- newUniqueSupply - ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } +newLocalName :: Name -> TcM Name +newLocalName name = newName (nameOccName name) newName :: OccName -> TcM Name newName occ @@ -395,6 +376,16 @@ newName occ ; loc <- getSrcSpanM ; return (mkInternalName uniq occ loc) } +newSysName :: OccName -> TcM Name +newSysName occ + = do { uniq <- newUnique + ; return (mkSystemName uniq occ) } + +newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] +newSysLocalIds fs tys + = do { us <- newUniqueSupply + ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) } + instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique getUniqueSupplyM = newUniqueSupply @@ -829,14 +820,18 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) -getCtLoc :: orig -> TcM (CtLoc orig) +getCtLoc :: CtOrigin -> TcM CtLoc getCtLoc origin - = do { loc <- getSrcSpanM ; env <- getLclEnv ; - return (CtLoc origin loc (tcl_ctxt env)) } - -setCtLoc :: CtLoc orig -> TcM a -> TcM a -setCtLoc (CtLoc _ src_loc ctxt) thing_inside - = setSrcSpan src_loc (setErrCtxt ctxt thing_inside) + = do { env <- getLclEnv + ; return (CtLoc { ctl_origin = origin, ctl_env = env, ctl_depth = 0 }) } + +setCtLoc :: CtLoc -> TcM a -> TcM a +-- Set the SrcSpan and error context from the CtLoc +setCtLoc (CtLoc { ctl_env = lcl }) thing_inside + = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl + , tcl_bndrs = tcl_bndrs lcl + , tcl_ctxt = tcl_ctxt lcl }) + thing_inside \end{code} %************************************************************************ @@ -1037,6 +1032,13 @@ emitImplications ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addImplics` ct) } +emitInsoluble :: Ct -> TcM () +emitInsoluble ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addInsols` unitBag ct) ; + v <- readTcRef lie_var ; + traceTc "emitInsoluble" (ppr v) } + captureConstraints :: TcM a -> TcM (a, WantedConstraints) -- (captureConstraints m) runs m, and returns the type constraints it generates captureConstraints thing_inside @@ -1049,20 +1051,27 @@ captureConstraints thing_inside captureUntouchables :: TcM a -> TcM (a, Untouchables) captureUntouchables thing_inside = do { env <- getLclEnv - ; low_meta <- readTcRef (tcl_meta env) - ; res <- setLclEnv (env { tcl_untch = low_meta }) + ; let untch' = pushUntouchables (tcl_untch env) + ; res <- setLclEnv (env { tcl_untch = untch' }) thing_inside - ; high_meta <- readTcRef (tcl_meta env) - ; return (res, TouchableRange low_meta high_meta) } + ; return (res, untch') } + +getUntouchables :: TcM Untouchables +getUntouchables = do { env <- getLclEnv + ; return (tcl_untch env) } + +setUntouchables :: Untouchables -> TcM a -> TcM a +setUntouchables untch thing_inside + = updLclEnv (\env -> env { tcl_untch = untch }) thing_inside -isUntouchable :: TcTyVar -> TcM Bool -isUntouchable tv +isTouchableTcM :: TcTyVar -> TcM Bool +isTouchableTcM tv -- Kind variables are always touchable | isSuperKind (tyVarKind tv) = return False | otherwise = do { env <- getLclEnv - ; return (varUnique tv < tcl_untch env) } + ; return (isTouchableMetaTyVar (tcl_untch env) tv) } getLclTypeEnv :: TcM TcTypeEnv getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 035833c9a6..aa5dec9bd2 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -38,7 +38,7 @@ module TcRnTypes( WhereFrom(..), mkModDeps, -- Typechecker types - TcTypeEnv, TcTyThing(..), PromotionErr(..), + TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..), pprTcTyThingCategory, pprPECategory, -- Template Haskell @@ -48,33 +48,33 @@ module TcRnTypes( -- Arrows ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, - -- Constraints - Untouchables(..), inTouchableRange, isNoUntouchables, - -- Canonical constraints - Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, keepWanted, + Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC, singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan, isCDictCan_Maybe, isCFunEqCan_Maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt, - ctWantedLoc, ctEvidence, - SubGoalDepth, mkNonCanonical, ctPred, ctEvPred, ctEvTerm, ctEvId, + isGivenCt, isHoleCt, + ctEvidence, + SubGoalDepth, mkNonCanonical, mkNonCanonicalCt, + ctPred, ctEvPred, ctEvTerm, ctEvId, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, - andWC, addFlats, addImplics, mkFlatWC, + andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols, Implication(..), - CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, - CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, pushErrCtxt, - pushErrCtxtSameOrigin, + CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, + ctLocDepth, bumpCtLocDepth, + setCtLocOrigin, + CtOrigin(..), + pushErrCtxt, pushErrCtxtSameOrigin, SkolemInfo(..), - CtEvidence(..), pprFlavorArising, + CtEvidence(..), mkGivenLoc, isWanted, isGiven, - isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite, + isDerived, canSolve, canRewrite, + CtFlavour(..), ctEvFlavour, ctFlavour, -- Pretty printing pprEvVarTheta, pprWantedsWithLocs, @@ -113,17 +113,14 @@ import VarSet import ErrUtils import UniqFM import UniqSupply -import Unique import BasicTypes import Bag import DynFlags import Outputable import ListSetOps import FastString -import Util import Data.Set (Set) - \end{code} @@ -410,12 +407,11 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is data TcLclEnv -- Changes as we move inside an expression -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { - tcl_loc :: SrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_errs :: TcRef Messages, -- Place to accumulate errors - - tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + tcl_loc :: SrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + tcl_untch :: Untouchables, -- Birthplace for new unification variables + tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context tcl_rdr :: LocalRdrEnv, -- Local name envt -- Maintained during renaming, of course, but also during @@ -429,8 +425,11 @@ data TcLclEnv -- Changes as we move inside an expression -- We still need the unsullied global name env so that -- we can look up record field names - tcl_env :: TcTypeEnv, -- The local type environment: Ids and - -- TyVars defined in this module + tcl_env :: TcTypeEnv, -- The local type environment: + -- Ids and TyVars defined in this module + + tcl_bndrs :: [TcIdBinder], -- Stack of locally-bound Ids, innermost on top + -- Used only for error reporting tcl_tidy :: TidyEnv, -- Used for tidying types; contains all -- in-scope type variables (but not term variables) @@ -441,18 +440,12 @@ data TcLclEnv -- Changes as we move inside an expression -- in tcl_lenv. -- Why mutable? see notes with tcGetGlobalTyVars - tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - - -- TcMetaTyVars have - tcl_meta :: TcRef Unique, -- The next free unique for TcMetaTyVars - -- Guaranteed to be allocated linearly - tcl_untch :: Unique -- Any TcMetaTyVar with - -- unique >= tcl_untch is touchable - -- unique < tcl_untch is untouchable + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef Messages -- Place to accumulate errors } type TcTypeEnv = NameEnv TcTyThing - +data TcIdBinder = TcIdBndr TcId TopLevelFlag {- Note [Given Insts] ~~~~~~~~~~~~~~~~~~ @@ -523,7 +516,8 @@ thLevel (Brack s _ _) = thLevel s + 1 -- Arrow-notation context --------------------------- -{- +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In arrow notation, a variable bound by a proc (or enclosed let/kappa) is not in scope to the left of an arrow tail (-<) or the head of (|..|). For example @@ -536,10 +530,15 @@ a bit complicated: let x = 3 in proc y -> (proc z -> e1) -< e2 -Here, x and z are in scope in e1, but y is not. We implement this by +Here, x and z are in scope in e1, but y is not. + +We implement this by recording the environment when passing a proc (using newArrowScope), and returning to that (using escapeArrowScope) on the left of -< and the head of (|..|). + +All this can be dealt with by the *renamer*; by the time we get to +the *type checker* we have sorted out the scopes -} data ArrowCtxt @@ -851,9 +850,6 @@ type Xi = Type -- In many comments, "xi" ranges over Xi type Cts = Bag Ct -type SubGoalDepth = Int -- An ever increasing number used to restrict - -- simplifier iterations. Bounded by -fcontext-stack. - data Ct -- Atomic canonical constraints = CDictCan { -- e.g. Num xi @@ -861,17 +857,17 @@ data Ct cc_class :: Class, cc_tyargs :: [Xi], - cc_depth :: SubGoalDepth -- Simplification depth of this constraint - -- See Note [WorkList] + cc_loc :: CtLoc } | CIrredEvCan { -- These stand for yet-unknown predicates cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_ty :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin) - -- Since, if it were a type constructor application, that'd make the - -- whole constraint a CDictCan, or CTyEqCan. And it can't be - -- a type family application either because it's a Xi type. - cc_depth :: SubGoalDepth -- See Note [WorkList] + -- In CIrredEvCan, the ctev_pred of the evidence is flat + -- and hence it may only be of the form (tv xi1 xi2 ... xin) + -- Since, if it were a type constructor application, that'd make the + -- whole constraint a CDictCan, or CTyEqCan. And it can't be + -- a type family application either because it's a Xi type. + cc_loc :: CtLoc } | CTyEqCan { -- tv ~ xi (recall xi means function free) @@ -883,26 +879,30 @@ data Ct cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_tyvar :: TcTyVar, cc_rhs :: Xi, - - cc_depth :: SubGoalDepth -- See Note [WorkList] + cc_loc :: CtLoc } | CFunEqCan { -- F xis ~ xi -- Invariant: * isSynFamilyTyCon cc_fun -- * typeKind (F xis) `compatKind` typeKind xi - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_fun :: TyCon, -- A type function cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated cc_rhs :: Xi, -- *never* over-saturated (because if so -- we should have decomposed) - cc_depth :: SubGoalDepth -- See Note [WorkList] + cc_loc :: CtLoc } | CNonCanonical { -- See Note [NonCanonical Semantics] - cc_ev :: CtEvidence, - cc_depth :: SubGoalDepth + cc_ev :: CtEvidence, + cc_loc :: CtLoc + } + + | CHoleCan { + cc_ev :: CtEvidence, + cc_loc :: CtLoc } \end{code} @@ -915,8 +915,11 @@ This holds by construction; look at the unique place where CDictCan is built (in TcCanonical) \begin{code} -mkNonCanonical :: CtEvidence -> Ct -mkNonCanonical flav = CNonCanonical { cc_ev = flav, cc_depth = 0} +mkNonCanonical :: CtLoc -> CtEvidence -> Ct +mkNonCanonical loc ev = CNonCanonical { cc_ev = ev, cc_loc = loc } + +mkNonCanonicalCt :: Ct -> Ct +mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct, cc_loc = cc_loc ct } ctEvidence :: Ct -> CtEvidence ctEvidence = cc_ev @@ -925,11 +928,12 @@ ctPred :: Ct -> PredType -- See Note [Ct/evidence invariant] ctPred ct = ctEvPred (cc_ev ct) -keepWanted :: Cts -> Cts -keepWanted = filterBag isWantedCt - -- DV: there used to be a note here that read: - -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' - -- DV: Is this still relevant? +dropDerivedWC :: WantedConstraints -> WantedConstraints +dropDerivedWC wc@(WC { wc_flat = flats }) + = wc { wc_flat = filterBag isWantedCt flats } + -- Don't filter the insolubles, because derived + -- insolubles should stay so that we report them. + -- The implications are (recursively) already filtered \end{code} @@ -941,11 +945,6 @@ keepWanted = filterBag isWantedCt %************************************************************************ \begin{code} -ctWantedLoc :: Ct -> WantedLoc --- Only works for Wanted/Derived -ctWantedLoc ct = ASSERT2( not (isGiven (cc_ev ct)), ppr ct ) - getWantedLoc (cc_ev ct) - isWantedCt :: Ct -> Bool isWantedCt = isWanted . cc_ev @@ -979,18 +978,23 @@ isCFunEqCan _ = False isCNonCanonical :: Ct -> Bool isCNonCanonical (CNonCanonical {}) = True isCNonCanonical _ = False + +isHoleCt:: Ct -> Bool +isHoleCt (CHoleCan {}) = True +isHoleCt _ = False + \end{code} \begin{code} instance Outputable Ct where - ppr ct = ppr (cc_ev ct) <+> - braces (ppr (cc_depth ct)) <+> parens (text ct_sort) + ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort) where ct_sort = case ct of CTyEqCan {} -> "CTyEqCan" CFunEqCan {} -> "CFunEqCan" CNonCanonical {} -> "CNonCanonical" CDictCan {} -> "CDictCan" CIrredEvCan {} -> "CIrredEvCan" + CHoleCan {} -> "CHoleCan" \end{code} \begin{code} @@ -1057,6 +1061,9 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) , wc_impl = i1 `unionBags` i2 , wc_insol = n1 `unionBags` n2 } +unionsWC :: [WantedConstraints] -> WantedConstraints +unionsWC = foldr andWC emptyWC + addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints addFlats wc cts = wc { wc_flat = wc_flat wc `unionBags` cts } @@ -1064,6 +1071,10 @@ addFlats wc cts addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } +addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints +addInsols wc cts + = wc { wc_insol = wc_insol wc `unionBags` cts } + instance Outputable WantedConstraints where ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n}) = ptext (sLit "WC") <+> braces (vcat @@ -1079,38 +1090,6 @@ pprBag pp b = foldrBag (($$) . pp) empty b \end{code} -\begin{code} -data Untouchables = NoUntouchables - | TouchableRange - Unique -- Low end - Unique -- High end - -- A TcMetaTyvar is *touchable* iff its unique u satisfies - -- u >= low - -- u < high - -instance Outputable Untouchables where - ppr NoUntouchables = ptext (sLit "No untouchables") - ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+> - ppr low <+> char '-' <+> ppr high - -isNoUntouchables :: Untouchables -> Bool -isNoUntouchables NoUntouchables = True -isNoUntouchables (TouchableRange {}) = False - -inTouchableRange :: Untouchables -> TcTyVar -> Bool -inTouchableRange NoUntouchables _ = True -inTouchableRange (TouchableRange low high) tv - = uniq >= low && uniq < high - where - uniq = varUnique tv - --- EvVar defined in module Var.lhs: --- Evidence variables include all *quantifiable* constraints --- dictionaries --- implicit parameters --- coercion variables -\end{code} - %************************************************************************ %* * Implication constraints @@ -1122,20 +1101,20 @@ data Implication = Implic { ic_untch :: Untouchables, -- Untouchables: unification variables -- free in the environment - ic_env :: TcTypeEnv, -- The type environment - -- Used only when generating error messages - -- Generally, ic_untch is a superset of tvsof(ic_env) - -- However, we don't zonk ic_env when zonking the Implication - -- Instead we do that when generating a skolem-escape error message ic_skols :: [TcTyVar], -- Introduced skolems - -- See Note [Skolems in an implication] + ic_info :: SkolemInfo, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + + ic_fsks :: [TcTyVar], -- Extra flatten-skolems introduced by the flattening + -- done by canonicalisation. ic_given :: [EvVar], -- Given evidence variables -- (order does not matter) - ic_loc :: GivenLoc, -- Binding location of the implication, - -- which is also the location of all the - -- given evidence variables + + ic_env :: TcLclEnv, -- Gives the source location and error context + -- for the implicatdion, and hence for all the + -- given evidence variables ic_wanted :: WantedConstraints, -- The wanted ic_insol :: Bool, -- True iff insolubleWC ic_wanted is true @@ -1145,19 +1124,32 @@ data Implication } instance Outputable Implication where - ppr (Implic { ic_untch = untch, ic_skols = skols, ic_given = given + ppr (Implic { ic_untch = untch, ic_skols = skols, ic_fsks = fsks + , ic_given = given , ic_wanted = wanted - , ic_binds = binds, ic_loc = loc }) + , ic_binds = binds, ic_info = info }) = ptext (sLit "Implic") <+> braces - (sep [ ptext (sLit "Untouchables = ") <+> ppr untch - , ptext (sLit "Skolems = ") <+> ppr skols - , ptext (sLit "Given = ") <+> pprEvVars given - , ptext (sLit "Wanted = ") <+> ppr wanted - , ptext (sLit "Binds = ") <+> ppr binds - , pprSkolInfo (ctLocOrigin loc) - , ppr (ctLocSpan loc) ]) + (sep [ ptext (sLit "Untouchables =") <+> ppr untch + , ptext (sLit "Skolems =") <+> ppr skols + , ptext (sLit "Flatten-skolems =") <+> ppr fsks + , ptext (sLit "Given =") <+> pprEvVars given + , ptext (sLit "Wanted =") <+> ppr wanted + , ptext (sLit "Binds =") <+> ppr binds + , pprSkolInfo info ]) \end{code} +Note [Shadowing in a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We assume NO SHADOWING in a constraint. Specifically + * The unification variables are all implicitly quantified at top + level, and are all unique + * The skolem varibles bound in ic_skols are all freah when the + implication is created. +So we can safely substitute. For example, if we have + forall a. a~Int => ...(forall b. ...a...)... +we can push the (a~Int) constraint inwards in the "givens" without +worrying that 'b' might clash. + Note [Skolems in an implication] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The skolems in an implication are not there to perform a skolem escape @@ -1224,7 +1216,7 @@ pprWantedsWithLocs wcs %************************************************************************ %* * - CtLoc + CtEvidence %* * %************************************************************************ @@ -1236,70 +1228,69 @@ may be un-zonked. \begin{code} data CtEvidence - = Given { ctev_gloc :: GivenLoc - , ctev_pred :: TcPredType - , ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence] + = CtGiven { ctev_pred :: TcPredType + , ctev_evtm :: EvTerm } -- See Note [Evidence field of CtEvidence] -- Truly given, not depending on subgoals -- NB: Spontaneous unifications belong here - | Wanted { ctev_wloc :: WantedLoc - , ctev_pred :: TcPredType - , ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence] + | CtWanted { ctev_pred :: TcPredType + , ctev_evar :: EvVar } -- See Note [Evidence field of CtEvidence] -- Wanted goal - | Derived { ctev_wloc :: WantedLoc - , ctev_pred :: TcPredType } + | CtDerived { ctev_pred :: TcPredType } -- A goal that we don't really have to solve and can't immediately -- rewrite anything other than a derived (there's no evidence!) -- but if we do manage to solve it may help in solving other goals. +data CtFlavour = Given | Wanted | Derived + +ctFlavour :: Ct -> CtFlavour +ctFlavour ct = ctEvFlavour (cc_ev ct) + +ctEvFlavour :: CtEvidence -> CtFlavour +ctEvFlavour (CtGiven {}) = Given +ctEvFlavour (CtWanted {}) = Wanted +ctEvFlavour (CtDerived {}) = Derived + ctEvPred :: CtEvidence -> TcPredType -- The predicate of a flavor ctEvPred = ctev_pred ctEvTerm :: CtEvidence -> EvTerm -ctEvTerm (Given { ctev_evtm = tm }) = tm -ctEvTerm (Wanted { ctev_evar = ev }) = EvId ev -ctEvTerm ctev@(Derived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" +ctEvTerm (CtGiven { ctev_evtm = tm }) = tm +ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev +ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" (ppr ctev) ctEvId :: CtEvidence -> TcId -ctEvId (Wanted { ctev_evar = ev }) = ev +ctEvId (CtWanted { ctev_evar = ev }) = ev ctEvId ctev = pprPanic "ctEvId:" (ppr ctev) +instance Outputable CtFlavour where + ppr Given = ptext (sLit "[G]") + ppr Wanted = ptext (sLit "[W]") + ppr Derived = ptext (sLit "[D]") + instance Outputable CtEvidence where ppr fl = case fl of - Given {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty - Wanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty - Derived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty + CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty + CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty + CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty where ppr_pty = dcolon <+> ppr (ctEvPred fl) -getWantedLoc :: CtEvidence -> WantedLoc --- Precondition: Wanted or Derived -getWantedLoc fl = ctev_wloc fl - -getGivenLoc :: CtEvidence -> GivenLoc --- Precondition: Given -getGivenLoc fl = ctev_gloc fl - -pprFlavorArising :: CtEvidence -> SDoc -pprFlavorArising (Given { ctev_gloc = gl }) = pprArisingAt gl -pprFlavorArising ctev = pprArisingAt (ctev_wloc ctev) - - isWanted :: CtEvidence -> Bool -isWanted (Wanted {}) = True +isWanted (CtWanted {}) = True isWanted _ = False isGiven :: CtEvidence -> Bool -isGiven (Given {}) = True +isGiven (CtGiven {}) = True isGiven _ = False isDerived :: CtEvidence -> Bool -isDerived (Derived {}) = True -isDerived _ = False +isDerived (CtDerived {}) = True +isDerived _ = False -canSolve :: CtEvidence -> CtEvidence -> Bool +canSolve :: CtFlavour -> CtFlavour -> Bool -- canSolve ctid1 ctid2 -- The constraint ctid1 can be used to solve ctid2 -- "to solve" means a reaction where the active parts of the two constraints match. @@ -1310,19 +1301,16 @@ canSolve :: CtEvidence -> CtEvidence -> Bool -- -- NB: either (a `canSolve` b) or (b `canSolve` a) must hold ----------------------------------------- -canSolve (Given {}) _ = True -canSolve (Wanted {}) (Derived {}) = True -canSolve (Wanted {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True -- Derived can't solve wanted/given +canSolve Given _ = True +canSolve Wanted Derived = True +canSolve Wanted Wanted = True +canSolve Derived Derived = True -- Derived can't solve wanted/given canSolve _ _ = False -- No evidence for a derived, anyway -canRewrite :: CtEvidence -> CtEvidence -> Bool +canRewrite :: CtFlavour -> CtFlavour -> Bool -- canRewrite ct1 ct2 -- The equality constraint ct1 can be used to rewrite inside ct2 canRewrite = canSolve - -mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc -mkGivenLoc wl sk = setCtLocOrigin wl sk \end{code} %************************************************************************ @@ -1337,26 +1325,49 @@ dictionaries don't appear in the original source code. type will evolve... \begin{code} -data CtLoc orig = CtLoc orig SrcSpan [ErrCtxt] +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: TcLclEnv + , ctl_depth :: SubGoalDepth } + -- The TcLclEnv includes particularly + -- source location: tcl_loc :: SrcSpan + -- context: tcl_ctxt :: [ErrCtxt] + -- binder stack: tcl_bndrs :: [TcIdBinders] + +type SubGoalDepth = Int -- An ever increasing number used to restrict + -- simplifier iterations. Bounded by -fcontext-stack. + -- See Note [WorkList] + +mkGivenLoc :: SkolemInfo -> TcLclEnv -> CtLoc +mkGivenLoc skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = env + , ctl_depth = 0 } + +ctLocEnv :: CtLoc -> TcLclEnv +ctLocEnv = ctl_env -type WantedLoc = CtLoc CtOrigin -- Instantiation for wanted constraints -type GivenLoc = CtLoc SkolemInfo -- Instantiation for given constraints +ctLocDepth :: CtLoc -> SubGoalDepth +ctLocDepth = ctl_depth -ctLocSpan :: CtLoc o -> SrcSpan -ctLocSpan (CtLoc _ s _) = s +ctLocOrigin :: CtLoc -> CtOrigin +ctLocOrigin = ctl_origin -ctLocOrigin :: CtLoc o -> o -ctLocOrigin (CtLoc o _ _) = o +ctLocSpan :: CtLoc -> SrcSpan +ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl -setCtLocOrigin :: CtLoc o -> o' -> CtLoc o' -setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c +bumpCtLocDepth :: CtLoc -> CtLoc +bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = d+1 } -pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig -pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs) +setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc +setCtLocOrigin ctl orig = ctl { ctl_origin = orig } -pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc orig -> CtLoc orig +pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc +pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc -- Just add information w/o updating the origin! -pushErrCtxtSameOrigin err (CtLoc o s errs) = CtLoc o s (err:errs) +pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } pprArising :: CtOrigin -> SDoc -- Used for the main, top-level error message @@ -1365,9 +1376,10 @@ pprArising (TypeEqOrigin {}) = empty pprArising FunDepOrigin = empty pprArising orig = text "arising from" <+> ppr orig -pprArisingAt :: Outputable o => CtLoc o -> SDoc -pprArisingAt (CtLoc o s _) = sep [ text "arising from" <+> ppr o - , text "at" <+> ppr s] +pprArisingAt :: CtLoc -> SDoc +pprArisingAt (CtLoc { ctl_origin = o, ctl_env = lcl}) + = sep [ text "arising from" <+> ppr o + , text "at" <+> ppr (tcl_loc lcl)] \end{code} %************************************************************************ @@ -1459,14 +1471,20 @@ pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "Unk %************************************************************************ \begin{code} --- CtOrigin gives the origin of *wanted* constraints data CtOrigin - = OccurrenceOf Name -- Occurrence of an overloaded identifier + = GivenOrigin SkolemInfo + + -- All the others are for *wanted* constraints + | OccurrenceOf Name -- Occurrence of an overloaded identifier | AppOrigin -- An application of some kind | SpecPragOrigin Name -- Specialisation pragma for identifier - | TypeEqOrigin EqOrigin + | TypeEqOrigin { uo_actual :: TcType + , uo_expected :: TcType } + | KindEqOrigin + TcType TcType -- A kind equality arising from unifying these two types + CtOrigin -- originally arising from this | IPOccOrigin HsIPName -- Occurrence of an implicit parameter @@ -1494,16 +1512,10 @@ data CtOrigin | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation | FunDepOrigin - -data EqOrigin - = UnifyOrigin - { uo_actual :: TcType - , uo_expected :: TcType } - -instance Outputable CtOrigin where - ppr orig = pprO orig + | HoleOrigin pprO :: CtOrigin -> SDoc +pprO (GivenOrigin sk) = ppr sk pprO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] pprO AppOrigin = ptext (sLit "an application") pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)] @@ -1528,11 +1540,13 @@ pprO DefaultOrigin = ptext (sLit "a 'default' declaration") pprO DoOrigin = ptext (sLit "a do statement") pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension") pprO ProcOrigin = ptext (sLit "a proc expression") -pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq +pprO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] +pprO (KindEqOrigin t1 t2 _) = ptext (sLit "a kind equality arising from") <+> sep [ppr t1, char '~', ppr t2] pprO AnnOrigin = ptext (sLit "an annotation") pprO FunDepOrigin = ptext (sLit "a functional dependency") +pprO HoleOrigin = ptext (sLit "a use of the hole") <+> quotes (ptext $ sLit "_") -instance Outputable EqOrigin where - ppr (UnifyOrigin t1 t2) = ppr t1 <+> char '~' <+> ppr t2 +instance Outputable CtOrigin where + ppr = pprO \end{code} diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index f4f8c96964..1a569d02c7 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -26,7 +26,6 @@ import TcEnv import TcEvidence( TcEvBinds(..) ) import Type import Id -import NameEnv( emptyNameEnv ) import Name import Var import VarSet @@ -139,10 +138,10 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Note [Typechecking rules] ; vars <- tcRuleBndrs hs_bndrs - ; let (id_bndrs, tv_bndrs) = partition (isId . snd) vars + ; let (id_bndrs, tv_bndrs) = partition isId vars ; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) - <- tcExtendTyVarEnv2 tv_bndrs $ - tcExtendIdEnv2 id_bndrs $ + <- tcExtendTyVarEnv tv_bndrs $ + tcExtendIdEnv id_bndrs $ do { ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) ; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty) ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) } @@ -161,7 +160,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- the LHS, lest they otherwise get defaulted to Any; but we do that -- during zonking (see TcHsSyn.zonkRule) - ; let tpl_ids = lhs_evs ++ map snd id_bndrs + ; let tpl_ids = lhs_evs ++ id_bndrs forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) ; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked @@ -178,54 +177,61 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ]) -- Simplify the RHS constraints - ; loc <- getCtLoc (RuleSkol name) + ; lcl_env <- getLclEnv ; rhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_untch = NoUntouchables - , ic_env = emptyNameEnv + ; emitImplication $ Implic { ic_untch = noUntouchables , ic_skols = qtkvs + , ic_fsks = [] , ic_given = lhs_evs , ic_wanted = rhs_wanted , ic_insol = insolubleWC rhs_wanted , ic_binds = rhs_binds_var - , ic_loc = loc } + , ic_info = RuleSkol name + , ic_env = lcl_env } -- For the LHS constraints we must solve the remaining constraints -- (a) so that we report insoluble ones -- (b) so that we bind any soluble ones ; lhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_untch = NoUntouchables - , ic_env = emptyNameEnv + ; emitImplication $ Implic { ic_untch = noUntouchables , ic_skols = qtkvs + , ic_fsks = [] , ic_given = lhs_evs , ic_wanted = other_lhs_wanted , ic_insol = insolubleWC other_lhs_wanted , ic_binds = lhs_binds_var - , ic_loc = loc } + , ic_info = RuleSkol name + , ic_env = lcl_env } ; return (HsRule name act (map (RuleBndr . noLoc) (qtkvs ++ tpl_ids)) (mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs (mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) } -tcRuleBndrs :: [RuleBndr Name] -> TcM [(Name, Var)] +tcRuleBndrs :: [RuleBndr Name] -> TcM [Var] tcRuleBndrs [] = return [] tcRuleBndrs (RuleBndr (L _ name) : rule_bndrs) = do { ty <- newFlexiTyVarTy openTypeKind ; vars <- tcRuleBndrs rule_bndrs - ; return ((name, mkLocalId name ty) : vars) } + ; return (mkLocalId name ty : vars) } tcRuleBndrs (RuleBndrSig (L _ name) rn_ty : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a = do { let ctxt = RuleSigCtxt name - ; (id_ty, skol_tvs) <- tcHsPatSigType ctxt rn_ty - ; let id = mkLocalId name id_ty + ; (id_ty, tv_prs) <- tcHsPatSigType ctxt rn_ty + ; let id = mkLocalId name id_ty + tvs = map snd tv_prs + -- tcHsPatSigType returns (Name,TyVar) pairs + -- for for RuleSigCtxt their Names are not + -- cloned, so we get (n, tv-with-name-n) pairs + -- See Note [Pattern signature binders] in TcHsType -- The type variables scope over subsequent bindings; yuk - ; vars <- tcExtendTyVarEnv2 skol_tvs $ + ; vars <- tcExtendTyVarEnv tvs $ tcRuleBndrs rule_bndrs - ; return (skol_tvs ++ (name, id) : vars) } + ; return (tvs ++ id : vars) } ruleCtxt :: FastString -> SDoc ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index f6f1c7878b..63c475d24a 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1,5 +1,5 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# OPTIONS -fno-warn-tabs -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -13,32 +13,31 @@ module TcSMonad ( WorkList(..), isEmptyWorkList, emptyWorkList, workListFromEq, workListFromNonEq, workListFromCt, - extendWorkListEq, extendWorkListNonEq, extendWorkListCt, - appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem, + extendWorkListEq, extendWorkListFunEq, + extendWorkListNonEq, extendWorkListCt, + extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem, + withWorkList, workListSize, - getTcSWorkList, updWorkListTcS, updWorkListTcS_return, - getTcSWorkListTvs, + updWorkListTcS, updWorkListTcS_return, - getTcSImplics, updTcSImplics, emitTcSImplication, + updTcSImplics, - Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, - emitFrozenError, + Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, + emitInsoluble, isWanted, isDerived, - isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising, - - isFlexiTcsTv, instFlexiTcSHelperTcS, + isGivenCt, isWantedCt, isDerivedCt, canRewrite, canSolve, - mkGivenLoc, ctWantedLoc, + mkGivenLoc, TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality - traceFireTcS, bumpStepCountTcS, doWithInert, - tryTcS, nestImplicTcS, recoverTcS, + traceFireTcS, bumpStepCountTcS, + tryTcS, nestTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS, -- Getting and setting the flattening cache - getFlatCache, updFlatCache, addToSolved, addSolvedFunEq, + addSolvedDict, addSolvedFunEq, getFlattenSkols, deferTcSForAllEq, @@ -46,11 +45,10 @@ module TcSMonad ( XEvTerm(..), MaybeNew (..), isFresh, freshGoals, getEvTerms, - xCtFlavor, -- Transform a CtEvidence during a step - rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions - newWantedEvVar, instDFunConstraints, + xCtFlavor, -- Transform a CtEvidence during a step + rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions + newWantedEvVar, newWantedEvVarNC, instDFunConstraints, newDerived, - xCtFlavor_cache, rewriteCtFlavor_cache, -- Creation of evidence variables setWantedTyBind, @@ -60,35 +58,37 @@ module TcSMonad ( getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap, - newFlattenSkolemTy, -- Flatten skolems + lookupFlatEqn, newFlattenSkolem, -- Flatten skolems + + -- Deque + Deque(..), insertDeque, emptyDeque, -- Inerts InertSet(..), InertCans(..), - getInertEqs, getCtCoercion, + getInertEqs, emptyInert, getTcSInerts, lookupInInerts, - getInertUnsolved, getInertInsols, splitInertsForImplications, + getInertUnsolved, checkAllSolved, + prepareInertsForImplications, modifyInertTcS, - updInertSetTcS, partitionCCanMap, partitionEqMap, + insertInertItemTcS, partitionCCanMap, partitionEqMap, getRelevantCts, extractRelevantInerts, CCanMap(..), CtTypeMap, CtFamHeadMap, CtPredMap, PredMap, FamHeadMap, - partCtFamHeadMap, lookupFamHead, + partCtFamHeadMap, lookupFamHead, lookupSolvedDict, filterSolved, instDFunType, -- Instantiation - newFlexiTcSTy, instFlexiTcS, + newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS, + cloneMetaTyVar, compatKind, mkKindErrorCtxtTcS, - TcsUntouchables, - isTouchableMetaTyVar, - isTouchableMetaTyVar_InRange, + Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe, getDefaultInfo, getDynFlags, matchClass, matchFam, MatchInstResult (..), checkWellStagedDFun, - warnTcS, pprEq -- Smaller utils, re-exported from TcM -- TODO (DV): these are only really used in the -- instance matcher in TcSimplify. I am wondering @@ -125,7 +125,6 @@ import VarEnv import Outputable import Bag import MonadUtils -import VarSet import FastString import Util @@ -134,17 +133,18 @@ import TcRnTypes import Unique import UniqFM -#ifdef DEBUG -import Digraph -#endif -import Maybes ( orElse, catMaybes ) - +import Maybes ( orElse, catMaybes, firstJust ) +import StaticFlags( opt_NoFlatCache ) import Control.Monad( unless, when, zipWithM ) -import StaticFlags( opt_PprStyle_Debug ) import Data.IORef import TrieMap +#ifdef DEBUG +import StaticFlags( opt_PprStyle_Debug ) +import VarSet +import Digraph +#endif \end{code} @@ -169,8 +169,8 @@ mkKindErrorCtxtTcS ty1 ki1 ty2 ki2 %* * %************************************************************************ -Note [WorkList] -~~~~~~~~~~~~~~~ +Note [WorkList priorities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ A WorkList contains canonical and non-canonical items (of all flavors). Notice that each Ct now has a simplification depth. We may consider using this depth for prioritization as well in the future. @@ -181,6 +181,7 @@ so that it's easier to deal with them first, but the separation is not strictly necessary. Notice that non-canonical constraints are also parts of the worklist. + Note [NonCanonical Semantics] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that canonical constraints involve a CNonCanonical constructor. In the worklist @@ -196,29 +197,68 @@ be rewritten by equalities (for instance if a non canonical exists in the inert, better rewrite it as much as possible before reporting it as an error to the user) \begin{code} +data Deque a = DQ [a] [a] -- Insert in RH field, remove from LH field + -- First to remove is at head of LH field --- See Note [WorkList] +instance Outputable a => Outputable (Deque a) where + ppr (DQ as bs) = ppr (as ++ reverse bs) -- Show first one to come out at the start + +emptyDeque :: Deque a +emptyDeque = DQ [] [] + +isEmptyDeque :: Deque a -> Bool +isEmptyDeque (DQ as bs) = null as && null bs + +dequeSize :: Deque a -> Int +dequeSize (DQ as bs) = length as + length bs + +insertDeque :: a -> Deque a -> Deque a +insertDeque b (DQ as bs) = DQ as (b:bs) + +appendDeque :: Deque a -> Deque a -> Deque a +appendDeque (DQ as1 bs1) (DQ as2 bs2) = DQ (as1 ++ reverse bs1 ++ as2) bs2 + +extractDeque :: Deque a -> Maybe (Deque a, a) +extractDeque (DQ [] []) = Nothing +extractDeque (DQ (a:as) bs) = Just (DQ as bs, a) +extractDeque (DQ [] bs) = case reverse bs of + (a:as) -> Just (DQ as [], a) + [] -> panic "extractDeque" + +-- See Note [WorkList priorities] data WorkList = WorkList { wl_eqs :: [Ct] - , wl_funeqs :: [Ct] + , wl_funeqs :: Deque Ct , wl_rest :: [Ct] } -unionWorkList :: WorkList -> WorkList -> WorkList -unionWorkList new_wl orig_wl = - WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl - , wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl - , wl_rest = wl_rest new_wl ++ wl_rest orig_wl } +appendWorkList :: WorkList -> WorkList -> WorkList +appendWorkList new_wl orig_wl + = WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl + , wl_funeqs = wl_funeqs new_wl `appendDeque` wl_funeqs orig_wl + , wl_rest = wl_rest new_wl ++ wl_rest orig_wl } +workListSize :: WorkList -> Int +workListSize (WorkList { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest }) + = length eqs + dequeSize funeqs + length rest + extendWorkListEq :: Ct -> WorkList -> WorkList -- Extension by equality extendWorkListEq ct wl | Just {} <- isCFunEqCan_Maybe ct - = wl { wl_funeqs = ct : wl_funeqs wl } + = extendWorkListFunEq ct wl | otherwise = wl { wl_eqs = ct : wl_eqs wl } +extendWorkListFunEq :: Ct -> WorkList -> WorkList +extendWorkListFunEq ct wl + = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) } + +extendWorkListEqs :: [Ct] -> WorkList -> WorkList +-- Append a list of equalities +extendWorkListEqs cts wl = foldr extendWorkListEq wl cts + extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality extendWorkListNonEq ct wl @@ -230,20 +270,16 @@ extendWorkListCt ct wl | isEqPred (ctPred ct) = extendWorkListEq ct wl | otherwise = extendWorkListNonEq ct wl -appendWorkListCt :: [Ct] -> WorkList -> WorkList +extendWorkListCts :: [Ct] -> WorkList -> WorkList -- Agnostic -appendWorkListCt cts wl = foldr extendWorkListCt wl cts - -appendWorkListEqs :: [Ct] -> WorkList -> WorkList --- Append a list of equalities -appendWorkListEqs cts wl = foldr extendWorkListEq wl cts +extendWorkListCts cts wl = foldr extendWorkListCt wl cts isEmptyWorkList :: WorkList -> Bool isEmptyWorkList wl - = null (wl_eqs wl) && null (wl_rest wl) && null (wl_funeqs wl) + = null (wl_eqs wl) && null (wl_rest wl) && isEmptyDeque (wl_funeqs wl) emptyWorkList :: WorkList -emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = [] } +emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = emptyDeque } workListFromEq :: Ct -> WorkList workListFromEq ct = extendWorkListEq ct emptyWorkList @@ -261,7 +297,8 @@ selectWorkItem :: WorkList -> (Maybe Ct, WorkList) selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest }) = case (eqs,feqs,rest) of (ct:cts,_,_) -> (Just ct, wl { wl_eqs = cts }) - (_,(ct:cts),_) -> (Just ct, wl { wl_funeqs = cts }) + (_,fun_eqs,_) | Just (fun_eqs', ct) <- extractDeque fun_eqs + -> (Just ct, wl { wl_funeqs = fun_eqs' }) (_,_,(ct:cts)) -> (Just ct, wl { wl_rest = cts }) (_,_,_) -> (Nothing,wl) @@ -274,12 +311,16 @@ instance Outputable WorkList where -- Canonical constraint maps -data CCanMap a = CCanMap { cts_given :: UniqFM Cts - -- Invariant: all Given - , cts_derived :: UniqFM Cts - -- Invariant: all Derived - , cts_wanted :: UniqFM Cts } - -- Invariant: all Wanted +data CCanMap a + = CCanMap { cts_given :: UniqFM Cts -- All Given + , cts_derived :: UniqFM Cts -- All Derived + , cts_wanted :: UniqFM Cts } -- All Wanted + +keepGivenCMap :: CCanMap a -> CCanMap a +keepGivenCMap cc = emptyCCanMap { cts_given = cts_given cc } + +instance Outputable (CCanMap a) where + ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted) cCanMapToBag :: CCanMap a -> Cts cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap) @@ -292,9 +333,9 @@ emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wante updCCanMap:: Uniquable a => (a,Ct) -> CCanMap a -> CCanMap a updCCanMap (a,ct) cmap = case cc_ev ct of - Wanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) } - Given {} -> cmap { cts_given = insert_into (cts_given cmap) } - Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) } + CtWanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) } + CtGiven {} -> cmap { cts_given = insert_into (cts_given cmap) } + CtDerived {} -> cmap { cts_derived = insert_into (cts_derived cmap) } where insert_into m = addToUFM_C unionBags m a (singleCt ct) @@ -351,23 +392,10 @@ partitionEqMap pred isubst in (eqs_out, eqs_in) where extend_if_pred (ct,_) cts = if pred ct then ct : cts else cts - -extractUnsolvedCMap :: CCanMap a -> (Cts, CCanMap a) --- Gets the wanted or derived constraints and returns a residual --- CCanMap with only givens. -extractUnsolvedCMap cmap = - let wntd = foldUFM unionBags emptyCts (cts_wanted cmap) - derd = foldUFM unionBags emptyCts (cts_derived cmap) - in (wntd `unionBags` derd, - cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM }) - -extractWantedCMap :: CCanMap a -> (Cts, CCanMap a) --- Gets the wanted /only/ constraints and returns a residual --- CCanMap with only givens or derived -extractWantedCMap cmap = - let wntd = foldUFM unionBags emptyCts (cts_wanted cmap) - in (wntd, cmap { cts_wanted = emptyUFM }) - +extractUnsolvedCMap :: CCanMap a -> Cts +-- Gets the wanted or derived constraints +extractUnsolvedCMap cmap = foldUFM unionBags emptyCts (cts_wanted cmap) + `unionBags` foldUFM unionBags emptyCts (cts_derived cmap) -- Maps from PredTypes to Constraints type CtTypeMap = TypeMap Ct @@ -383,12 +411,30 @@ instance Outputable a => Outputable (PredMap a) where instance Outputable a => Outputable (FamHeadMap a) where ppr (FamHeadMap m) = ppr (foldTM (:) m []) +sizePredMap :: PredMap a -> Int +sizePredMap (PredMap m) = foldTypeMap (\_ x -> x+1) 0 m + +emptyFamHeadMap :: FamHeadMap a +emptyFamHeadMap = FamHeadMap emptyTM + +sizeFamHeadMap :: FamHeadMap a -> Int +sizeFamHeadMap (FamHeadMap m) = foldTypeMap (\_ x -> x+1) 0 m + ctTypeMapCts :: TypeMap Ct -> Cts ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts lookupFamHead :: FamHeadMap a -> TcType -> Maybe a lookupFamHead (FamHeadMap m) key = lookupTM key m +insertFamHead :: FamHeadMap a -> TcType -> a -> FamHeadMap a +insertFamHead (FamHeadMap m) key value = FamHeadMap (alterTM key (const (Just value)) m) + +delFamHead :: FamHeadMap a -> TcType -> FamHeadMap a +delFamHead (FamHeadMap m) key = FamHeadMap (alterTM key (const Nothing) m) + +anyFamHeadMap :: (Ct -> Bool) -> CtFamHeadMap -> Bool +anyFamHeadMap f ctmap = foldTM ((||) . f) (unFamHeadMap ctmap) False + partCtFamHeadMap :: (Ct -> Bool) -> CtFamHeadMap -> (Cts, CtFamHeadMap) @@ -418,30 +464,6 @@ filterSolved p (PredMap mp) = PredMap (foldTM upd mp emptyTM) %* * %************************************************************************ -\begin{code} --- All Given (fully known) or Wanted or Derived --- See Note [Detailed InertCans Invariants] for more -data InertCans - = IC { inert_eqs :: TyVarEnv Ct - -- Must all be CTyEqCans! If an entry exists of the form: - -- a |-> ct,co - -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } - -- And co : a ~ xi - , inert_eq_tvs :: InScopeSet - -- Superset of the type variables of inert_eqs - , inert_dicts :: CCanMap Class - -- Dictionaries only, index is the class - -- NB: index is /not/ the whole type because FD reactions - -- need to match the class but not necessarily the whole type. - , inert_funeqs :: CtFamHeadMap - -- Family equations, index is the whole family head type. - , inert_irreds :: Cts - -- Irreducible predicates - } - - -\end{code} - Note [Detailed InertCans Invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The InertCans represents a collection of constraints with the following properties: @@ -500,105 +522,138 @@ The reason for all this is simply to avoid re-solving goals we have solved alrea But there are no solved Deriveds in inert_solved_funeqs +Note [Type family equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type-family equations, of form (ev : F tys ~ ty), live in four places + + * The work-list, of course + + * The inert_flat_cache. This is used when flattening, to get maximal + sharing. It contains lots of things that are still in the work-list. + E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the + work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work + list. Now if we flatten w2 before we get to w3, we still want to + share that (G a). + + Because it contains work-list things, DO NOT use the flat cache to solve + a top-level goal. Eg in the above example we don't want to solve w3 + using w3 itself! + + * The inert_solved_funeqs. These are all "solved" goals (see Note [Solved constraints]), + the result of using a top-level type-family instance. + + * THe inert_funeqs are un-solved but fully processed and in the InertCans. + \begin{code} +-- All Given (fully known) or Wanted or Derived +-- See Note [Detailed InertCans Invariants] for more +data InertCans + = IC { inert_eqs :: TyVarEnv Ct + -- Must all be CTyEqCans! If an entry exists of the form: + -- a |-> ct,co + -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } + -- And co : a ~ xi + , inert_dicts :: CCanMap Class + -- Dictionaries only, index is the class + -- NB: index is /not/ the whole type because FD reactions + -- need to match the class but not necessarily the whole type. + , inert_funeqs :: CtFamHeadMap + -- Family equations, index is the whole family head type. + , inert_irreds :: Cts + -- Irreducible predicates + + , inert_insols :: Cts + -- Frozen errors (as non-canonicals) + } + + -- The Inert Set data InertSet = IS { inert_cans :: InertCans -- Canonical Given, Wanted, Derived (no Solved) -- Sometimes called "the inert set" - , inert_frozen :: Cts - -- Frozen errors (as non-canonicals) - - , inert_flat_cache :: CtFamHeadMap - -- All ``flattening equations'' are kept here. - -- Always canonical CTyFunEqs (Given or Wanted only!) - -- Key is by family head. We use this field during flattening only + , inert_flat_cache :: FamHeadMap (CtEvidence, TcType) + -- See Note [Type family equations] + -- Just a hash-cons cache for use when flattening only + -- These include entirely un-processed goals, so don't use + -- them to solve a top-level goal, else you may end up solving + -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache + -- when allocating a new flatten-skolem. -- Not necessarily inert wrt top-level equations (or inert_cans) - - , inert_solved_funeqs :: FamHeadMap CtEvidence -- Of form co :: F xis ~ xi - -- No Deriveds - - , inert_solved :: PredMap CtEvidence -- All others - -- These two fields constitute a cache of solved (only!) constraints + + , inert_fsks :: [TcTyVar] -- Rigid flatten-skolems (arising from givens) + -- allocated in this local scope + + , inert_solved_funeqs :: FamHeadMap (CtEvidence, TcType) + -- See Note [Type family equations] + -- Of form co :: F xis ~ xi + -- Always the result of using a top-level family axiom F xis ~ tau + -- No Deriveds + -- Not necessarily fully rewritten (by type substitutions) + + , inert_solved_dicts :: PredMap CtEvidence + -- Of form ev :: C t1 .. tn + -- Always the result of using a top-level instance declaration -- See Note [Solved constraints] - -- - Constraints of form (F xis ~ xi) live in inert_solved_funeqs, - -- all the others are in inert_solved - -- - Used to avoid creating a new EvVar when we have a new goal that we - -- have solvedin the past + -- - Used to avoid creating a new EvVar when we have a new goal + -- that we have solved in the past -- - Stored not necessarily as fully rewritten -- (ToDo: rewrite lazily when we lookup) } instance Outputable InertCans where - ppr ics = vcat [ vcat (map ppr (varEnvElts (inert_eqs ics))) - , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics))) - , vcat (map ppr (Bag.bagToList $ + ppr ics = vcat [ ptext (sLit "Equalities:") + <+> vcat (map ppr (varEnvElts (inert_eqs ics))) + , ptext (sLit "Type-function equalities:") + <+> vcat (map ppr (Bag.bagToList $ ctTypeMapCts (unFamHeadMap $ inert_funeqs ics))) - , vcat (map ppr (Bag.bagToList $ inert_irreds ics)) + , ptext (sLit "Dictionaries:") + <+> vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics))) + , ptext (sLit "Irreds:") + <+> vcat (map ppr (Bag.bagToList $ inert_irreds ics)) + , text "Insolubles =" <+> -- Clearly print frozen errors + braces (vcat (map ppr (Bag.bagToList $ inert_insols ics))) ] instance Outputable InertSet where ppr is = vcat [ ppr $ inert_cans is - , text "Frozen errors =" <+> -- Clearly print frozen errors - braces (vcat (map ppr (Bag.bagToList $ inert_frozen is))) - , text "Solved and cached" <+> - int (foldTypeMap (\_ x -> x+1) 0 - (unPredMap $ inert_solved is)) <+> - text "more constraints" ] + , text "Solved dicts" <+> int (sizePredMap (inert_solved_dicts is)) + , text "Solved funeqs" <+> int (sizeFamHeadMap (inert_solved_funeqs is))] emptyInert :: InertSet emptyInert = IS { inert_cans = IC { inert_eqs = emptyVarEnv - , inert_eq_tvs = emptyInScopeSet , inert_dicts = emptyCCanMap - , inert_funeqs = FamHeadMap emptyTM - , inert_irreds = emptyCts } - , inert_frozen = emptyCts - , inert_flat_cache = FamHeadMap emptyTM - , inert_solved = PredMap emptyTM - , inert_solved_funeqs = FamHeadMap emptyTM } - -updSolvedSet :: InertSet -> CtEvidence -> InertSet -updSolvedSet is item - = let pty = ctEvPred item - upd_solved Nothing = Just item - upd_solved (Just _existing_solved) = Just item - -- .. or Just existing_solved? Is this even possible to happen? - in is { inert_solved = - PredMap $ - alterTM pty upd_solved (unPredMap $ inert_solved is) } - - -updInertSet :: InertSet -> Ct -> InertSet + , inert_funeqs = emptyFamHeadMap + , inert_irreds = emptyCts + , inert_insols = emptyCts } + , inert_fsks = [] + , inert_flat_cache = emptyFamHeadMap + , inert_solved_dicts = PredMap emptyTM + , inert_solved_funeqs = emptyFamHeadMap } + +insertInertItem :: Ct -> InertSet -> InertSet -- Add a new inert element to the inert set. -updInertSet is item - | isCNonCanonical item - -- NB: this may happen if we decide to kick some frozen error - -- out to rewrite him. Frozen errors are just NonCanonicals - = is { inert_frozen = inert_frozen is `Bag.snocBag` item } - - | otherwise - -- A canonical Given, Wanted, or Derived - = is { inert_cans = upd_inert_cans (inert_cans is) item } +insertInertItem item is + = -- A canonical Given, Wanted, or Derived + is { inert_cans = upd_inert_cans (inert_cans is) item } where upd_inert_cans :: InertCans -> Ct -> InertCans -- Precondition: item /is/ canonical upd_inert_cans ics item | isCTyEqCan item - = let upd_err a b = pprPanic "updInertSet" $ + = let upd_err a b = pprPanic "insertInertItem" $ vcat [ text "Multiple inert equalities:" , text "Old (already inert):" <+> ppr a , text "Trying to insert :" <+> ppr b ] eqs' = extendVarEnv_C upd_err (inert_eqs ics) (cc_tyvar item) item - inscope' = extendInScopeSetSet (inert_eq_tvs ics) - (tyVarsOfCt item) - - in ics { inert_eqs = eqs', inert_eq_tvs = inscope' } + + in ics { inert_eqs = eqs' } | isCIrredEvCan item -- Presently-irreducible evidence = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item } @@ -610,50 +665,46 @@ updInertSet is item = let fam_head = mkTyConApp (cc_fun item) (cc_tyargs item) upd_funeqs Nothing = Just item upd_funeqs (Just _already_there) - = panic "updInertSet: item already there!" + = panic "insertInertItem: item already there!" in ics { inert_funeqs = FamHeadMap (alterTM fam_head upd_funeqs $ (unFamHeadMap $ inert_funeqs ics)) } | otherwise = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item + ppr item -- Can't be CNonCanonical, CHoleCan, + -- because they only land in inert_insols -updInertSetTcS :: Ct -> TcS () + +insertInertItemTcS :: Ct -> TcS () -- Add a new item in the inerts of the monad -updInertSetTcS item - = do { traceTcS "updInertSetTcs {" $ +insertInertItemTcS item + = do { traceTcS "insertInertItemTcS {" $ text "Trying to insert new inert item:" <+> ppr item - ; modifyInertTcS (\is -> ((), updInertSet is item)) + ; updInertTcS (insertInertItem item) - ; traceTcS "updInertSetTcs }" $ empty } - + ; traceTcS "insertInertItemTcS }" $ empty } -addToSolved :: CtEvidence -> TcS () +addSolvedDict :: CtEvidence -> TcS () -- Add a new item in the solved set of the monad -addToSolved item +addSolvedDict item | isIPPred (ctEvPred item) -- Never cache "solved" implicit parameters (not sure why!) = return () | otherwise - = do { traceTcS "updSolvedSetTcs {" $ - text "Trying to insert new solved item:" <+> ppr item - - ; modifyInertTcS (\is -> ((), updSolvedSet is item)) - - ; traceTcS "updSolvedSetTcs }" $ empty } - -addSolvedFunEq :: CtEvidence -> TcS () -addSolvedFunEq fun_eq - = modifyInertTcS $ \inert -> ((), upd_inert inert) - where - upd_inert inert - = let slvd = unFamHeadMap (inert_solved_funeqs inert) - in inert { inert_solved_funeqs = - FamHeadMap (alterTM key upd_funeqs slvd) } - upd_funeqs Nothing = Just fun_eq - upd_funeqs (Just _ct) = Just fun_eq - -- Or _ct? depends on which caches more steps of computation - key = ctEvPred fun_eq + = do { traceTcS "updSolvedSetTcs:" $ ppr item + ; updInertTcS upd_solved_dicts } + where + upd_solved_dicts is + = is { inert_solved_dicts = PredMap $ alterTM pred upd_solved $ + unPredMap $ inert_solved_dicts is } + pred = ctEvPred item + upd_solved _ = Just item + +addSolvedFunEq :: TcType -> CtEvidence -> TcType -> TcS () +addSolvedFunEq fam_ty ev rhs_ty + = updInertTcS $ \ inert -> + inert { inert_solved_funeqs = insertFamHead (inert_solved_funeqs inert) + fam_ty (ev, rhs_ty) } modifyInertTcS :: (InertSet -> (a,InertSet)) -> TcS a -- Modify the inert set with the supplied function @@ -664,95 +715,127 @@ modifyInertTcS upd ; wrapTcS (TcM.writeTcRef is_var new_inert) ; return a } +updInertTcS :: (InertSet -> InertSet) -> TcS () +-- Modify the inert set with the supplied function +updInertTcS upd + = do { is_var <- getTcSInertsRef + ; curr_inert <- wrapTcS (TcM.readTcRef is_var) + ; let new_inert = upd curr_inert + ; wrapTcS (TcM.writeTcRef is_var new_inert) } + +prepareInertsForImplications :: InertSet -> InertSet +-- See Note [Preparing inert set for implications] +prepareInertsForImplications is + = is { inert_cans = getGivens (inert_cans is) + , inert_fsks = [] + , inert_flat_cache = emptyFamHeadMap } + where + getGivens (IC { inert_eqs = eqs + , inert_irreds = irreds + , inert_funeqs = FamHeadMap funeqs + , inert_dicts = dicts }) + = IC { inert_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) eqs + , inert_funeqs = FamHeadMap (mapTM given_from_wanted funeqs) + , inert_irreds = Bag.filterBag isGivenCt irreds + , inert_dicts = keepGivenCMap dicts + , inert_insols = emptyCts } + + given_from_wanted funeq -- This is where the magic processing happens + | isGiven ev = funeq -- for type-function equalities + -- See Note [Preparing inert set for implications] + | otherwise = funeq { cc_ev = given_ev } + where + ev = ctEvidence funeq + given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev) + , ctev_pred = ctev_pred ev } +\end{code} +Note [Preparing inert set for implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before solving the nested implications, we trim the inert set, +retaining only Givens. These givens can be used when solving +the inner implications. -splitInertsForImplications :: InertSet -> ([Ct],InertSet) --- Converts the Wanted of the original inert to Given and removes --- all Wanted and Derived from the inerts. --- DV: Is the removal of Derived essential? -splitInertsForImplications is - = let (cts,is') = extractWanted is - in (givens_from_unsolved cts,is') - where givens_from_unsolved = foldrBag get_unsolved [] - get_unsolved cc rest_givens - | pushable_wanted cc - = let fl = ctEvidence cc - gfl = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol - , ctev_evtm = EvId (ctev_evar fl) - , ctev_pred = ctev_pred fl } - this_given = cc { cc_ev = gfl } - in this_given : rest_givens - | otherwise = rest_givens - - pushable_wanted :: Ct -> Bool - pushable_wanted cc - = isEqPred (ctPred cc) -- see Note [Preparing inert set for implications] - - -- Returns Wanted constraints and a Derived/Given InertSet - extractWanted (IS { inert_cans = IC { inert_eqs = eqs - , inert_eq_tvs = eq_tvs - , inert_irreds = irreds - , inert_funeqs = funeqs - , inert_dicts = dicts - } - , inert_frozen = _frozen - , inert_solved = solved - , inert_flat_cache = flat_cache - , inert_solved_funeqs = funeq_cache - }) - - = let is_solved = IS { inert_cans = IC { inert_eqs = solved_eqs - , inert_eq_tvs = eq_tvs - , inert_dicts = solved_dicts - , inert_irreds = solved_irreds - , inert_funeqs = solved_funeqs } - , inert_frozen = emptyCts -- All out - - -- At some point, I used to flush all the solved, in - -- fear of evidence loops. But I think we are safe, - -- flushing is why T3064 had become slower - , inert_solved = solved -- PredMap emptyTM - , inert_flat_cache = flat_cache -- FamHeadMap emptyTM - , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM - } - in (wanted, is_solved) - - where gd_eqs = filterVarEnv_Directly (\_ ct -> not (isWantedCt ct)) eqs - wanted_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $ - eqs `minusVarEnv` gd_eqs - - (wanted_irreds, gd_irreds) = Bag.partitionBag isWantedCt irreds - (wanted_dicts, gd_dicts) = extractWantedCMap dicts - (wanted_funeqs, gd_funeqs) = partCtFamHeadMap isWantedCt funeqs +With one wrinkle! We take all *wanted* *funeqs*, and turn them into givens. +Consider (Trac #4935) + type instance F True a b = a + type instance F False a b = b + + [w] F c a b ~ gamma + (c ~ True) => a ~ gamma + (c ~ False) => b ~ gamma + +Obviously this is soluble with gamma := F c a b. But +Since solveCTyFunEqs happens at the very end of solving, the only way +to solve the two implications is temporarily consider (F c a b ~ gamma) +as Given and push it inside the implications. Now, when we come +out again at the end, having solved the implications solveCTyFunEqs +will solve this equality. + +Turning type-function equalities into Givens is easy becase they +*stay inert*. No need to re-process them. + +We don't try to turn any *other* Wanteds into Givens: + + * For example, we should not push given dictionaries in because + of example LongWayOverlapping.hs, where we might get strange + overlap errors between far-away constraints in the program. + +There might be cases where interactions between wanteds can help +to solve a constraint. For example + + class C a b | a -> b + (C Int alpha), (forall d. C d blah => C Int a) + +If we push the (C Int alpha) inwards, as a given, it can produce a +fundep (alpha~a) and this can float out again and be used to fix +alpha. (In general we can't float class constraints out just in case +(C d blah) might help to solve (C Int a).) But we ignore this possiblity. - -- Is this all necessary? - solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) gd_eqs - solved_irreds = Bag.filterBag isGivenCt gd_irreds - (_,solved_dicts) = extractUnsolvedCMap gd_dicts - (_,solved_funeqs) = partCtFamHeadMap (not . isGivenCt) gd_funeqs - wanted = wanted_eqs `unionBags` wanted_irreds `unionBags` - wanted_dicts `unionBags` wanted_funeqs +\begin{code} +getInertEqs :: TcS (TyVarEnv Ct) +getInertEqs = do { inert <- getTcSInerts + ; return (inert_eqs (inert_cans inert)) } + +getInertUnsolved :: TcS (Cts, Cts) +-- Return (unsolved-wanteds, insolubles) +-- Both consist of a mixture of Wanted and Derived +getInertUnsolved + = do { is <- getTcSInerts + + ; let icans = inert_cans is + unsolved_irreds = Bag.filterBag is_unsolved (inert_irreds icans) + unsolved_dicts = extractUnsolvedCMap (inert_dicts icans) + (unsolved_funeqs,_) = partCtFamHeadMap is_unsolved (inert_funeqs icans) + unsolved_eqs = foldVarEnv add_if_unsolved emptyCts (inert_eqs icans) + unsolved_flats = unsolved_eqs `unionBags` unsolved_irreds `unionBags` + unsolved_dicts `unionBags` unsolved_funeqs -getInertInsols :: InertSet -> Cts --- Insolubles only -getInertInsols is = inert_frozen is + ; return (unsolved_flats, inert_insols icans) } + where + add_if_unsolved ct cts + | is_unsolved ct = cts `extendCts` ct + | otherwise = cts + + is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived -getInertUnsolved :: InertSet -> Cts --- Unsolved Wanted or Derived only -getInertUnsolved (IS { inert_cans = icans }) - = let unsolved_eqs = foldVarEnv add_if_not_given emptyCts (inert_eqs icans) - add_if_not_given ct cts - | isGivenCt ct = cts - | otherwise = cts `extendCts` ct - (unsolved_irreds,_) = Bag.partitionBag (not . isGivenCt) (inert_irreds icans) - (unsolved_dicts,_) = extractUnsolvedCMap (inert_dicts icans) - (unsolved_funeqs,_) = partCtFamHeadMap (not . isGivenCt) (inert_funeqs icans) - in unsolved_eqs `unionBags` unsolved_irreds `unionBags` - unsolved_dicts `unionBags` unsolved_funeqs +checkAllSolved :: TcS Bool +-- True if there are no unsolved wanteds +-- Ignore Derived for this purpose, unless in insolubles +checkAllSolved + = do { is <- getTcSInerts + ; let icans = inert_cans is + unsolved_irreds = Bag.anyBag isWantedCt (inert_irreds icans) + unsolved_dicts = not (isNullUFM (cts_wanted (inert_dicts icans))) + unsolved_funeqs = anyFamHeadMap isWantedCt (inert_funeqs icans) + unsolved_eqs = foldVarEnv ((||) . isWantedCt) False (inert_eqs icans) + ; return (not (unsolved_eqs || unsolved_irreds + || unsolved_dicts || unsolved_funeqs + || not (isEmptyBag (inert_insols icans)))) } extractRelevantInerts :: Ct -> TcS Cts -- Returns the constraints from the inert set that are 'relevant' to react with @@ -767,34 +850,51 @@ extractRelevantInerts wi extract_ics_relevants (CDictCan {cc_class = cl}) ics = let (cts,dict_map) = getRelevantCts cl (inert_dicts ics) in (cts, ics { inert_dicts = dict_map }) - extract_ics_relevants ct@(CFunEqCan {}) ics = - let (cts,feqs_map) = - let funeq_map = unFamHeadMap $ inert_funeqs ics - fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct) - lkp = lookupTM fam_head funeq_map - new_funeq_map = alterTM fam_head xtm funeq_map - xtm Nothing = Nothing - xtm (Just _ct) = Nothing - in case lkp of - Nothing -> (emptyCts, funeq_map) - Just ct -> (singleCt ct, new_funeq_map) - in (cts, ics { inert_funeqs = FamHeadMap feqs_map }) + + extract_ics_relevants ct@(CFunEqCan {}) ics@(IC { inert_funeqs = funeq_map }) + | Just ct <- lookupFamHead funeq_map fam_head + = (singleCt ct, ics { inert_funeqs = delFamHead funeq_map fam_head }) + | otherwise + = (emptyCts, ics) + where + fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct) + + extract_ics_relevants (CHoleCan {}) ics + = pprPanic "extractRelevantInerts" (ppr wi) + -- Holes are put straight into inert_frozen, so never get here + extract_ics_relevants (CIrredEvCan { }) ics = let cts = inert_irreds ics in (cts, ics { inert_irreds = emptyCts }) + extract_ics_relevants _ ics = (emptyCts,ics) -lookupInInerts :: InertSet -> TcPredType -> Maybe CtEvidence +lookupFlatEqn :: TcType -> TcS (Maybe (CtEvidence, TcType)) +lookupFlatEqn fam_ty + = do { IS { inert_solved_funeqs = solved_funeqs + , inert_flat_cache = flat_cache + , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts + ; return (lookupFamHead solved_funeqs fam_ty `firstJust` + lookupFamHead flat_cache fam_ty `firstJust` + lookup_in_inerts inert_funeqs) } + where + lookup_in_inerts inert_funeqs + = case lookupFamHead inert_funeqs fam_ty of + Nothing -> Nothing + Just ct -> Just (ctEvidence ct, cc_rhs ct) + +lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence) -- Is this exact predicate type cached in the solved or canonicals of the InertSet -lookupInInerts (IS { inert_solved = solved, inert_cans = ics }) pty - = case lookupInSolved solved pty of - Just ctev -> return ctev - Nothing -> lookupInInertCans ics pty +lookupInInerts pty + = do { IS { inert_solved_dicts = solved, inert_cans = ics } <- getTcSInerts + ; case lookupSolvedDict solved pty of + Just ctev -> return (Just ctev) + Nothing -> return (lookupInInertCans ics pty) } -lookupInSolved :: PredMap CtEvidence -> TcPredType -> Maybe CtEvidence +lookupSolvedDict :: PredMap CtEvidence -> TcPredType -> Maybe CtEvidence -- Returns just if exactly this predicate type exists in the solved. -lookupInSolved tm pty = lookupTM pty $ unPredMap tm +lookupSolvedDict tm pty = lookupTM pty $ unPredMap tm lookupInInertCans :: InertCans -> TcPredType -> Maybe CtEvidence -- Returns Just if exactly this pred type exists in the inert canonicals @@ -818,7 +918,7 @@ lookupInInertCans ics pty IrredPred {} -> findEvidence (\ct -> ctEvPred ct `eqType` pty) (inert_irreds ics) - _other -> Nothing -- NB: No caching for IPs + _other -> Nothing -- NB: No caching for IPs or holes \end{code} @@ -851,23 +951,17 @@ data TcSEnv tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)), -- Global type bindings - tcs_untch :: TcsUntouchables, - - tcs_ic_depth :: Int, -- Implication nesting depth tcs_count :: IORef Int, -- Global step count tcs_inerts :: IORef InertSet, -- Current inert set tcs_worklist :: IORef WorkList, -- Current worklist -- Residual implication constraints that are generated - -- while solving the current worklist. + -- while solving or canonicalising the current worklist. + -- Specifically, when canonicalising (forall a. t1 ~ forall a. t2) + -- from which we get the implication (forall a. t1 ~ t2) tcs_implics :: IORef (Bag Implication) } - -type TcsUntouchables = (Untouchables,TcTyVarSet) --- Like the TcM Untouchables, --- but records extra TcsTv variables generated during simplification --- See Note [Extra TcsTv untouchables] in TcSimplify \end{code} \begin{code} @@ -908,41 +1002,46 @@ panicTcS doc = pprPanic "TcCanonical" doc traceTcS :: String -> SDoc -> TcS () traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + bumpStepCountTcS :: TcS () bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env ; n <- TcM.readTcRef ref ; TcM.writeTcRef ref (n+1) } -traceFireTcS :: SubGoalDepth -> SDoc -> TcS () +traceFireTcS :: Ct -> SDoc -> TcS () -- Dump a rule-firing trace -traceFireTcS depth doc +traceFireTcS ct doc = TcS $ \env -> TcM.ifDOptM Opt_D_dump_cs_trace $ do { n <- TcM.readTcRef (tcs_count env) - ; let msg = int n - <> text (replicate (tcs_ic_depth env) '>') - <> brackets (int depth) <+> doc + ; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct))) <+> doc ; TcM.dumpTcRn msg } +runTcS :: TcS a -- What to run + -> TcM (a, Bag EvBind) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; return (res, ev_binds) } + runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a runTcSWithEvBinds ev_binds_var tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv - ; impl_var <- TcM.newTcRef emptyBag ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef is - ; wl_var <- TcM.newTcRef wl ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var - , tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet , tcs_count = step_count - , tcs_ic_depth = 0 , tcs_inerts = inert_var - , tcs_worklist = wl_var - , tcs_implics = impl_var } + , tcs_worklist = panic "runTcS: worklist" + , tcs_implics = panic "runTcS: implics" } + -- NB: Both these are initialised by withWorkList -- Run the computation ; res <- unTcS tcs env @@ -950,32 +1049,22 @@ runTcSWithEvBinds ev_binds_var tcs ; ty_binds <- TcM.readTcRef ty_binds_var ; mapM_ do_unification (varEnvElts ty_binds) - ; when debugIsOn $ - do { count <- TcM.readTcRef step_count - ; when (opt_PprStyle_Debug && count > 0) $ - TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) } - -- And return +#ifdef DEBUG + ; count <- TcM.readTcRef step_count + ; when (opt_PprStyle_Debug && count > 0) $ + TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) + ; ev_binds <- TcM.getTcEvBinds ev_binds_var ; checkForCyclicBinds ev_binds +#endif + ; return res } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty - untouch = NoUntouchables is = emptyInert - wl = emptyWorkList -runTcS :: TcS a -- What to run - -> TcM (a, Bag EvBind) -runTcS tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBinds ev_binds_var - ; return (res, ev_binds) } - +#ifdef DEBUG checkForCyclicBinds :: Bag EvBind -> TcM () -#ifndef DEBUG -checkForCyclicBinds _ = return () -#else checkForCyclicBinds ev_binds | null cycles = return () @@ -994,50 +1083,27 @@ checkForCyclicBinds ev_binds edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds] #endif -doWithInert :: InertSet -> TcS a -> TcS a -doWithInert inert (TcS action) - = TcS $ \env -> do { new_inert_var <- TcM.newTcRef inert - ; action (env { tcs_inerts = new_inert_var }) } - -nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a -nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) +nestImplicTcS :: EvBindsVar -> Untouchables -> InertSet -> TcS a -> TcS a +nestImplicTcS ref inner_untch inerts (TcS thing_inside) = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds - , tcs_untch = (_outer_range, outer_tcs) - , tcs_count = count - , tcs_ic_depth = idepth - , tcs_inerts = inert_var - , tcs_worklist = wl_var - , tcs_implics = _impl_var } -> - do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs) - -- The inner_range should be narrower than the outer one - -- (thus increasing the set of untouchables) but - -- the inner Tcs-untouchables must be unioned with the - -- outer ones! - - -- Inherit the inerts from the outer scope - ; orig_inerts <- TcM.readTcRef inert_var - ; new_inert_var <- TcM.newTcRef orig_inerts - -- Inherit residual implications from outer scope (?) or create - -- fresh var? --- ; orig_implics <- TcM.readTcRef impl_var - ; new_implics_var <- TcM.newTcRef emptyBag - + , tcs_count = count } -> + do { new_inert_var <- TcM.newTcRef inerts ; let nest_env = TcSEnv { tcs_ev_binds = ref , tcs_ty_binds = ty_binds - , tcs_untch = inner_untch , tcs_count = count - , tcs_ic_depth = idepth+1 , tcs_inerts = new_inert_var - , tcs_worklist = wl_var - -- NB: worklist is going to be empty anyway, - -- so reuse the same ref cell - , tcs_implics = new_implics_var + , tcs_worklist = panic "nextImplicTcS: worklist" + , tcs_implics = panic "nextImplicTcS: implics" + -- NB: Both these are initialised by withWorkList } - ; res <- thing_inside nest_env + ; res <- TcM.setUntouchables inner_untch $ + thing_inside nest_env +#ifdef DEBUG -- Perform a check that the thing_inside did not cause cycles ; ev_binds <- TcM.getTcEvBinds ref ; checkForCyclicBinds ev_binds +#endif ; return res } @@ -1046,23 +1112,35 @@ recoverTcS (TcS recovery_code) (TcS thing_inside) = TcS $ \ env -> TcM.recoverM (recovery_code env) (thing_inside env) +nestTcS :: TcS a -> TcS a +-- Use the current untouchables, augmenting the current +-- evidence bindings, ty_binds, and solved caches +-- But have no effect on the InertCans or insolubles +nestTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> + do { inerts <- TcM.readTcRef inerts_var + ; new_inert_var <- TcM.newTcRef inerts + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = panic "nextImplicTcS: worklist" + , tcs_implics = panic "nextImplicTcS: implics" } + ; thing_inside nest_env } + tryTcS :: TcS a -> TcS a -- Like runTcS, but from within the TcS monad -- Completely afresh inerts and worklist, be careful! -- Moreover, we will simply throw away all the evidence generated. -tryTcS tcs - = TcS (\env -> - do { wl_var <- TcM.newTcRef emptyWorkList - ; is_var <- TcM.newTcRef emptyInert - - ; ty_binds_var <- TcM.newTcRef emptyVarEnv - ; ev_binds_var <- TcM.newTcEvBinds +tryTcS (TcS thing_inside) + = TcS $ \env -> + do { is_var <- TcM.newTcRef emptyInert + ; ty_binds_var <- TcM.newTcRef emptyVarEnv + ; ev_binds_var <- TcM.newTcEvBinds - ; let env1 = env { tcs_ev_binds = ev_binds_var - , tcs_ty_binds = ty_binds_var - , tcs_inerts = is_var - , tcs_worklist = wl_var } - ; unTcS tcs env1 }) + ; let nest_env = env { tcs_ev_binds = ev_binds_var + , tcs_ty_binds = ty_binds_var + , tcs_inerts = is_var + , tcs_worklist = panic "nextImplicTcS: worklist" + , tcs_implics = panic "nextImplicTcS: implics" } + ; thing_inside nest_env } -- Getters and setters of TcEnv fields -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1073,97 +1151,75 @@ getTcSInertsRef = TcS (return . tcs_inerts) getTcSWorkListRef :: TcS (IORef WorkList) getTcSWorkListRef = TcS (return . tcs_worklist) - getTcSInerts :: TcS InertSet getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) - -getTcSImplicsRef :: TcS (IORef (Bag Implication)) -getTcSImplicsRef = TcS (return . tcs_implics) - -getTcSImplics :: TcS (Bag Implication) -getTcSImplics = getTcSImplicsRef >>= wrapTcS . (TcM.readTcRef) - -getTcSWorkList :: TcS WorkList -getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef) - - -getTcSWorkListTvs :: TcS TyVarSet --- Return the variables of the worklist -getTcSWorkListTvs - = do { wl <- getTcSWorkList - ; return $ - cts_tvs (wl_eqs wl) `unionVarSet` cts_tvs (wl_funeqs wl) `unionVarSet` cts_tvs (wl_rest wl) } - where cts_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet - - updWorkListTcS :: (WorkList -> WorkList) -> TcS () updWorkListTcS f - = updWorkListTcS_return (\w -> ((),f w)) + = do { wl_var <- getTcSWorkListRef + ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) + ; let new_work = f wl_curr + ; wrapTcS (TcM.writeTcRef wl_var new_work) } updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a +-- Process the work list, returning a depleted work list, +-- plus a value extracted from it (typically a work item removed from it) updWorkListTcS_return f = do { wl_var <- getTcSWorkListRef ; wl_curr <- wrapTcS (TcM.readTcRef wl_var) ; let (res,new_work) = f wl_curr ; wrapTcS (TcM.writeTcRef wl_var new_work) ; return res } - + +withWorkList :: Cts -> TcS () -> TcS (Bag Implication) +-- Use 'thing_inside' to solve 'work_items', extending the +-- ambient InertSet, and returning any residual implications +-- (arising from polytype equalities) +-- We do this with fresh work list and residual-implications variables +withWorkList work_items (TcS thing_inside) + = TcS $ \ tcs_env -> + do { let init_work_list = foldrBag extendWorkListCt emptyWorkList work_items + ; new_wl_var <- TcM.newTcRef init_work_list + ; new_implics_var <- TcM.newTcRef emptyBag + ; thing_inside (tcs_env { tcs_worklist = new_wl_var + , tcs_implics = new_implics_var }) + ; final_wl <- TcM.readTcRef new_wl_var + ; implics <- TcM.readTcRef new_implics_var + ; ASSERT( isEmptyWorkList final_wl ) + return implics } updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS () updTcSImplics f = do { impl_ref <- getTcSImplicsRef - ; implics <- wrapTcS (TcM.readTcRef impl_ref) - ; let new_implics = f implics - ; wrapTcS (TcM.writeTcRef impl_ref new_implics) } - -emitTcSImplication :: Implication -> TcS () -emitTcSImplication imp = updTcSImplics (consBag imp) + ; wrapTcS $ do { implics <- TcM.readTcRef impl_ref + ; TcM.writeTcRef impl_ref (f implics) } } - -emitFrozenError :: CtEvidence -> SubGoalDepth -> TcS () +emitInsoluble :: Ct -> TcS () -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. -emitFrozenError fl depth - = do { traceTcS "Emit frozen error" (ppr (ctEvPred fl)) - ; inert_ref <- getTcSInertsRef - ; wrapTcS $ do - { inerts <- TcM.readTcRef inert_ref - ; let old_insols = inert_frozen inerts - ct = CNonCanonical { cc_ev = fl, cc_depth = depth } - inerts_new = inerts { inert_frozen = extendCts old_insols ct } - this_pred = ctEvPred fl - already_there = not (isWanted fl) && anyBag (eqType this_pred . ctPred) old_insols +emitInsoluble ct + = do { traceTcS "Emit insoluble" (ppr ct) + ; updInertTcS add_insol } + where + add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) }) + | already_there = is + | otherwise = is { inert_cans = ics { inert_insols = extendCts old_insols ct } } + where + already_there = not (isWantedCt ct) && anyBag (eqType this_pred . ctPred) old_insols -- See Note [Do not add duplicate derived insolubles] - ; unless already_there $ - TcM.writeTcRef inert_ref inerts_new } } -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags + this_pred = ctPred ct +getTcSImplicsRef :: TcS (IORef (Bag Implication)) +getTcSImplicsRef = TcS (return . tcs_implics) getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) -getFlatCache :: TcS CtTypeMap -getFlatCache = getTcSInerts >>= (return . unFamHeadMap . inert_flat_cache) - -updFlatCache :: Ct -> TcS () --- Pre: constraint is a flat family equation (equal to a flatten skolem) -updFlatCache flat_eq@(CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = xis }) - = modifyInertTcS upd_inert_cache - where upd_inert_cache is = ((), is { inert_flat_cache = FamHeadMap new_fc }) - where new_fc = alterTM pred_key upd_cache fc - fc = unFamHeadMap $ inert_flat_cache is - pred_key = mkTyConApp tc xis - upd_cache (Just ct) | cc_ev ct `canSolve` fl = Just ct - upd_cache (Just _ct) = Just flat_eq - upd_cache Nothing = Just flat_eq -updFlatCache other_ct = pprPanic "updFlatCache: non-family constraint" $ - ppr other_ct - +getUntouchables :: TcS Untouchables +getUntouchables = wrapTcS TcM.getUntouchables -getUntouchables :: TcS TcsUntouchables -getUntouchables = TcS (return . tcs_untch) +getFlattenSkols :: TcS [TcTyVar] +getFlattenSkols = do { is <- getTcSInerts; return (inert_fsks is) } getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType))) getTcSTyBinds = TcS (return . tcs_ty_binds) @@ -1180,7 +1236,8 @@ setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding -- We never do this twice! setWantedTyBind tv ty - = do { ref <- getTcSTyBinds + = ASSERT2( isMetaTyVar tv, ppr tv ) + do { ref <- getTcSTyBinds ; wrapTcS $ do { ty_binds <- TcM.readTcRef ref ; when debugIsOn $ @@ -1188,17 +1245,11 @@ setWantedTyBind tv ty vcat [ text "TERRIBLE ERROR: double set of meta type variable" , ppr tv <+> text ":=" <+> ppr ty , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)] + ; TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty) ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } } - - \end{code} \begin{code} -warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS () -warnTcS loc warn_if doc - | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc - | otherwise = return () - getDefaultInfo :: TcS ([Type], (Bool, Bool)) getDefaultInfo = wrapTcS TcM.tcGetDefaultTys @@ -1220,7 +1271,7 @@ getGblEnv = wrapTcS $ TcM.getGblEnv -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS () +checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS () checkWellStagedDFun pred dfun_id loc = wrapTcS $ TcM.setCtLoc loc $ do { use_stage <- TcM.getStage @@ -1232,26 +1283,26 @@ checkWellStagedDFun pred dfun_id loc pprEq :: TcType -> TcType -> SDoc pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2 -isTouchableMetaTyVar :: TcTyVar -> TcS Bool -isTouchableMetaTyVar tv +isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool +isTouchableMetaTyVarTcS tv = do { untch <- getUntouchables - ; return $ isTouchableMetaTyVar_InRange untch tv } - -isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool -isTouchableMetaTyVar_InRange (untch,untch_tcs) tv - = ASSERT2 ( isTcTyVar tv, ppr tv ) - case tcTyVarDetails tv of - MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs) - -- See Note [Touchable meta type variables] - MetaTv {} -> inTouchableRange untch tv && not (tv `elemVarSet` untch_tcs) - _ -> False - - + ; return $ isTouchableMetaTyVar untch tv } + +isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) +isFilledMetaTyVar_maybe tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- wrapTcS (TcM.readTcRef ref) + ; case cts of + Indirect ty -> return (Just ty) + Flexi -> return Nothing } + _ -> return Nothing \end{code} Note [Do not add duplicate derived insolubles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we do want to add an insoluble (Int ~ Bool) even if there is one +In general we *do* want to add an insoluble (Int ~ Bool) even if there is one such there already, because they may come from distinct call sites. But for *derived* insolubles, we only want to report each one once. Why? @@ -1285,7 +1336,7 @@ which we have simplified to: For some reason, e.g. because we floated an equality somewhere else, we might try to re-solve this implication. If we do not do a -keepWanted, then we will end up trying to solve the following +dropDerivedWC, then we will end up trying to solve the following constraints the second time: (D [c] c) [W] @@ -1296,34 +1347,47 @@ which will result in two Deriveds to end up in the insoluble set: wc_flat = D [c] c [W] wc_insols = (c ~ [c]) [D], (c ~ [c]) [D] -Note [Touchable meta type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Meta type variables allocated *by the constraint solver itself* are always -touchable. Example: - instance C a b => D [a] where... -if we use this instance declaration we "make up" a fresh meta type -variable for 'b', which we must later guess. (Perhaps C has a -functional dependency.) But since we aren't in the constraint *generator* -we can't allocate a Unique in the touchable range for this implication -constraint. Instead, we mark it as a "TcsTv", which makes it always-touchable. \begin{code} -- Flatten skolems -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -newFlattenSkolemTy :: TcType -> TcS TcType -newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty - -newFlattenSkolemTyVar :: TcType -> TcS TcTyVar -newFlattenSkolemTyVar ty +newFlattenSkolem :: CtFlavour + -> TcType -- F xis + -> TcS (CtEvidence, TcType) -- co :: F xis ~ ty +-- We have already looked up in the cache; no need to so so again +newFlattenSkolem Given fam_ty = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique ; let name = TcM.mkTcTyVarName uniq (fsLit "f") - ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } + ; return $ mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty) } ; traceTcS "New Flatten Skolem Born" $ - ppr tv <+> text "[:= " <+> ppr ty <+> text "]" - ; return tv } + ppr tv <+> text "[:= " <+> ppr fam_ty <+> text "]" + + ; let rhs_ty = mkTyVarTy tv + ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty + , ctev_evtm = EvCoercion (mkTcReflCo fam_ty) } + ; updInertTcS $ \ is@(IS { inert_fsks = fsks }) -> + extendFlatCache fam_ty ctev rhs_ty + is { inert_fsks = tv : fsks } + + ; return (ctev, rhs_ty) } + +newFlattenSkolem _ fam_ty -- Wanted or Derived: make new unification variable + = do { rhs_ty <- newFlexiTcSTy (typeKind fam_ty) + ; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_ty) + -- NC (no-cache) version because we've already + -- looked in the solved goals an inerts (lookupFlatEqn) + ; updInertTcS $ extendFlatCache fam_ty ctev rhs_ty + ; return (ctev, rhs_ty) } + +extendFlatCache :: TcType -> CtEvidence -> TcType -> InertSet -> InertSet +extendFlatCache + | opt_NoFlatCache + = \ _ _ _ is -> is + | otherwise + = \ fam_ty ctev rhs_ty is@(IS { inert_flat_cache = fc }) -> + is { inert_flat_cache = insertFamHead fc fam_ty (ctev,rhs_ty) } -- Instantiations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1347,41 +1411,31 @@ instDFunType dfun_id mb_inst_tys ; return (ty : tys, phi) } go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr mb_inst_tys) +newFlexiTcSTy :: Kind -> TcS TcType +newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) + +cloneMetaTyVar :: TcTyVar -> TcS TcTyVar +cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) + instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType]) --- Like TcM.instMetaTyVar but the variable that is created is --- always touchable; we are supposed to guess its instantiation. --- See Note [Touchable meta type variables] instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs) where - inst_one subst tv = do { ty' <- instFlexiTcSHelper (tyVarName tv) - (substTy subst (tyVarKind tv)) - ; return (extendTvSubst subst tv ty', ty') } - -newFlexiTcSTy :: Kind -> TcS TcType -newFlexiTcSTy knd - = wrapTcS $ - do { uniq <- TcM.newUnique - ; ref <- TcM.newMutVar Flexi - ; let name = TcM.mkTcTyVarName uniq (fsLit "uf") - ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) } - -isFlexiTcsTv :: TyVar -> Bool -isFlexiTcsTv tv - | not (isTcTyVar tv) = False - | MetaTv TcsTv _ <- tcTyVarDetails tv = True - | otherwise = False + inst_one subst tv + = do { ty' <- instFlexiTcSHelper (tyVarName tv) + (substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv ty', ty') } instFlexiTcSHelper :: Name -> Kind -> TcM TcType -instFlexiTcSHelper tvname tvkind +instFlexiTcSHelper tvname kind = do { uniq <- TcM.newUnique - ; ref <- TcM.newMutVar Flexi + ; details <- TcM.newMetaDetails TauTv ; let name = setNameUnique tvname uniq - kind = tvkind - ; return (mkTyVarTy (mkTcTyVar name kind (MetaTv TcsTv ref))) } + ; return (mkTyVarTy (mkTcTyVar name kind details)) } instFlexiTcSHelperTcS :: Name -> Kind -> TcS TcType instFlexiTcSHelperTcS n k = wrapTcS (instFlexiTcSHelper n k) + -- Creating and setting evidence variables and CtFlavors -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1415,41 +1469,43 @@ setEvBind the_ev tm ; tc_evbinds <- getTcEvBinds ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm } -newGivenEvVar :: GivenLoc -> TcPredType -> EvTerm -> TcS CtEvidence +newGivenEvVar :: TcPredType -> EvTerm -> TcS CtEvidence -- Make a new variable of the given PredType, -- immediately bind it to the given term -- and return its CtEvidence -newGivenEvVar gloc pred rhs +newGivenEvVar pred rhs = do { new_ev <- wrapTcS $ TcM.newEvVar pred ; setEvBind new_ev rhs - ; return (Given { ctev_gloc = gloc, ctev_pred = pred, ctev_evtm = EvId new_ev }) } - -newWantedEvVar :: WantedLoc -> TcPredType -> TcS MaybeNew -newWantedEvVar loc pty - = do { is <- getTcSInerts - ; case lookupInInerts is pty of + ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) } + +newWantedEvVarNC :: TcPredType -> TcS CtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC pty + = do { new_ev <- wrapTcS $ TcM.newEvVar pty + ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })} + +newWantedEvVar :: TcPredType -> TcS MaybeNew +newWantedEvVar pty + = do { mb_ct <- lookupInInerts pty + ; case mb_ct of Just ctev | not (isDerived ctev) -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev ; return (Cached (ctEvTerm ctev)) } - _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty - ; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev - ; let ctev = Wanted { ctev_wloc = loc - , ctev_pred = pty - , ctev_evar = new_ev } + _ -> do { ctev <- newWantedEvVarNC pty + ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev ; return (Fresh ctev) } } -newDerived :: WantedLoc -> TcPredType -> TcS (Maybe CtEvidence) +newDerived :: TcPredType -> TcS (Maybe CtEvidence) -- Returns Nothing if cached, -- Just pred if not cached -newDerived loc pty - = do { is <- getTcSInerts - ; case lookupInInerts is pty of - Just {} -> return Nothing - _ -> return (Just Derived { ctev_wloc = loc - , ctev_pred = pty }) } - -instDFunConstraints :: WantedLoc -> TcThetaType -> TcS [MaybeNew] -instDFunConstraints wl = mapM (newWantedEvVar wl) +newDerived pty + = do { mb_ct <- lookupInInerts pty + ; return (case mb_ct of + Just {} -> Nothing + Nothing -> Just (CtDerived { ctev_pred = pty })) } + +instDFunConstraints :: TcThetaType -> TcS [MaybeNew] +instDFunConstraints = mapM newWantedEvVar \end{code} @@ -1493,34 +1549,23 @@ See Note [Coercion evidence terms] in TcEvidence. \begin{code} -xCtFlavor :: CtEvidence -- Original flavor +xCtFlavor :: CtEvidence -- Original flavor -> [TcPredType] -- New predicate types -> XEvTerm -- Instructions about how to manipulate evidence -> TcS [CtEvidence] -xCtFlavor = xCtFlavor_cache True -xCtFlavor_cache :: Bool -- True = if wanted add to the solved bag! - -> CtEvidence -- Original flavor - -> [TcPredType] -- New predicate types - -> XEvTerm -- Instructions about how to manipulate evidence - -> TcS [CtEvidence] - -xCtFlavor_cache _ (Given { ctev_gloc = gl, ctev_evtm = tm }) ptys xev +xCtFlavor (CtGiven { ctev_evtm = tm }) ptys xev = ASSERT( equalLength ptys (ev_decomp xev tm) ) - zipWithM (newGivenEvVar gl) ptys (ev_decomp xev tm) + zipWithM newGivenEvVar ptys (ev_decomp xev tm) -- See Note [Bind new Givens immediately] -xCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar }) ptys xev - = do { new_evars <- mapM (newWantedEvVar wl) ptys +xCtFlavor ctev@(CtWanted { ctev_evar = evar }) ptys xev + = do { new_evars <- mapM newWantedEvVar ptys ; setEvBind evar (ev_comp xev (getEvTerms new_evars)) - - -- Add the now-solved wanted constraint to the cache - ; when cache $ addToSolved ctev - ; return (freshGoals new_evars) } -xCtFlavor_cache _ (Derived { ctev_wloc = wl }) ptys _xev - = do { ders <- mapM (newDerived wl) ptys +xCtFlavor (CtDerived {}) ptys _xev + = do { ders <- mapM newDerived ptys ; return (catMaybes ders) } ----------------------------- @@ -1528,9 +1573,12 @@ rewriteCtFlavor :: CtEvidence -> TcPredType -- new predicate -> TcCoercion -- new ~ old -> TcS (Maybe CtEvidence) +-- Returns Just new_fl iff either (i) 'co' is reflexivity +-- or (ii) 'co' is not reflexivity, and 'new_pred' not cached +-- In either case, there is nothing new to do with new_fl {- rewriteCtFlavor old_fl new_pred co -Main purpose: create a new identity (flavor) for new_pred; +Main purpose: create new evidence for new_pred; unless new_pred is cached already * Returns a new_fl : new_pred, with same wanted/given/derived flag as old_fl * If old_fl was wanted, create a binding for old_fl, in terms of new_fl @@ -1546,47 +1594,36 @@ Main purpose: create a new identity (flavor) for new_pred; Given Already in inert Nothing Not Just new_evidence - - Solved NEVER HAPPENS -} -rewriteCtFlavor = rewriteCtFlavor_cache True --- Returns Just new_fl iff either (i) 'co' is reflexivity --- or (ii) 'co' is not reflexivity, and 'new_pred' not cached --- In either case, there is nothing new to do with new_fl - -rewriteCtFlavor_cache :: Bool - -> CtEvidence - -> TcPredType -- new predicate - -> TcCoercion -- new ~ old - -> TcS (Maybe CtEvidence) -- If derived, don't even look at the coercion -- NB: this allows us to sneak away with ``error'' thunks for -- coercions that come from derived ids (which don't exist!) -rewriteCtFlavor_cache _cache (Derived { ctev_wloc = wl }) pty_new _co - = newDerived wl pty_new + +rewriteCtFlavor (CtDerived {}) pty_new _co + = newDerived pty_new -rewriteCtFlavor_cache _cache (Given { ctev_gloc = gl, ctev_evtm = old_tm }) pty_new co - = do { new_ev <- newGivenEvVar gl pty_new new_tm -- See Note [Bind new Givens immediately] +rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) pty_new co + = do { new_ev <- newGivenEvVar pty_new new_tm -- See Note [Bind new Givens immediately] ; return (Just new_ev) } where - new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCase optimises ReflCo + new_tm = mkEvCast old_tm (mkTcSymCo co) -- mkEvCast optimises ReflCo -rewriteCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar, ctev_pred = pty_old }) pty_new co - | isTcReflCo co -- If just reflexivity then you may re-use the same variable - = return (Just (if pty_old `eqType` pty_new +rewriteCtFlavor ctev@(CtWanted { ctev_evar = evar, ctev_pred = old_pred }) + new_pred co + | isTcReflCo co -- If just reflexivity then you may re-use the same variable + = return (Just (if old_pred `eqType` new_pred then ctev - else ctev { ctev_pred = pty_new })) - -- If the old and new types compare equal (eqType looks through synonyms) + else ctev { ctev_pred = new_pred })) + -- Even if the coercion is Refl, it might reflect the result of unification alpha := ty + -- so old_pred and new_pred might not *look* the same, and it's vital to proceed from + -- now on using new_pred. + -- However, if they *do* look the same, we'd prefer to stick with old_pred -- then retain the old type, so that error messages come out mentioning synonyms | otherwise - = do { new_evar <- newWantedEvVar wl pty_new + = do { new_evar <- newWantedEvVar new_pred ; setEvBind evar (mkEvCast (getEvTerm new_evar) co) - - -- Add the now-solved wanted constraint to the cache - ; when cache $ addToSolved ctev - ; case new_evar of Fresh ctev -> return (Just ctev) _ -> return Nothing } @@ -1641,7 +1678,7 @@ matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args -- Deferring forall equalities as implications -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -deferTcSForAllEq :: (WantedLoc,EvVar) -- Original wanted equality flavor +deferTcSForAllEq :: (CtLoc,EvVar) -- Original wanted equality flavor -> ([TyVar],TcType) -- ForAll tvs1 body1 -> ([TyVar],TcType) -- ForAll tvs2 body2 -> TcS () @@ -1653,52 +1690,32 @@ deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2) phi1 = Type.substTy subst1 body1 phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 skol_info = UnifyForAllSkol skol_tvs phi1 - ; mev <- newWantedEvVar loc (mkTcEqPred phi1 phi2) + ; mev <- newWantedEvVar (mkTcEqPred phi1 phi2) ; coe_inside <- case mev of Cached ev_tm -> return (evTermCoercion ev_tm) Fresh ctev -> do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds + ; env <- wrapTcS $ TcM.getLclEnv ; let ev_binds = TcEvBinds ev_binds_var - new_ct = mkNonCanonical ctev + new_ct = mkNonCanonical loc ctev new_co = evTermCoercion (ctEvTerm ctev) - ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv - ; loc <- wrapTcS $ TcM.getCtLoc skol_info + new_untch = pushUntouchables (tcl_untch env) ; let wc = WC { wc_flat = singleCt new_ct , wc_impl = emptyBag , wc_insol = emptyCts } - imp = Implic { ic_untch = all_untouchables - , ic_env = lcl_env + imp = Implic { ic_untch = new_untch , ic_skols = skol_tvs + , ic_fsks = [] , ic_given = [] , ic_wanted = wc , ic_insol = False , ic_binds = ev_binds_var - , ic_loc = loc } + , ic_env = env + , ic_info = skol_info } ; updTcSImplics (consBag imp) ; return (TcLetCo ev_binds new_co) } ; setEvBind orig_ev $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) } - where all_untouchables = TouchableRange u u - u = idUnique orig_ev -- HACK: empty range - -\end{code} - - - --- Rewriting with respect to the inert equalities --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -getInertEqs :: TcS (TyVarEnv Ct, InScopeSet) -getInertEqs = do { inert <- getTcSInerts - ; let ics = inert_cans inert - ; return (inert_eqs ics, inert_eq_tvs ics) } - -getCtCoercion :: EvBindMap -> Ct -> TcCoercion --- Precondition: A CTyEqCan which is either Wanted or Given, never Derived or Solved! -getCtCoercion _bs ct - = ASSERT( not (isDerivedCt ct) ) - evTermCoercion (ctEvTerm (ctEvidence ct)) \end{code} - diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index c36ee43f83..c0ff59d793 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -9,11 +9,13 @@ module TcSimplify( simplifyInfer, simplifyAmbiguityCheck, simplifyDefault, simplifyDeriv, - simplifyRule, simplifyTop, simplifyInteractive + simplifyRule, simplifyTop, simplifyInteractive, + solveWantedsTcM ) where #include "HsVersions.h" +import TcRnTypes import TcRnMonad import TcErrors import TcMType @@ -21,8 +23,8 @@ import TcType import TcSMonad import TcInteract import Inst -import Unify ( niFixTvSubst, niSubstTvSet ) -import Type ( classifyPredType, PredTree(..), isIPPred_maybe ) +import Type ( classifyPredType, PredTree(..), getClassPredTys_maybe ) +import Class ( Class ) import Var import Unique import VarSet @@ -37,12 +39,9 @@ import PrelInfo import PrelNames import Class ( classKey ) import BasicTypes ( RuleName ) -import Control.Monad ( when ) import Outputable import FastString import TrieMap () -- DV: for now -import DynFlags -import Data.Maybe ( mapMaybe ) \end{code} @@ -52,53 +51,45 @@ import Data.Maybe ( mapMaybe ) * * ********************************************************************************* - \begin{code} - - simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- Simplify top-level constraints -- Usually these will be implications, -- but when there is nothing to quantify we don't wrap -- in a degenerate implication, so we do that here instead -simplifyTop wanteds - = do { ev_binds_var <- newTcEvBinds - - ; zonked_wanteds <- zonkWC wanteds - ; wc_first_go <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds - ; cts <- applyTyVarDefaulting wc_first_go - -- See Note [Top-level Defaulting Plan] - - ; let wc_for_loop = wc_first_go { wc_flat = wc_flat wc_first_go `unionBags` cts } - - ; traceTc "simpl_top_loop {" $ text "zonked_wc =" <+> ppr zonked_wanteds - ; simpl_top_loop ev_binds_var wc_for_loop } +simplifyTop wanteds + = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds + ; ev_binds_var <- newTcEvBinds + ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top + ; binds1 <- TcRnMonad.getTcEvBinds ev_binds_var + ; traceTc "End simplifyTop }" empty + + ; traceTc "reportUnsolved {" empty + ; binds2 <- reportUnsolved zonked_final_wc + ; traceTc "reportUnsolved }" empty + + ; return (binds1 `unionBags` binds2) } + + where + -- See Note [Top-level Defaulting Plan] + simpl_top :: WantedConstraints -> TcS WantedConstraints + simpl_top wanteds + = do { wc_first_go <- nestTcS (solve_wanteds_and_drop wanteds) + ; applyTyVarDefaulting wc_first_go + ; simpl_top_loop wc_first_go } - where simpl_top_loop ev_binds_var wc - | isEmptyWC wc - = do { traceTc "simpl_top_loop }" empty - ; TcRnMonad.getTcEvBinds ev_binds_var } - | otherwise - = do { wc_residual <- solveWantedsWithEvBinds ev_binds_var wc - ; let wc_flat_approximate = approximateWC wc_residual - ; (dflt_eqs,_unused_bind) <- runTcS $ - applyDefaultingRules wc_flat_approximate - -- See Note [Top-level Defaulting Plan] - ; if isEmptyBag dflt_eqs then - do { traceTc "simpl_top_loop }" empty - ; report_and_finish ev_binds_var wc_residual } - else - simpl_top_loop ev_binds_var $ - wc_residual { wc_flat = wc_flat wc_residual `unionBags` dflt_eqs } } - - report_and_finish ev_binds_var wc_residual - = do { eb1 <- TcRnMonad.getTcEvBinds ev_binds_var - ; traceTc "reportUnsolved {" empty - -- See Note [Deferring coercion errors to runtime] - ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors - ; eb2 <- reportUnsolved runtimeCoercionErrors wc_residual - ; traceTc "reportUnsolved }" empty - ; return (eb1 `unionBags` eb2) } + simpl_top_loop wc + | isEmptyWC wc + = return wc + | otherwise + = do { wc_residual <- nestTcS (solve_wanteds_and_drop wc) + ; let wc_flat_approximate = approximateWC wc_residual + ; something_happened <- applyDefaultingRules wc_flat_approximate + -- See Note [Top-level Defaulting Plan] + ; if something_happened then + simpl_top_loop wc_residual + else + return wc_residual } \end{code} Note [Top-level Defaulting Plan] @@ -148,7 +139,7 @@ More details in Note [DefaultTyVar]. simplifyAmbiguityCheck :: Name -> WantedConstraints -> TcM (Bag EvBind) simplifyAmbiguityCheck name wanteds = traceTc "simplifyAmbiguityCheck" (text "name =" <+> ppr name) >> - simplifyTop wanteds -- NB: must be simplifyTop not simplifyCheck, so that we + simplifyTop wanteds -- NB: must be simplifyTop so that we -- do ambiguity resolution. -- See Note [Impedence matching] in TcBinds. @@ -164,7 +155,16 @@ simplifyDefault :: ThetaType -- Wanted; has no type variables in it simplifyDefault theta = do { traceTc "simplifyInteractive" empty ; wanted <- newFlatWanteds DefaultOrigin theta - ; _ignored_ev_binds <- simplifyCheck (mkFlatWC wanted) + ; (unsolved, _binds) <- solveWantedsTcM (mkFlatWC wanted) + + ; traceTc "reportUnsolved {" empty + -- See Note [Deferring coercion errors to runtime] + ; reportAllUnsolved unsolved + -- Postcondition of solveWantedsTcM is that returned + -- constraints are zonked. So Precondition of reportUnsolved + -- is true. + ; traceTc "reportUnsolved }" empty + ; return () } \end{code} @@ -200,7 +200,8 @@ simplifyDeriv orig pred tvs theta ; traceTc "simplifyDeriv" $ vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] ; (residual_wanted, _ev_binds1) - <- solveWanteds (mkFlatWC wanted) + <- solveWantedsTcM (mkFlatWC wanted) + -- Post: residual_wanted are already zonked ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] @@ -215,7 +216,7 @@ simplifyDeriv orig pred tvs theta -- We never want to defer these errors because they are errors in the -- compiler! Hence the `False` below - ; _ev_binds2 <- reportUnsolved False (residual_wanted { wc_flat = bad }) + ; reportAllUnsolved (residual_wanted { wc_flat = bad }) ; let min_theta = mkMinimalBySCs (bagToList good) ; return (substTheta subst_skol min_theta) } @@ -320,14 +321,14 @@ simplifyInfer :: Bool -> Bool -- Apply monomorphism restriction -> [(Name, TcTauType)] -- Variables to be generalised, -- and their tau-types - -> (Untouchables, WantedConstraints) + -> WantedConstraints -> TcM ([TcTyVar], -- Quantify over these type variables [EvVar], -- ... and these constraints Bool, -- The monomorphism restriction did something -- so the results type is not as general as -- it could be TcEvBinds) -- ... binding these evidence variables -simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) +simplifyInfer _top_lvl apply_mr name_taus wanteds | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; zonked_taus <- zonkTcTypes (map snd name_taus) @@ -338,20 +339,16 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) ; return (qtvs, [], False, emptyTcEvBinds) } | otherwise - = do { runtimeCoercionErrors <- doptM Opt_DeferTypeErrors - ; gbl_tvs <- tcGetGlobalTyVars - ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) - ; zonked_wanteds <- zonkWC wanteds + = do { zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) + ; ev_binds_var <- newTcEvBinds ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) , ptext (sLit "taus =") <+> ppr (map snd name_taus) , ptext (sLit "tau_tvs (zonked) =") <+> ppr zonked_tau_tvs - , ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs , ptext (sLit "closed =") <+> ppr _top_lvl , ptext (sLit "apply_mr =") <+> ppr apply_mr - , ptext (sLit "untch =") <+> ppr untch - , ptext (sLit "wanted =") <+> ppr zonked_wanteds + , ptext (sLit "(unzonked) wanted =") <+> ppr wanteds ] -- Historical note: Before step 2 we used to have a @@ -368,60 +365,63 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) -- calling solveWanteds will side-effect their evidence -- bindings, so we can't just revert to the input -- constraint. - ; ev_binds_var <- newTcEvBinds - ; wanted_transformed <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds - - -- Step 3) Fail fast if there is an insoluble constraint, - -- unless we are deferring errors to runtime - ; when (not runtimeCoercionErrors && insolubleWC wanted_transformed) $ - do { _ev_binds <- reportUnsolved False wanted_transformed; failM } + ; wanted_transformed <- solveWantedsTcMWithEvBinds ev_binds_var wanteds $ + solve_wanteds_and_drop + -- Post: wanted_transformed are zonked -- Step 4) Candidates for quantification are an approximation of wanted_transformed - ; let quant_candidates = approximateWC wanted_transformed -- NB: Already the fixpoint of any unifications that may have happened -- NB: We do not do any defaulting when inferring a type, this can lead -- to less polymorphic types, see Note [Default while Inferring] - -- NB: quant_candidates here are wanted or derived, we filter the wanteds later, anyway -- Step 5) Minimize the quantification candidates - ; (quant_candidates_transformed, _extra_binds) - <- solveWanteds $ WC { wc_flat = quant_candidates - , wc_impl = emptyBag - , wc_insol = emptyBag } - -- Step 6) Final candidates for quantification - ; let final_quant_candidates :: [PredType] - final_quant_candidates = map ctPred $ bagToList $ - keepWanted (wc_flat quant_candidates_transformed) - -- NB: Already the fixpoint of any unifications that may have happened + -- We discard bindings, insolubles etc, because all we are + -- care aout it + + ; (quant_pred_candidates, _extra_binds) + <- if insolubleWC wanted_transformed + then return ([], emptyBag) -- See Note [Quantification with errors] + else runTcS $ + do { let quant_candidates = approximateWC wanted_transformed + ; traceTcS "simplifyWithApprox" $ + text "quant_candidates = " <+> ppr quant_candidates + ; promoteTyVars quant_candidates + ; _implics <- solveInteract quant_candidates + ; (flats, _insols) <- getInertUnsolved + -- NB: Dimitrios is slightly worried that we will get + -- family equalities (F Int ~ alpha) in the quantification + -- candidates, as we have performed no further unflattening + -- at this point. Nothing bad, but inferred contexts might + -- look complicated. + ; return (map ctPred $ filter isWantedCt (bagToList flats)) } + + -- NB: quant_pred_candidates is already the fixpoint of any + -- unifications that may have happened ; gbl_tvs <- tcGetGlobalTyVars -- TODO: can we just use untch instead of gbl_tvs? ; zonked_tau_tvs <- zonkTyVarsAndFV zonked_tau_tvs - ; traceTc "simplifyWithApprox" $ - vcat [ ptext (sLit "final_quant_candidates =") <+> ppr final_quant_candidates - , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs - , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs ] - ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs - poly_qtvs = growThetaTyVars final_quant_candidates init_tvs + poly_qtvs = growThetaTyVars quant_pred_candidates init_tvs `minusVarSet` gbl_tvs - pbound = filter (quantifyPred poly_qtvs) final_quant_candidates + pbound = filter (quantifyPred poly_qtvs) quant_pred_candidates - ; traceTc "simplifyWithApprox" $ - vcat [ ptext (sLit "pbound =") <+> ppr pbound - , ptext (sLit "init_qtvs =") <+> ppr init_tvs - , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ] - -- Monomorphism restriction - ; let mr_qtvs = init_tvs `minusVarSet` constrained_tvs - constrained_tvs = tyVarsOfTypes final_quant_candidates + mr_qtvs = init_tvs `minusVarSet` constrained_tvs + constrained_tvs = tyVarsOfTypes quant_pred_candidates mr_bites = apply_mr && not (null pbound) - (qtvs, bound) - | mr_bites = (mr_qtvs, []) - | otherwise = (poly_qtvs, pbound) + (qtvs, bound) | mr_bites = (mr_qtvs, []) + | otherwise = (poly_qtvs, pbound) + ; traceTc "simplifyWithApprox" $ + vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates + , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs + , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs + , ptext (sLit "pbound =") <+> ppr pbound + , ptext (sLit "init_qtvs =") <+> ppr init_tvs + , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ] ; if isEmptyVarSet qtvs && null bound then do { traceTc "} simplifyInfer/no quantification" empty @@ -446,30 +446,39 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) -- Step 7) Emit an implication ; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds - ; lcl_env <- getLclTypeEnv - ; gloc <- getCtLoc skol_info - ; let implic = Implic { ic_untch = untch - , ic_env = lcl_env + ; lcl_env <- TcRnMonad.getLclEnv + ; let implic = Implic { ic_untch = pushUntouchables (tcl_untch lcl_env) , ic_skols = qtvs_to_return + , ic_fsks = [] -- wanted_tansformed arose only from solveWanteds + -- hence no flatten-skolems (which come from givens) , ic_given = minimal_bound_ev_vars , ic_wanted = wanted_transformed , ic_insol = False , ic_binds = ev_binds_var - , ic_loc = gloc } + , ic_info = skol_info + , ic_env = lcl_env } ; emitImplication implic ; traceTc "} simplifyInfer/produced residual implication for quantification" $ vcat [ ptext (sLit "implic =") <+> ppr implic -- ic_skols, ic_given give rest of result , ptext (sLit "qtvs =") <+> ppr qtvs_to_return - , ptext (sLit "spb =") <+> ppr final_quant_candidates + , ptext (sLit "spb =") <+> ppr quant_pred_candidates , ptext (sLit "bound =") <+> ppr bound ] ; return ( qtvs_to_return, minimal_bound_ev_vars , mr_bites, TcEvBinds ev_binds_var) } } - where \end{code} +Note [Quantification with errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find that the RHS of the definition has some absolutely-insoluble +constraints, we abandon all attempts to find a context to quantify +over, and instead make the function fully-polymorphic in whatever +type we have found. For two reasons + a) Minimise downstream errors + b) Avoid spurious errors from this function + Note [Default while Inferring] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -509,7 +518,6 @@ we don't do it for now. Note [Minimize by Superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - When we quantify over a constraint, in simplifyInfer we need to quantify over a constraint that is minimal in some sense: For instance, if the final wanted constraint is (Eq alpha, Ord alpha), @@ -518,29 +526,6 @@ from superclass selection from Ord alpha. This minimization is what mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint to check the original wanted. -\begin{code} -approximateWC :: WantedConstraints -> Cts --- Postcondition: Wanted or Derived Cts -approximateWC wc = float_wc emptyVarSet wc - where - float_wc :: TcTyVarSet -> WantedConstraints -> Cts - float_wc skols (WC { wc_flat = flat, wc_impl = implic }) = floats1 `unionBags` floats2 - where floats1 = do_bag (float_flat skols) flat - floats2 = do_bag (float_implic skols) implic - - float_implic :: TcTyVarSet -> Implication -> Cts - float_implic skols imp - = float_wc (skols `extendVarSetList` ic_skols imp) (ic_wanted imp) - - float_flat :: TcTyVarSet -> Ct -> Cts - float_flat skols ct - | tyVarsOfCt ct `disjointVarSet` skols - = singleCt ct - | otherwise = emptyCts - - do_bag :: (a -> Bag c) -> Bag a -> Bag c - do_bag f = foldrBag (unionBags.f) emptyBag -\end{code} Note [Avoid unecessary constraint simplification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -596,16 +581,13 @@ simplifyRule :: RuleName -> TcM ([EvVar], WantedConstraints) -- LHS evidence varaibles -- See Note [Simplifying RULE constraints] in TcRule simplifyRule name lhs_wanted rhs_wanted - = do { zonked_all <- zonkWC (lhs_wanted `andWC` rhs_wanted) - ; let doc = ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) - - -- We allow ourselves to unify environment + = do { -- We allow ourselves to unify environment -- variables: runTcS runs with NoUntouchables - ; (resid_wanted, _) <- solveWanteds zonked_all - - ; zonked_lhs <- zonkWC lhs_wanted + (resid_wanted, _) <- solveWantedsTcM (lhs_wanted `andWC` rhs_wanted) + -- Post: these are zonked and unflattened - ; let (q_cts, non_q_cts) = partitionBag quantify_me (wc_flat zonked_lhs) + ; zonked_lhs_flats <- zonkCts (wc_flat lhs_wanted) + ; let (q_cts, non_q_cts) = partitionBag quantify_me zonked_lhs_flats quantify_me -- Note [RULE quantification over equalities] | insolubleWC resid_wanted = quantify_insol | otherwise = quantify_normal @@ -619,12 +601,12 @@ simplifyRule name lhs_wanted rhs_wanted = True ; traceTc "simplifyRule" $ - vcat [ doc - , text "zonked_lhs" <+> ppr zonked_lhs + vcat [ ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) + , text "zonked_lhs_flats" <+> ppr zonked_lhs_flats , text "q_cts" <+> ppr q_cts ] ; return ( map (ctEvId . ctEvidence) (bagToList q_cts) - , zonked_lhs { wc_flat = non_q_cts }) } + , lhs_wanted { wc_flat = non_q_cts }) } \end{code} @@ -634,43 +616,8 @@ simplifyRule name lhs_wanted rhs_wanted * * *********************************************************************************** -\begin{code} -simplifyCheck :: WantedConstraints -- Wanted - -> TcM (Bag EvBind) --- Solve a single, top-level implication constraint --- e.g. typically one created from a top-level type signature --- f :: forall a. [a] -> [a] --- f x = rhs --- We do this even if the function has no polymorphism: --- g :: Int -> Int - --- g y = rhs --- (whereas for *nested* bindings we would not create --- an implication constraint for g at all.) --- --- Fails if can't solve something in the input wanteds -simplifyCheck wanteds - = do { wanteds <- zonkWC wanteds - - ; traceTc "simplifyCheck {" (vcat - [ ptext (sLit "wanted =") <+> ppr wanteds ]) - - ; (unsolved, eb1) <- solveWanteds wanteds - - ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved - - ; traceTc "reportUnsolved {" empty - -- See Note [Deferring coercion errors to runtime] - ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors - ; eb2 <- reportUnsolved runtimeCoercionErrors unsolved - ; traceTc "reportUnsolved }" empty - - ; return (eb1 `unionBags` eb2) } -\end{code} - Note [Deferring coercion errors to runtime] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - While developing, sometimes it is desirable to allow compilation to succeed even if there are type errors in the code. Consider the following case: @@ -706,61 +653,88 @@ in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the errors and does not fail if -fwarn-type-errors is on, so that we can continue compilation. The errors are turned into warnings in `reportUnsolved`. -\begin{code} +Note [Zonk after solving] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We zonk the result immediately after constraint solving, for two reasons: -solveWanteds :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) --- Return the evidence binds in the BagEvBinds result -solveWanteds wanted = runTcS $ solve_wanteds wanted +a) because zonkWC generates evidence, and this is the moment when we + have a suitable evidence variable to hand. + +Note that *after* solving the constraints are typically small, so the +overhead is not great. -solveWantedsWithEvBinds :: EvBindsVar -> WantedConstraints -> TcM WantedConstraints --- Side-effect the EvBindsVar argument to add new bindings from solving -solveWantedsWithEvBinds ev_binds_var wanted - = runTcSWithEvBinds ev_binds_var $ solve_wanteds wanted +\begin{code} +solveWantedsTcMWithEvBinds :: EvBindsVar + -> WantedConstraints + -> (WantedConstraints -> TcS WantedConstraints) + -> TcM WantedConstraints +-- Returns a *zonked* result +-- We zonk when we finish primarily to un-flatten out any +-- flatten-skolems etc introduced by canonicalisation of +-- types involving type funuctions. Happily the result +-- is typically much smaller than the input, indeed it is +-- often empty. +solveWantedsTcMWithEvBinds ev_binds_var wc tcs_action + = do { traceTc "solveWantedsTcMWithEvBinds" $ text "wanted=" <+> ppr wc + ; wc2 <- runTcSWithEvBinds ev_binds_var (tcs_action wc) + ; zonkWC ev_binds_var wc2 } + -- See Note [Zonk after solving] + +solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) +-- Zonk the input constraints, and simplify them +-- Return the evidence binds in the BagEvBinds result +-- Discards all Derived stuff in result +-- Postcondition: fully zonked and unflattened constraints +solveWantedsTcM wanted + = do { ev_binds_var <- newTcEvBinds + ; wanteds' <- solveWantedsTcMWithEvBinds ev_binds_var wanted solve_wanteds_and_drop + ; binds <- TcRnMonad.getTcEvBinds ev_binds_var + ; return (wanteds', binds) } +solve_wanteds_and_drop :: WantedConstraints -> TcS (WantedConstraints) +-- Since solve_wanteds returns the residual WantedConstraints, +-- it should alway be called within a runTcS or something similar, +solve_wanteds_and_drop wanted = do { wc <- solve_wanteds wanted + ; return (dropDerivedWC wc) } solve_wanteds :: WantedConstraints -> TcS WantedConstraints +-- so that the inert set doesn't mindlessly propagate. -- NB: wc_flats may be wanted /or/ derived now solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols }) = do { traceTcS "solveWanteds {" (ppr wanted) -- Try the flat bit, including insolubles. Solving insolubles a - -- second time round is a bit of a waste but the code is simple + -- second time round is a bit of a waste; but the code is simple -- and the program is wrong anyway, and we don't run the danger -- of adding Derived insolubles twice; see -- TcSMonad Note [Do not add duplicate derived insolubles] + ; traceTcS "solveFlats {" empty ; let all_flats = flats `unionBags` insols - - ; impls_from_flats <- solveInteractCts $ bagToList all_flats + ; impls_from_flats <- solveInteract all_flats + ; traceTcS "solveFlats end }" (ppr impls_from_flats) -- solve_wanteds iterates when it is able to float equalities -- out of one or more of the implications. ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats) - ; is <- getTcSInerts - ; let insoluble_flats = getInertInsols is - unsolved_flats = getInertUnsolved is + ; (unsolved_flats, insoluble_flats) <- getInertUnsolved + -- We used to unflatten here but now we only do it once at top-level + -- during zonking -- see Note [Unflattening while zonking] in TcMType + ; let wc = WC { wc_flat = unsolved_flats + , wc_impl = unsolved_implics + , wc_insol = insoluble_flats } + ; bb <- getTcEvBindsMap ; tb <- getTcSTyBindsMap - ; traceTcS "solveWanteds }" $ vcat [ text "unsolved_flats =" <+> ppr unsolved_flats , text "unsolved_implics =" <+> ppr unsolved_implics , text "current evbinds =" <+> ppr (evBindMapBinds bb) , text "current tybinds =" <+> vcat (map ppr (varEnvElts tb)) - ] - - ; let wc = WC { wc_flat = unsolved_flats - , wc_impl = unsolved_implics - , wc_insol = insoluble_flats } - - - ; traceTcS "solveWanteds finished with" $ - vcat [ text "wc (unflattened) =" <+> ppr wc ] - - ; unFlattenWC wc } - + , text "final wc =" <+> ppr wc ] + ; return wc } simpl_loop :: Int -> Bag Implication @@ -769,24 +743,13 @@ simpl_loop n implics | n > 10 = traceTcS "solveWanteds: loop!" empty >> return implics | otherwise - = do { (implic_eqs, unsolved_implics) <- solveNestedImplications implics - - ; let improve_eqs = implic_eqs - -- NB: improve_eqs used to contain defaulting equations HERE but - -- defaulting now happens only at simplifyTop and not deep inside - -- simpl_loop! See Note [Top-level Defaulting Plan] - - ; unsolved_flats <- getTcSInerts >>= (return . getInertUnsolved) - ; traceTcS "solveWanteds: simpl_loop end" $ - vcat [ text "improve_eqs =" <+> ppr improve_eqs - , text "unsolved_flats =" <+> ppr unsolved_flats - , text "unsolved_implics =" <+> ppr unsolved_implics ] - - - ; if isEmptyBag improve_eqs then return unsolved_implics - else do { impls_from_eqs <- solveInteractCts $ bagToList improve_eqs - ; simpl_loop (n+1) (unsolved_implics `unionBags` - impls_from_eqs)} } + = do { (floated_eqs, unsolved_implics) <- solveNestedImplications implics + ; if isEmptyBag floated_eqs + then return unsolved_implics + else + do { -- Put floated_eqs into the current inert set before looping + impls_from_eqs <- solveInteract floated_eqs + ; simpl_loop (n+1) (unsolved_implics `unionBags` impls_from_eqs)} } solveNestedImplications :: Bag Implication @@ -798,278 +761,153 @@ solveNestedImplications implics = return (emptyBag, emptyBag) | otherwise = do { inerts <- getTcSInerts - ; traceTcS "solveNestedImplications starting, inerts are:" $ ppr inerts - ; let (pushed_givens, thinner_inerts) = splitInertsForImplications inerts + ; let thinner_inerts = prepareInertsForImplications inerts + -- See Note [Preparing inert set for implications] - ; traceTcS "solveNestedImplications starting, more info:" $ + ; traceTcS "solveNestedImplications starting {" $ vcat [ text "original inerts = " <+> ppr inerts - , text "pushed_givens = " <+> ppr pushed_givens , text "thinner_inerts = " <+> ppr thinner_inerts ] - ; (implic_eqs, unsolved_implics) - <- doWithInert thinner_inerts $ - do { let tcs_untouchables - = foldr (unionVarSet . tyVarsOfCt) emptyVarSet pushed_givens - -- Typically pushed_givens is very small, consists - -- only of unsolved equalities, so no inefficiency - -- danger. - - - -- See Note [Preparing inert set for implications] - -- Push the unsolved wanteds inwards, but as givens - ; traceTcS "solveWanteds: preparing inerts for implications {" $ - vcat [ppr tcs_untouchables, ppr pushed_givens] - ; impls_from_givens <- solveInteractCts pushed_givens - - ; MASSERT (isEmptyBag impls_from_givens) - -- impls_from_givens must be empty, since we are reacting givens - -- with givens, and they can never generate extra implications - -- from decomposition of ForAll types. (Whereas wanteds can, see - -- TcCanonical, canEq ForAll-ForAll case) - - ; traceTcS "solveWanteds: } now doing nested implications {" empty - ; flatMapBagPairM (solveImplication tcs_untouchables) implics } + ; (floated_eqs, unsolved_implics) + <- flatMapBagPairM (solveImplication thinner_inerts) implics -- ... and we are back in the original TcS inerts -- Notice that the original includes the _insoluble_flats so it was safe to ignore -- them in the beginning of this function. - ; traceTcS "solveWanteds: done nested implications }" $ - vcat [ text "implic_eqs =" <+> ppr implic_eqs + ; traceTcS "solveNestedImplications end }" $ + vcat [ text "all floated_eqs =" <+> ppr floated_eqs , text "unsolved_implics =" <+> ppr unsolved_implics ] - ; return (implic_eqs, unsolved_implics) } + ; return (floated_eqs, unsolved_implics) } -solveImplication :: TcTyVarSet -- Untouchable TcS unification variables +solveImplication :: InertSet -> Implication -- Wanted -> TcS (Cts, -- All wanted or derived floated equalities: var = type Bag Implication) -- Unsolved rest (always empty or singleton) -- Precondition: The TcS monad contains an empty worklist and given-only inerts -- which after trying to solve this implication we must restore to their original value -solveImplication tcs_untouchables +solveImplication inerts imp@(Implic { ic_untch = untch , ic_binds = ev_binds , ic_skols = skols + , ic_fsks = old_fsks , ic_given = givens , ic_wanted = wanteds - , ic_loc = loc }) - = shadowIPs givens $ -- See Note [Shadowing of Implicit Parameters] - nestImplicTcS ev_binds (untch, tcs_untouchables) $ - recoverTcS (return (emptyBag, emptyBag)) $ - -- Recover from nested failures. Even the top level is - -- just a bunch of implications, so failing at the first one is bad + , ic_info = info + , ic_env = env }) + = do { traceTcS "solveImplication {" (ppr imp) - -- Solve flat givens - ; impls_from_givens <- solveInteractGiven loc givens - ; MASSERT (isEmptyBag impls_from_givens) - - -- Simplify the wanteds - ; WC { wc_flat = unsolved_flats - , wc_impl = unsolved_implics - , wc_insol = insols } <- solve_wanteds wanteds - - ; let (res_flat_free, res_flat_bound) - = floatEqualities skols givens unsolved_flats - - ; let res_wanted = WC { wc_flat = res_flat_bound - , wc_impl = unsolved_implics - , wc_insol = insols } - - res_implic = unitImplication $ - imp { ic_wanted = res_wanted - , ic_insol = insolubleWC res_wanted } + -- Solve the nested constraints + -- NB: 'inerts' has empty inert_fsks + ; (new_fsks, residual_wanted) + <- nestImplicTcS ev_binds untch inerts $ + do { solveInteractGiven (mkGivenLoc info env) old_fsks givens + ; residual_wanted <- solve_wanteds wanteds + -- solve_wanteds, *not* solve_wanteds_and_drop, because + -- we want to retain derived equalities so we can float + -- them out in floatEqualities + ; more_fsks <- getFlattenSkols + ; return (more_fsks ++ old_fsks, residual_wanted) } + + ; (floated_eqs, final_wanted) + <- floatEqualities (skols ++ new_fsks) givens residual_wanted + + ; let res_implic | isEmptyWC final_wanted + = emptyBag + | otherwise + = unitBag (imp { ic_fsks = new_fsks + , ic_wanted = dropDerivedWC final_wanted + , ic_insol = insolubleWC final_wanted }) ; evbinds <- getTcEvBindsMap - ; traceTcS "solveImplication end }" $ vcat - [ text "res_flat_free =" <+> ppr res_flat_free - , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) - , text "res_implic =" <+> ppr res_implic ] - - ; return (res_flat_free, res_implic) } - -- and we are back to the original inerts + [ text "floated_eqs =" <+> ppr floated_eqs + , text "new_fsks =" <+> ppr new_fsks + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) ] + ; return (floated_eqs, res_implic) } \end{code} \begin{code} -floatEqualities :: [TcTyVar] -> [EvVar] -> Cts -> (Cts, Cts) +floatEqualities :: [TcTyVar] -> [EvVar] -> WantedConstraints + -> TcS (Cts, WantedConstraints) -- Post: The returned FlavoredEvVar's are only Wanted or Derived -- and come from the input wanted ev vars or deriveds -floatEqualities skols can_given wantders - | hasEqualities can_given = (emptyBag, wantders) - -- Note [Float Equalities out of Implications] - | otherwise = partitionBag is_floatable wantders - where skol_set = mkVarSet skols - is_floatable :: Ct -> Bool - is_floatable ct - | ct_predty <- ctPred ct - , isEqPred ct_predty - = skol_set `disjointVarSet` tvs_under_fsks ct_predty - is_floatable _ct = False - - tvs_under_fsks :: Type -> TyVarSet - -- ^ NB: for type synonyms tvs_under_fsks does /not/ expand the synonym - tvs_under_fsks (TyVarTy tv) - | not (isTcTyVar tv) = unitVarSet tv - | FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty - | otherwise = unitVarSet tv - tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys) - tvs_under_fsks (LitTy {}) = emptyVarSet - tvs_under_fsks (FunTy arg res) = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res - tvs_under_fsks (AppTy fun arg) = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg - tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder - -- can mention type variables! - | isTyVar tv = inner_tvs `delVarSet` tv - | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) ) - inner_tvs `unionVarSet` tvs_under_fsks (tyVarKind tv) - where - inner_tvs = tvs_under_fsks ty - -shadowIPs :: [EvVar] -> TcS a -> TcS a -shadowIPs gs m - | null shadowed = m - | otherwise = do is <- getTcSInerts - doWithInert (purgeShadowed is) m +-- Also performs some unifications, adding to monadically-carried ty_binds +-- These will be used when processing floated_eqs later +floatEqualities skols can_given wanteds@(WC { wc_flat = flats }) + | hasEqualities can_given + = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] + | otherwise + = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats + ; promoteTyVars float_eqs + ; ty_binds <- getTcSTyBindsMap + ; traceTcS "floatEqualities" (vcat [ text "Floated eqs =" <+> ppr float_eqs + , text "Ty binds =" <+> ppr ty_binds]) + ; return (float_eqs, wanteds { wc_flat = remaining_flats }) } + where + skol_set = growSkols wanteds (mkVarSet skols) + + is_floatable :: Ct -> Bool + is_floatable ct + = isEqPred pred && skol_set `disjointVarSet` tyVarsOfType pred + where + pred = ctPred ct + +promoteTyVars :: Cts -> TcS () +-- When we float a constraint out of an implication we +-- must restore (MetaTvInv) in Note [Untouchable type variables] +-- in TcType +promoteTyVars cts + = do { untch <- TcSMonad.getUntouchables + ; mapM_ (promote_tv untch) (varSetElems (tyVarsOfCts cts)) } where - shadowed = mapMaybe isIP gs - - isIP g = do p <- evVarPred_maybe g - (x,_) <- isIPPred_maybe p - return x - - isShadowedCt ct = isShadowedEv (ctEvidence ct) - isShadowedEv ev = case isIPPred_maybe (ctEvPred ev) of - Just (x,_) -> x `elem` shadowed - _ -> False - - purgeShadowed is = is { inert_cans = purgeCans (inert_cans is) - , inert_solved = purgeSolved (inert_solved is) - } + promote_tv untch tv + | isFloatedTouchableMetaTyVar untch tv + = do { cloned_tv <- TcSMonad.cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarUntouchables cloned_tv untch + ; setWantedTyBind tv (mkTyVarTy rhs_tv) } + | otherwise + = return () + +growSkols :: WantedConstraints -> VarSet -> VarSet +-- Find all the type variables that might possibly be unified +-- with a type that mentions a skolem. This test is very conservative. +-- I don't *think* we need look inside the implications, because any +-- relevant unification variables in there are untouchable. +growSkols (WC { wc_flat = flats }) skols + = growThetaTyVars theta skols + where + theta = foldrBag ((:) . ctPred) [] flats - purgeDicts = snd . partitionCCanMap isShadowedCt - purgeCans ics = ics { inert_dicts = purgeDicts (inert_dicts ics) } - purgeSolved = filterSolved (not . isShadowedEv) +approximateWC :: WantedConstraints -> Cts +-- Postcondition: Wanted or Derived Cts +approximateWC wc = float_wc emptyVarSet wc + where + float_wc :: TcTyVarSet -> WantedConstraints -> Cts + float_wc skols (WC { wc_flat = flat, wc_impl = implic }) = floats1 `unionBags` floats2 + where floats1 = do_bag (float_flat skols) flat + floats2 = do_bag (float_implic skols) implic + + float_implic :: TcTyVarSet -> Implication -> Cts + float_implic skols imp + = float_wc skols' (ic_wanted imp) + where + skols' = skols `extendVarSetList` ic_skols imp `extendVarSetList` ic_fsks imp + + float_flat :: TcTyVarSet -> Ct -> Cts + float_flat skols ct + | tyVarsOfCt ct `disjointVarSet` skols + = singleCt ct + | otherwise = emptyCts + + do_bag :: (a -> Bag c) -> Bag a -> Bag c + do_bag f = foldrBag (unionBags.f) emptyBag \end{code} -Note [Preparing inert set for implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before solving the nested implications, we convert any unsolved flat wanteds -to givens, and add them to the inert set. Reasons: - - a) In checking mode, suppresses unnecessary errors. We already have - on unsolved-wanted error; adding it to the givens prevents any - consequential errors from showing up - - b) More importantly, in inference mode, we are going to quantify over this - constraint, and we *don't* want to quantify over any constraints that - are deducible from it. - - c) Flattened type-family equalities must be exposed to the nested - constraints. Consider - F b ~ alpha, (forall c. F b ~ alpha) - Obviously this is soluble with [alpha := F b]. But the - unification is only done by solveCTyFunEqs, right at the end of - solveWanteds, and if we aren't careful we'll end up with an - unsolved goal inside the implication. We need to "push" the - as-yes-unsolved (F b ~ alpha) inwards, as a *given*, so that it - can be used to solve the inner (F b - ~ alpha). See Trac #4935. - - d) There are other cases where interactions between wanteds that can help - to solve a constraint. For example - - class C a b | a -> b - - (C Int alpha), (forall d. C d blah => C Int a) - - If we push the (C Int alpha) inwards, as a given, it can produce - a fundep (alpha~a) and this can float out again and be used to - fix alpha. (In general we can't float class constraints out just - in case (C d blah) might help to solve (C Int a).) - -The unsolved wanteds are *canonical* but they may not be *inert*, -because when made into a given they might interact with other givens. -Hence the call to solveInteract. Example: - - Original inert set = (d :_g D a) /\ (co :_w a ~ [beta]) - -We were not able to solve (a ~w [beta]) but we can't just assume it as -given because the resulting set is not inert. Hence we have to do a -'solveInteract' step first. - -Finally, note that we convert them to [Given] and NOT [Given/Solved]. -The reason is that Given/Solved are weaker than Givens and may be discarded. -As an example consider the inference case, where we may have, the following -original constraints: - [Wanted] F Int ~ Int - (F Int ~ a => F Int ~ a) -If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next -given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting -the (F Int ~ a) insoluble. Hence we should really convert the residual -wanteds to plain old Given. - -We need only push in unsolved equalities both in checking mode and inference mode: - - (1) In checking mode we should not push given dictionaries in because of -example LongWayOverlapping.hs, where we might get strange overlap -errors between far-away constraints in the program. But even in -checking mode, we must still push type family equations. Consider: - - type instance F True a b = a - type instance F False a b = b - - [w] F c a b ~ gamma - (c ~ True) => a ~ gamma - (c ~ False) => b ~ gamma - -Since solveCTyFunEqs happens at the very end of solving, the only way to solve -the two implications is temporarily consider (F c a b ~ gamma) as Given (NB: not -merely Given/Solved because it has to interact with the top-level instance -environment) and push it inside the implications. Now, when we come out again at -the end, having solved the implications solveCTyFunEqs will solve this equality. - - (2) In inference mode, we recheck the final constraint in checking mode and -hence we will be able to solve inner implications from top-level quantified -constraints nonetheless. - - -Note [Extra TcsTv untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Whenever we are solving a bunch of flat constraints, they may contain -the following sorts of 'touchable' unification variables: - - (i) Born-touchables in that scope - - (ii) Simplifier-generated unification variables, such as unification - flatten variables - - (iii) Touchables that have been floated out from some nested - implications, see Note [Float Equalities out of Implications]. - -Now, once we are done with solving these flats and have to move inwards to -the nested implications (perhaps for a second time), we must consider all the -extra variables (categories (ii) and (iii) above) as untouchables for the -implication. Otherwise we have the danger or double unifications, as well -as the danger of not ``seing'' some unification. Example (from Trac #4494): - - (F Int ~ uf) /\ [untch=beta](forall a. C a => F Int ~ beta) - -In this example, beta is touchable inside the implication. The -first solveInteract step leaves 'uf' ununified. Then we move inside -the implication where a new constraint - uf ~ beta -emerges. We may spontaneously solve it to get uf := beta, so the whole -implication disappears but when we pop out again we are left with (F -Int ~ uf) which will be unified by our final solveCTyFunEqs stage and -uf will get unified *once more* to (F Int). - -The solution is to record the unification variables of the flats, -and make them untouchables for the nested implication. In the -example above uf would become untouchable, so beta would be forced -to be unified as beta := uf. - Note [Float Equalities out of Implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For ordinary pattern matches (including existentials) we float @@ -1115,16 +953,21 @@ Consequence: classes with functional dependencies don't matter (since there is no evidence for a fundep equality), but equality superclasses do matter (since they carry evidence). -Notice that, due to Note [Extra TcSTv Untouchables], the free unification variables -of an equality that is floated out of an implication become effectively untouchables -for the leftover implication. This is absolutely necessary. Consider the following -example. We start with two implications and a class with a functional dependency. +Note [Promoting unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an equality out of an implication we must "promote" free +unification variables of the equality, in order to maintain Invariant +(MetaTvInv) from Note [Untouchable type variables] in TcType. for the +leftover implication. -class C x y | x -> y -instance C [a] [a] - -(I1) [untch=beta]forall b. 0 => F Int ~ [beta] -(I2) [untch=beta]forall b. 0 => F Int ~ [[alpha]] /\ C beta [b] +This is absolutely necessary. Consider the following example. We start +with two implications and a class with a functional dependency. + + class C x y | x -> y + instance C [a] [a] + + (I1) [untch=beta]forall b. 0 => F Int ~ [beta] + (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. They may react to yield that (beta := [alpha]) which can then be pushed inwards @@ -1132,143 +975,27 @@ the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean tha (alpha := a). In the end we will have the skolem 'b' escaping in the untouchable beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: -class C x y | x -> y where - op :: x -> y -> () - -instance C [a] [a] - -type family F a :: * - -h :: F Int -> () -h = undefined - -data TEx where - TEx :: a -> TEx - - -f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) - -Note [Shadowing of Implicit Parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: + class C x y | x -> y where + op :: x -> y -> () -f :: (?x :: Char) => Char -f = let ?x = 'a' in ?x + instance C [a] [a] -The "let ?x = ..." generates an implication constraint of the form: + type family F a :: * -?x :: Char => ?x :: Char + h :: F Int -> () + h = undefined + data TEx where + TEx :: a -> TEx -Furthermore, the signature for `f` also generates an implication -constraint, so we end up with the following nested implication: -?x :: Char => (?x :: Char => ?x :: Char) + f (x::beta) = + let g1 :: forall b. b -> () + g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) -Note that the wanted (?x :: Char) constraint may be solved in -two incompatible ways: either by using the parameter from the -signature, or by using the local definition. Our intention is -that the local definition should "shadow" the parameter of the -signature, and we implement this as follows: when we nest implications, -we remove any implicit parameters in the outer implication, that -have the same name as givens of the inner implication. -Here is another variation of the example: - -f :: (?x :: Int) => Char -f = let ?x = 'x' in ?x - -This program should also be accepted: the two constraints `?x :: Int` -and `?x :: Char` never exist in the same context, so they don't get to -interact to cause failure. -\begin{code} - - - -unFlattenWC :: WantedConstraints -> TcS WantedConstraints -unFlattenWC wc - = do { (subst, remaining_unsolved_flats) <- solveCTyFunEqs (wc_flat wc) - -- See Note [Solving Family Equations] - -- NB: remaining_flats has already had subst applied - ; return $ - WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats - , wc_impl = mapBag (substImplication subst) (wc_impl wc) - , wc_insol = mapBag (substCt subst) (wc_insol wc) } - } - where - solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts) - -- Default equalities (F xi ~ alpha) by setting (alpha := F xi), whenever possible - -- See Note [Solving Family Equations] - -- Returns: a bunch of unsolved constraints from the original Cts and implications - -- where the newly generated equalities (alpha := F xi) have been substituted through. - solveCTyFunEqs cts - = do { untch <- getUntouchables - ; let (unsolved_can_cts, (ni_subst, cv_binds)) - = getSolvableCTyFunEqs untch cts - ; traceTcS "defaultCTyFunEqs" (vcat [text "Trying to default family equations:" - , ppr ni_subst, ppr cv_binds - ]) - ; mapM_ solve_one cv_binds - - ; return (niFixTvSubst ni_subst, unsolved_can_cts) } - where - solve_one (Wanted { ctev_evar = cv }, tv, ty) - = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty)) - solve_one (Derived {}, tv, ty) - = setWantedTyBind tv ty - solve_one arg - = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg - ------------- -type FunEqBinds = (TvSubstEnv, [(CtEvidence, TcTyVar, TcType)]) - -- The TvSubstEnv is not idempotent, but is loop-free - -- See Note [Non-idempotent substitution] in Unify -emptyFunEqBinds :: FunEqBinds -emptyFunEqBinds = (emptyVarEnv, []) - -extendFunEqBinds :: FunEqBinds -> CtEvidence -> TcTyVar -> TcType -> FunEqBinds -extendFunEqBinds (tv_subst, cv_binds) fl tv ty - = (extendVarEnv tv_subst tv ty, (fl, tv, ty):cv_binds) - ------------- -getSolvableCTyFunEqs :: TcsUntouchables - -> Cts -- Precondition: all Wanteds or Derived! - -> (Cts, FunEqBinds) -- Postcondition: returns the unsolvables -getSolvableCTyFunEqs untch cts - = Bag.foldlBag dflt_funeq (emptyCts, emptyFunEqBinds) cts - where - dflt_funeq :: (Cts, FunEqBinds) -> Ct - -> (Cts, FunEqBinds) - dflt_funeq (cts_in, feb@(tv_subst, _)) - (CFunEqCan { cc_ev = fl - , cc_fun = tc - , cc_tyargs = xis - , cc_rhs = xi }) - | Just tv <- tcGetTyVar_maybe xi -- RHS is a type variable - - , isTouchableMetaTyVar_InRange untch tv - -- And it's a *touchable* unification variable - - , typeKind xi `tcIsSubKind` tyVarKind tv - -- Must do a small kind check since TcCanonical invariants - -- on family equations only impose compatibility, not subkinding - - , not (tv `elemVarEnv` tv_subst) - -- Check not in extra_binds - -- See Note [Solving Family Equations], Point 1 - - , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis)) - -- Occurs check: see Note [Solving Family Equations], Point 2 - = ASSERT ( not (isGiven fl) ) - (cts_in, extendFunEqBinds feb fl tv (mkTyConApp tc xis)) - - dflt_funeq (cts_in, fun_eq_binds) ct - = (cts_in `extendCts` ct, fun_eq_binds) -\end{code} Note [Solving Family Equations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1288,7 +1015,10 @@ When is it ok to do so? set [beta := F xis] only if beta is not among the free variables of xis. 3) Notice that 'beta' can't be bound in ty binds already because we rewrite RHS - of type family equations. See Inert Set invariants in TcInteract. + of type family equations. See Inert Set invariants in TcInteract. + +This solving is now happening during zonking, see Note [Unflattening while zonking] +in TcMType. ********************************************************************************* @@ -1297,13 +1027,14 @@ When is it ok to do so? * * ********************************************************************************* \begin{code} -applyDefaultingRules :: Cts -- Wanteds or Deriveds - -> TcS Cts -- Derived equalities +applyDefaultingRules :: Cts -> TcS Bool + -- True <=> I did some defaulting, reflected in ty_binds + -- Return some extra derived equalities, which express the -- type-class default choice. applyDefaultingRules wanteds | isEmptyBag wanteds - = return emptyBag + = return False | otherwise = do { traceTcS "applyDefaultingRules { " $ text "wanteds =" <+> ppr wanteds @@ -1312,17 +1043,15 @@ applyDefaultingRules wanteds ; let groups = findDefaultableGroups info wanteds ; traceTcS "findDefaultableGroups" $ vcat [ text "groups=" <+> ppr groups , text "info=" <+> ppr info ] - ; deflt_cts <- mapM (disambigGroup default_tys) groups + ; something_happeneds <- mapM (disambigGroup default_tys) groups - ; traceTcS "applyDefaultingRules }" $ - vcat [ text "Type defaults =" <+> ppr deflt_cts] + ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - ; return (unionManyBags deflt_cts) } + ; return (or something_happeneds) } \end{code} Note [tryTcS in defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - defaultTyVar and disambigGroup create new evidence variables for default equations, and hence update the EvVar cache. However, after applyDefaultingRules we will try to solve these default equations @@ -1345,48 +1074,29 @@ in the cache! \begin{code} ------------------- -touchablesOfWC :: WantedConstraints -> TcTyVarSet --- See Note [Extra Tcs Untouchables] to see why we carry a TcsUntouchables --- instead of just using the Untouchable range have in our hands. -touchablesOfWC = go (NoUntouchables, emptyVarSet) - where go :: TcsUntouchables -> WantedConstraints -> TcTyVarSet - go untch (WC { wc_flat = flats, wc_impl = impls }) - = filterVarSet is_touchable flat_tvs `unionVarSet` - foldrBag (unionVarSet . (go_impl $ untch_for_impls untch)) emptyVarSet impls - where is_touchable = isTouchableMetaTyVar_InRange untch - flat_tvs = tyVarsOfCts flats - untch_for_impls (r,uset) = (r, uset `unionVarSet` flat_tvs) - go_impl (_rng,set) implic = go (ic_untch implic,set) (ic_wanted implic) - -applyTyVarDefaulting :: WantedConstraints -> TcM Cts -applyTyVarDefaulting wc = runTcS do_dflt >>= (return . fst) - where do_dflt = do { tv_cts <- mapM defaultTyVar $ - varSetElems (touchablesOfWC wc) - ; return (unionManyBags tv_cts) } - -defaultTyVar :: TcTyVar -> TcS Cts --- Precondition: a touchable meta-variable +applyTyVarDefaulting :: WantedConstraints -> TcS () +applyTyVarDefaulting wc + = do { let tvs = filter isMetaTyVar (varSetElems (tyVarsOfWC wc)) + -- tyVarsOfWC: post-simplification the WC should reflect + -- all unifications that have happened + -- filter isMetaTyVar: we might have runtime-skolems in GHCi, + -- and we definitely don't want to try to assign to those! + + ; traceTcS "applyTyVarDefaulting {" (ppr tvs) + ; mapM_ defaultTyVar tvs + ; traceTcS "applyTyVarDefaulting end }" empty } + +defaultTyVar :: TcTyVar -> TcS () defaultTyVar the_tv | not (k `eqKind` default_k) - -- Why tryTcS? See Note [tryTcS in defaulting] - = tryTcS $ - do { let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk - ; ty_k <- instFlexiTcSHelperTcS (tyVarName the_tv) default_k - ; md <- newDerived loc (mkTcEqPred (mkTyVarTy the_tv) ty_k) - -- Why not directly newDerived loc (mkTcEqPred k default_k)? + = do { tv' <- TcSMonad.cloneMetaTyVar the_tv + ; let rhs_ty = mkTyVarTy (setTyVarKind tv' default_k) + ; setWantedTyBind the_tv rhs_ty } + -- Why not directly derived_pred = mkTcEqPred k default_k? -- See Note [DefaultTyVar] - ; let cts - | Just der_ev <- md = [mkNonCanonical der_ev] - | otherwise = [] - - ; implics_from_defaulting <- solveInteractCts cts - ; MASSERT (isEmptyBag implics_from_defaulting) - - ; unsolved <- getTcSInerts >>= (return . getInertUnsolved) - ; if isEmptyBag (keepWanted unsolved) then return (listToBag cts) - else return emptyBag } - | otherwise = return emptyBag -- The common case + -- We keep the same Untouchables on tv' + + | otherwise = return () -- The common case where k = tyVarKind the_tv default_k = defaultKind k @@ -1421,37 +1131,37 @@ default is default_k we do not simply generate [D] (k ~ default_k) because: right kind. \begin{code} - - ----------------- findDefaultableGroups :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) -> Cts -- Unsolved (wanted or derived) - -> [[(Ct,TcTyVar)]] + -> [[(Ct,Class,TcTyVar)]] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | null default_tys = [] | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries) where - unaries :: [(Ct, TcTyVar)] -- (C tv) constraints + unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints non_unaries :: [Ct] -- and *other* constraints (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds) -- Finds unary type-class constraints - find_unary cc@(CDictCan { cc_tyargs = [ty] }) - | Just tv <- tcGetTyVar_maybe ty - = Left (cc, tv) + find_unary cc + | Just (cls,[ty]) <- getClassPredTys_maybe (ctPred cc) + , Just tv <- tcGetTyVar_maybe ty + , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and + -- we definitely don't want to try to assign to those! + = Left (cc, cls, tv) find_unary cc = Right cc -- Non unary or non dictionary bad_tvs :: TcTyVarSet -- TyVars mentioned by non-unaries bad_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet non_unaries - cmp_tv (_,tv1) (_,tv2) = tv1 `compare` tv2 + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - is_defaultable_group ds@((_,tv):_) + is_defaultable_group ds@((_,_,tv):_) = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] b2 = not (tv `elemVarSet` bad_tvs) - b4 = defaultable_classes [cc_class cc | (cc,_) <- ds] + b4 = defaultable_classes [cls | (_,cls,_) <- ds] in (b1 && b2 && b4) is_defaultable_group [] = panic "defaultable_group" @@ -1472,54 +1182,42 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds -- Similarly is_std_class ------------------------------ -disambigGroup :: [Type] -- The default types - -> [(Ct, TcTyVar)] -- All classes of the form (C a) - -- sharing same type variable - -> TcS Cts +disambigGroup :: [Type] -- The default types + -> [(Ct, Class, TcTyVar)] -- All classes of the form (C a) + -- sharing same type variable + -> TcS Bool -- True <=> something happened, reflected in ty_binds disambigGroup [] _grp - = return emptyBag + = return False disambigGroup (default_ty:default_tys) group = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty) ; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting] - do { derived_eq <- tryTcS $ - -- I need a new tryTcS because we will call solveInteractCts below! - do { md <- newDerived (ctev_wloc the_fl) - (mkTcEqPred (mkTyVarTy the_tv) default_ty) - -- ctev_wloc because constraint is not Given! - ; case md of - Nothing -> return [] - Just ctev -> return [ mkNonCanonical ctev ] } - + do { setWantedTyBind the_tv default_ty ; traceTcS "disambigGroup (solving) {" $ text "trying to solve constraints along with default equations ..." - ; implics_from_defaulting <- - solveInteractCts (derived_eq ++ wanteds) + ; implics_from_defaulting <- solveInteract wanteds ; MASSERT (isEmptyBag implics_from_defaulting) -- I am not certain if any implications can be generated -- but I am letting this fail aggressively if this ever happens. - ; unsolved <- getTcSInerts >>= (return . getInertUnsolved) + ; all_solved <- checkAllSolved ; traceTcS "disambigGroup (solving) }" $ - text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved) - ; if isEmptyBag (keepWanted unsolved) then -- Don't care about Derived's - return (Just $ listToBag derived_eq) - else - return Nothing - } - ; case success of - Just cts -> -- Success: record the type variable binding, and return - do { wrapWarnTcS $ warnDefaulting wanteds default_ty - ; traceTcS "disambigGroup succeeded" (ppr default_ty) - ; return cts } - Nothing -> -- Failure: try with the next type - do { traceTcS "disambigGroup failed, will try other default types" - (ppr default_ty) - ; disambigGroup default_tys group } } + text "disambigGroup solved =" <+> ppr all_solved + ; return all_solved } + ; if success then + -- Success: record the type variable binding, and return + do { setWantedTyBind the_tv default_ty + ; wrapWarnTcS $ warnDefaulting wanteds default_ty + ; traceTcS "disambigGroup succeeded" (ppr default_ty) + ; return True } + else + -- Failure: try with the next type + do { traceTcS "disambigGroup failed, will try other default types" + (ppr default_ty) + ; disambigGroup default_tys group } } where - ((the_ct,the_tv):_) = group - the_fl = cc_ev the_ct - wanteds = map fst group + ((_,_,the_tv):_) = group + wanteds = listToBag (map fstOf3 group) \end{code} Note [Avoiding spurious errors] @@ -1551,9 +1249,7 @@ newFlatWanteds orig theta where inst_to_wanted loc pty = do { v <- TcMType.newWantedEvVar pty - ; return $ - CNonCanonical { cc_ev = Wanted { ctev_evar = v - , ctev_wloc = loc - , ctev_pred = pty } - , cc_depth = 0 } } + ; return $ mkNonCanonical loc $ + CtWanted { ctev_evar = v + , ctev_pred = pty } } \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 419647bd12..21a6b7ef87 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -348,7 +348,7 @@ tcBracket brack res_ty -- We will type check this bracket again at its usage site. -- -- We build a single implication constraint with a BracketSkol; - -- that in turn tells simplifyCheck to report only definite + -- that in turn tells simplifyTop to report only definite -- errors ; (_,lie) <- captureConstraints $ newImplication BracketSkol [] [] $ @@ -872,7 +872,7 @@ runMeta show_code run_and_convert expr exn_msg <- liftIO $ Panic.safeShowException exn let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", nest 2 (text exn_msg), - if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + if show_code then text "Code:" <+> ppr expr else empty] failWithTc msg \end{code} @@ -1227,9 +1227,8 @@ reifyTyCon tc (TH.FamilyD flavour (reifyName tc) tvs' kind') instances) } - | isSynTyCon tc - = do { let (tvs, rhs) = synTyConDefn tc - ; rhs' <- reifyType rhs + | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs ; tvs' <- reifyTyVars tvs ; return (TH.TyConI (TH.TySynD (reifyName tc) tvs' rhs')) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index e25ddc7580..4d5e7d5937 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -28,7 +28,6 @@ module TcTyClsDecls ( import HsSyn import HscTypes import BuildTyCl -import TcUnify import TcRnMonad import TcEnv import TcHsSyn @@ -533,7 +532,8 @@ tcTyClDecl1 parent _calc_isrec = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "type family:" (ppr tc_name) ; checkFamFlag tc_name - ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent + ; let syn_rhs = SynFamilyTyCon { synf_open = True, synf_injective = False } + ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent ; return [ATyCon tycon] } -- "data family" declaration @@ -658,7 +658,7 @@ tcTyDefn calc_isrec tc_name tvs kind Nothing -> return () Just hs_k -> do { checkTc (kind_signatures) (badSigTyDecl tc_name) ; tc_kind <- tcLHsKind hs_k - ; _ <- unifyKind kind tc_kind + ; checkKind kind tc_kind ; return () } ; dataDeclChecks tc_name new_or_data stupid_theta cons @@ -770,12 +770,12 @@ kcTyDefn (TySynonym { td_synRhs = rhs_ty }) res_k ------------------ kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () kcResultKind Nothing res_k - = discardResult (unifyKind res_k liftedTypeKind) + = checkKind res_k liftedTypeKind -- type family F a -- defaults to type family F a :: * -kcResultKind (Just k ) res_k +kcResultKind (Just k) res_k = do { k' <- tcLHsKind k - ; discardResult (unifyKind k' res_k) } + ; checkKind k' res_k } ------------------------- -- Kind check type patterns and kind annotate the embedded type variables. @@ -1306,8 +1306,8 @@ checkValidTyCon tc | Just cl <- tyConClass_maybe tc = checkValidClass cl - | isSynTyCon tc - = case synTyConRhs tc of + | Just syn_rhs <- synTyConRhs_maybe tc + = case syn_rhs of SynFamilyTyCon {} -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 00fce7267e..3df8209eed 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -195,17 +195,6 @@ calcClassCycles cls expandTheta _ _ [] = id expandTheta seen path (pred:theta) = expandType seen path pred . expandTheta seen path theta - {- - expandTree seen path (ClassPred cls tys) - | cls `elemUniqSet` seen = - | otherwise = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path) - (substTysWith (classTyVars cls) tys (classSCTheta cls)) - expandTree seen path (TuplePred ts) = flip (foldr (expandTree seen path)) ts - expandTree _ _ (EqPred _ _) = id - expandTree _ _ (IPPred _ _) = id - expandTree seen path (IrredPred pred) = expandType seen path pred - -} - expandType seen path (TyConApp tc tys) -- Expand unsaturated classes to their superclass theta if they are yet unseen. -- If they have already been seen then we have detected an error! @@ -222,9 +211,8 @@ calcClassCycles cls -- For synonyms, try to expand them: some arguments might be -- phantoms, after all. We can expand with impunity because at -- this point the type synonym cycle check has already happened. - | isSynTyCon tc - , SynonymTyCon rhs <- synTyConRhs tc - , let (env, remainder) = papp (tyConTyVars tc) tys + | Just (tvs, rhs) <- synTyConDefn_maybe tc + , let (env, remainder) = papp tvs tys rest_tys = either (const []) id remainder = expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs) . flip (foldr (expandType seen path)) rest_tys diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index c656f0641f..b8594afcec 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -28,6 +28,9 @@ module TcType ( TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcKind, TcCoVar, + -- Untouchables + Untouchables(..), noUntouchables, pushUntouchables, isTouchable, + -------------------------------- -- MetaDetails UserTypeCtxt(..), pprUserTypeCtxt, @@ -35,9 +38,11 @@ module TcType ( MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, isSigTyVar, isOverlappableTyVar, isTyConableTyVar, - isAmbiguousTyVar, metaTvRef, + isAmbiguousTyVar, metaTvRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, - isTypeVar, isKindVar, + isTypeVar, isKindVar, + metaTyVarUntouchables, setMetaTyVarUntouchables, + isTouchableMetaTyVar, isFloatedTouchableMetaTyVar, -------------------------------- -- Builders @@ -118,7 +123,6 @@ module TcType ( openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, tcIsSubKind, splitKindFunTys, defaultKind, - mkMetaKindVar, -------------------------------- -- Rexported from Type @@ -304,13 +308,16 @@ data TcTyVarDetails -- to represent a flattening skolem variable alpha -- identified with type ty. - | MetaTv MetaInfo (IORef MetaDetails) + | MetaTv { mtv_info :: MetaInfo + , mtv_ref :: IORef MetaDetails + , mtv_untch :: Untouchables } -- See Note [Untouchable type variables] vanillaSkolemTv, superSkolemTv :: TcTyVarDetails -- See Note [Binding when looking up instances] in InstEnv vanillaSkolemTv = SkolemTv False -- Might be instantiated superSkolemTv = SkolemTv True -- Treat this as a completely distinct type +----------------------------- data MetaDetails = Flexi -- Flexi type variables unify to become Indirects | Indirect TcType @@ -331,11 +338,6 @@ data MetaInfo -- The MetaDetails, if filled in, will -- always be another SigTv or a SkolemTv - | TcsTv -- A MetaTv allocated by the constraint solver - -- Its particular property is that it is always "touchable" - -- Nevertheless, the constraint solver has to try to guess - -- what type to instantiate it to - ------------------------------------- -- UserTypeCtxt describes the origin of the polymorphic type -- in the places where we need to an expression has that type @@ -383,21 +385,92 @@ data UserTypeCtxt -- -- With gla-exts that's right, but for H98 we should complain. ---------------------------------- --- Kind variables: + +%************************************************************************ +%* * + Untoucable type variables +%* * +%************************************************************************ + +Note [Untouchable type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Each unification variable (MetaTv) + and each Implication + has a level number (of type Untouchables) + +* INVARIANTS. In a tree of Implications, + + (ImplicInv) The level number of an Implication is + STRICTLY GREATER THAN that of its parent + + (MetaTvInv) The level number of a unification variable is + LESS THAN OR EQUAL TO that of its parent + implication + +* A unification variable is *touchable* if its level number + is EQUAL TO that of its immediate parent implication. + +Note [Skolem escape prevention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only unify touchable unification variables. Because of +(MetaTvInv), there can be no occurrences of he variable further out, +so the unification can't cause the kolems to escape. Example: + data T = forall a. MkT a (a->Int) + f x (MkT v f) = length [v,x] +We decide (x::alpha), and generate an implication like + [1]forall a. (a ~ alpha[0]) +But we must not unify alpha:=a, because the skolem would escape. + +For the cases where we DO want to unify, we rely on floating the +equality. Example (with same T) + g x (MkT v f) = x && True +We decide (x::alpha), and generate an implication like + [1]forall a. (Bool ~ alpha[0]) +We do NOT unify directly, bur rather float out (if the constraint +does not memtion 'a') to get + (Bool ~ alpha[0]) /\ [1]forall a.() +and NOW we can unify alpha. + +The same idea of only unifying touchables solves another problem. +Suppose we had + (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) +In this example, beta is touchable inside the implication. The +first solveInteract step leaves 'uf' un-unified. Then we move inside +the implication where a new constraint + uf ~ beta +emerges. If we (wrongly) spontaneously solved it to get uf := beta, +the whole implication disappears but when we pop out again we are left with +(F Int ~ uf) which will be unified by our final solveCTyFunEqs stage and +uf will get unified *once more* to (F Int). + \begin{code} -mkKindName :: Unique -> Name -mkKindName unique = mkSystemName unique kind_var_occ +newtype Untouchables = Untouchables Int + +noUntouchables :: Untouchables +noUntouchables = Untouchables 0 -- 0 = outermost level + +pushUntouchables :: Untouchables -> Untouchables +pushUntouchables (Untouchables us) = Untouchables (us+1) + +isFloatedTouchable :: Untouchables -> Untouchables -> Bool +isFloatedTouchable (Untouchables ctxt_untch) (Untouchables tv_untch) + = ctxt_untch < tv_untch -mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar -mkMetaKindVar u r - = mkTcTyVar (mkKindName u) superKind (MetaTv TauTv r) +isTouchable :: Untouchables -> Untouchables -> Bool +isTouchable (Untouchables ctxt_untch) (Untouchables tv_untch) + = ctxt_untch == tv_untch -- NB: invariant ctxt_untch >= tv_untch + -- So <= would be equivalent -kind_var_occ :: OccName -- Just one for all MetaKindVars - -- They may be jiggled by tidying -kind_var_occ = mkOccName tvName "k" +checkTouchableInvariant :: Untouchables -> Untouchables -> Bool +-- Checks (MetaTvInv) from Note [Untouchable type variables] +checkTouchableInvariant (Untouchables ctxt_untch) (Untouchables tv_untch) + = ctxt_untch >= tv_untch + +instance Outputable Untouchables where + ppr (Untouchables us) = ppr us \end{code} + %************************************************************************ %* * Pretty-printing @@ -411,9 +484,12 @@ pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk") pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk") pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") -pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") -pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") -pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig") +pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) + = pp_info <> brackets (ppr untch) + where + pp_info = case info of + TauTv -> ptext (sLit "tau") + SigTv -> ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) @@ -511,20 +587,11 @@ tidyOpenTyVar env@(_, subst) tyvar Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder --------------- -tidyTyVarOcc :: TidyEnv -> TyVar -> Type -tidyTyVarOcc env@(_, subst) tv +tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar +tidyTyVarOcc (_, subst) tv = case lookupVarEnv subst tv of - Nothing -> expand tv - Just tv' -> expand tv' - where - -- Expand FlatSkols, the skolems introduced by flattening process - -- We don't want to show them in type error messages - expand tv | isTcTyVar tv - , FlatSkol ty <- tcTyVarDetails tv - = WARN( True, text "I DON'T THINK THIS SHOULD EVER HAPPEN" <+> ppr tv <+> ppr ty ) - tidyType env ty - | otherwise - = TyVarTy tv + Nothing -> tv + Just tv' -> tv' --------------- tidyTypes :: TidyEnv -> [Type] -> [Type] @@ -533,7 +600,7 @@ tidyTypes env tys = map (tidyType env) tys --------------- tidyType :: TidyEnv -> Type -> Type tidyType _ (LitTy n) = LitTy n -tidyType env (TyVarTy tv) = tidyTyVarOcc env tv +tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) @@ -595,6 +662,7 @@ tidyCo env@(_, subst) co go (SymCo co) = SymCo $! go co go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 go (NthCo d co) = NthCo d $! go co + go (LRCo lr co) = LRCo lr $! go co go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty tidyCos :: TidyEnv -> [Coercion] -> [Coercion] @@ -683,8 +751,24 @@ exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys %************************************************************************ \begin{code} -isImmutableTyVar :: TyVar -> Bool +isTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool +isTouchableMetaTyVar ctxt_untch tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_untch = tv_untch } + -> ASSERT2( checkTouchableInvariant ctxt_untch tv_untch, + ppr tv $$ ppr tv_untch $$ ppr ctxt_untch ) + isTouchable ctxt_untch tv_untch + _ -> False + +isFloatedTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool +isFloatedTouchableMetaTyVar ctxt_untch tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_untch = tv_untch } -> isFloatedTouchable ctxt_untch tv_untch + _ -> False +isImmutableTyVar :: TyVar -> Bool isImmutableTyVar tv | isTcTyVar tv = isSkolemTyVar tv | otherwise = True @@ -698,8 +782,8 @@ isTyConableTyVar tv -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv SigTv _ -> False - _ -> True + MetaTv { mtv_info = SigTv } -> False + _ -> True isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -737,19 +821,40 @@ isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv isMetaTyVarTy _ = False +metaTyVarInfo :: TcTyVar -> MetaInfo +metaTyVarInfo tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> info + _ -> pprPanic "metaTyVarInfo" (ppr tv) + +metaTyVarUntouchables :: TcTyVar -> Untouchables +metaTyVarUntouchables tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv { mtv_untch = untch } -> untch + _ -> pprPanic "metaTyVarUntouchables" (ppr tv) + +setMetaTyVarUntouchables :: TcTyVar -> Untouchables -> TcTyVar +setMetaTyVarUntouchables tv untch + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_untch = untch }) + _ -> pprPanic "metaTyVarUntouchables" (ppr tv) + isSigTyVar :: Var -> Bool isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - MetaTv SigTv _ -> True - _ -> False + MetaTv { mtv_info = SigTv } -> True + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of - MetaTv _ ref -> ref - _ -> pprPanic "metaTvRef" (ppr tv) + MetaTv { mtv_ref = ref } -> ref + _ -> pprPanic "metaTvRef" (ppr tv) isFlexi, isIndirect :: MetaDetails -> Bool isFlexi Flexi = True @@ -811,8 +916,8 @@ isTauTy _ = False isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype isTauTyCon tc - | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc)) - | otherwise = True + | Just (_, rhs) <- synTyConDefn_maybe tc = isTauTy rhs + | otherwise = True --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to @@ -1270,6 +1375,7 @@ orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNa orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 orphNamesOfCo (NthCo _ co) = orphNamesOfCo co +orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty orphNamesOfCos :: [Coercion] -> NameSet diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 6f92ccbd35..781d4c8cd1 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -19,7 +19,8 @@ module TcUnify ( checkConstraints, newImplication, -- Various unifications - unifyType, unifyTypeList, unifyTheta, unifyKind, unifyKindEq, + unifyType, unifyTypeList, unifyTheta, + unifyKindX, -------------------------------- -- Holes @@ -59,7 +60,7 @@ import VarEnv import ErrUtils import DynFlags import BasicTypes -import Maybes ( allMaybes ) +import Maybes ( allMaybes, isJust ) import Util import Outputable import FastString @@ -424,11 +425,12 @@ newImplication :: SkolemInfo -> [TcTyVar] newImplication skol_info skol_tvs given thing_inside = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { ((result, untch), wanted) <- captureConstraints $ + do { let no_equalities = not (hasEqualities given) + ; ((result, untch), wanted) <- captureConstraints $ captureUntouchables $ thing_inside - ; if isEmptyWC wanted && not (hasEqualities given) + ; if isEmptyWC wanted && no_equalities -- Optimisation : if there are no wanteds, and the givens -- are sufficiently simple, don't generate an implication -- at all. Reason for the hasEqualities test: @@ -438,16 +440,16 @@ newImplication skol_info skol_tvs given thing_inside return (emptyTcEvBinds, result) else do { ev_binds_var <- newTcEvBinds - ; lcl_env <- getLclTypeEnv - ; loc <- getCtLoc skol_info + ; env <- getLclEnv ; emitImplication $ Implic { ic_untch = untch - , ic_env = lcl_env , ic_skols = skol_tvs + , ic_fsks = [] , ic_given = given , ic_wanted = wanted , ic_insol = insolubleWC wanted , ic_binds = ev_binds_var - , ic_loc = loc } + , ic_env = env + , ic_info = skol_info } ; return (TcEvBinds ev_binds_var, result) } } \end{code} @@ -465,7 +467,9 @@ non-exported generic functions. unifyType :: TcTauType -> TcTauType -> TcM TcCoercion -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 -unifyType ty1 ty2 = uType [] ty1 ty2 +unifyType ty1 ty2 = uType origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } --------------- unifyPred :: PredType -> PredType -> TcM TcCoercion @@ -507,21 +511,9 @@ second, except that if the first is a synonym then the second may be a de-synonym'd version. This way we get better error messages. \begin{code} -data SwapFlag - = NotSwapped -- Args are: actual, expected - | IsSwapped -- Args are: expected, actual - -instance Outputable SwapFlag where - ppr IsSwapped = ptext (sLit "Is-swapped") - ppr NotSwapped = ptext (sLit "Not-swapped") - -unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b -unSwap NotSwapped f a b = f a b -unSwap IsSwapped f a b = f b a - ------------ -uType, uType_np, uType_defer - :: [EqOrigin] +uType, uType_defer + :: CtOrigin -> TcType -- ty1 is the *actual* type -> TcType -- ty2 is the *expected* type -> TcM TcCoercion @@ -529,13 +521,12 @@ uType, uType_np, uType_defer -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] -uType_defer items ty1 ty2 - = ASSERT( not (null items) ) - do { eqv <- newEq ty1 ty2 - ; loc <- getCtLoc (TypeEqOrigin (last items)) - ; let ctev = Wanted { ctev_wloc = loc, ctev_evar = eqv - , ctev_pred = mkTcEqPred ty1 ty2 } - ; emitFlat $ mkNonCanonical ctev +uType_defer origin ty1 ty2 + = do { eqv <- newEq ty1 ty2 + ; loc <- getCtLoc origin + ; let ctev = CtWanted { ctev_evar = eqv + , ctev_pred = mkTcEqPred ty1 ty2 } + ; emitFlat $ mkNonCanonical loc ctev -- Error trace only -- NB. do *not* call mkErrInfo unless tracing is on, because @@ -544,20 +535,17 @@ uType_defer items ty1 ty2 { ctxt <- getErrCtxt ; doc <- mkErrInfo emptyTidyEnv ctxt ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, - ppr ty2, ppr items, doc]) + ppr ty2, ppr origin, doc]) } ; return (mkTcCoVarCo eqv) } -------------- --- Push a new item on the origin stack (the most common case) -uType origin ty1 ty2 -- Push a new item on the origin stack - = uType_np (pushOrigin ty1 ty2 origin) ty1 ty2 - --------------- -- unify_np (short for "no push" on the origin stack) does the work -uType_np origin orig_ty1 orig_ty2 - = do { traceTc "u_tys " $ vcat - [ sep [ ppr orig_ty1, text "~", ppr orig_ty2] +uType origin orig_ty1 orig_ty2 + = do { untch <- getUntouchables + ; traceTc "u_tys " $ vcat + [ text "untch" <+> ppr untch + , sep [ ppr orig_ty1, text "~", ppr orig_ty2] , ppr origin] ; co <- go orig_ty1 orig_ty2 ; if isTcReflCo co @@ -644,11 +632,11 @@ uType_np origin orig_ty1 orig_ty2 ------------------ go_app s1 t1 s2 t2 - = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] + = do { co_s <- uType origin s1 s2 -- See Note [Unifying AppTy] ; co_t <- uType origin t1 t2 ; return $ mkTcAppCo co_s co_t } -unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM TcCoercion +unifySigmaTy :: CtOrigin -> TcType -> TcType -> TcM TcCoercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 @@ -755,7 +743,7 @@ of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uUnfilledVar :: [EqOrigin] +uUnfilledVar :: CtOrigin -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTauType -- Type 2 @@ -776,10 +764,12 @@ uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2) uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type variable = case details1 of - MetaTv TauTv ref1 + MetaTv { mtv_info = TauTv, mtv_ref = ref1 } -> do { mb_ty2' <- checkTauTvUpdate tv1 non_var_ty2 ; case mb_ty2' of - Nothing -> do { traceTc "Occ/kind defer" (ppr tv1); defer } + Nothing -> do { traceTc "Occ/kind defer" (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + $$ ppr non_var_ty2 $$ ppr (typeKind non_var_ty2)) + ; defer } Just ty2' -> updateMeta tv1 ref1 ty2' } @@ -795,7 +785,7 @@ uUnfilledVar origin swapped tv1 details1 non_var_ty2 -- ty2 is not a type varia -- eg tv1 occured in type family parameter ---------------- -uUnfilledVars :: [EqOrigin] +uUnfilledVars :: CtOrigin -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTyVar -> TcTyVarDetails -- Tyvar 2 @@ -806,31 +796,34 @@ uUnfilledVars :: [EqOrigin] uUnfilledVars origin swapped tv1 details1 tv2 details2 = do { traceTc "uUnfilledVars" ( text "trying to unify" <+> ppr k1 <+> text "with" <+> ppr k2) - ; let ctxt = mkKindErrorCtxt ty1 ty2 k1 k2 - ; sub_kind <- addErrCtxtM ctxt $ unifyKind k1 k2 + ; mb_sub_kind <- unifyKindX k1 k2 + ; case mb_sub_kind of { + Nothing -> unSwap swapped (uType_defer origin) (mkTyVarTy tv1) ty2 ; + Just sub_kind -> - ; case (sub_kind, details1, details2) of + case (sub_kind, details1, details2) of -- k1 < k2, so update tv2 - (LT, _, MetaTv _ ref2) -> updateMeta tv2 ref2 ty1 + (LT, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 -- k2 < k1, so update tv1 - (GT, MetaTv _ ref1, _) -> updateMeta tv1 ref1 ty2 + (GT, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 -- k1 = k2, so we are free to update either way - (EQ, MetaTv i1 ref1, MetaTv i2 ref2) + (EQ, MetaTv { mtv_info = i1, mtv_ref = ref1 }, + MetaTv { mtv_info = i2, mtv_ref = ref2 }) | nicer_to_update_tv1 i1 i2 -> updateMeta tv1 ref1 ty2 | otherwise -> updateMeta tv2 ref2 ty1 - (EQ, MetaTv _ ref1, _) -> updateMeta tv1 ref1 ty2 - (EQ, _, MetaTv _ ref2) -> updateMeta tv2 ref2 ty1 + (EQ, MetaTv { mtv_ref = ref1 }, _) -> updateMeta tv1 ref1 ty2 + (EQ, _, MetaTv { mtv_ref = ref2 }) -> updateMeta tv2 ref2 ty1 -- Can't do it in-place, so defer -- This happens for skolems of all sorts - (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } + (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } } where - k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - ty1 = mkTyVarTy tv1 - ty2 = mkTyVarTy tv2 + k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + ty1 = mkTyVarTy tv1 + ty2 = mkTyVarTy tv2 nicer_to_update_tv1 _ SigTv = True nicer_to_update_tv1 SigTv _ = False @@ -863,17 +856,21 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType) -- we return Nothing, leaving it to the later constraint simplifier to -- sort matters out. -checkTauTvUpdate tv ty - = do { ty' <- zonkTcType ty - ; let k2 = typeKind ty' - ; k1 <- zonkTcKind (tyVarKind tv) - ; let ctxt = mkKindErrorCtxt (mkTyVarTy tv) ty' k1 k2 - ; sub_k <- addErrCtxtM ctxt $ - unifyKind (tyVarKind tv) (typeKind ty') +-- Used in debug meesages only +_ppr_sub :: Maybe Ordering -> SDoc +_ppr_sub (Just LT) = text "LT" +_ppr_sub (Just EQ) = text "EQ" +_ppr_sub (Just GT) = text "GT" +_ppr_sub Nothing = text "Nothing" +checkTauTvUpdate tv ty + = do { ty' <- zonkTcType ty + ; sub_k <- unifyKindX (tyVarKind tv) (typeKind ty') +-- ; traceTc "checktttv" (ppr tv $$ ppr ty' $$ ppr (tyVarKind tv) $$ ppr (typeKind ty') $$ _ppr_sub sub_k) ; case sub_k of - LT -> return Nothing - _ -> return (ok ty') } + Nothing -> return Nothing + Just LT -> return Nothing + _ -> return (ok ty') } where ok :: TcType -> Maybe TcType -- Checks that tv does not occur in the arg type @@ -933,7 +930,7 @@ function @occ_check_ok@. Note [Type family sharing] -~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~ We must avoid eagerly unifying type variables to types that contain function symbols, because this may lead to loss of sharing, and in turn, in very poor performance of the constraint simplifier. Assume that we have a wanted constraint: @@ -967,15 +964,16 @@ data LookupTyVarResult -- The result of a lookupTcTyVar call lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult lookupTcTyVar tyvar - | MetaTv _ ref <- details + | MetaTv { mtv_ref = ref } <- details = do { meta_details <- readMutVar ref ; case meta_details of Indirect ty -> return (Filled ty) - Flexi -> do { is_untch <- isUntouchable tyvar - ; let -- Note [Unifying untouchables] - ret_details | is_untch = vanillaSkolemTv - | otherwise = details - ; return (Unfilled ret_details) } } + Flexi -> do { is_touchable <- isTouchableTcM tyvar + -- Note [Unifying untouchables] + ; if is_touchable then + return (Unfilled details) + else + return (Unfilled vanillaSkolemTv) } } | otherwise = return (Unfilled details) where @@ -997,50 +995,6 @@ we return a made-up TcTyVarDetails, but I think it works smoothly. %************************************************************************ %* * - Errors and contexts -%* * -%************************************************************************ - -\begin{code} -pushOrigin :: TcType -> TcType -> [EqOrigin] -> [EqOrigin] -pushOrigin ty_act ty_exp origin - = UnifyOrigin { uo_actual = ty_act, uo_expected = ty_exp } : origin -\end{code} - - ------------------------------------------ - UNUSED FOR NOW ------------------------------------------ - ----------------- ----------------- --- If an error happens we try to figure out whether the function --- function has been given too many or too few arguments, and say so. -addSubCtxt :: InstOrigin -> TcType -> TcType -> TcM a -> TcM a -addSubCtxt orig actual_res_ty expected_res_ty thing_inside - = addErrCtxtM mk_err thing_inside - where - mk_err tidy_env - = do { exp_ty' <- zonkTcType expected_res_ty - ; act_ty' <- zonkTcType actual_res_ty - ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty' - (env2, act_ty'') = tidyOpenType env1 act_ty' - (exp_args, _) = tcSplitFunTys exp_ty'' - (act_args, _) = tcSplitFunTys act_ty'' - - len_act_args = length act_args - len_exp_args = length exp_args - - message = case orig of - OccurrenceOf fun - | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun - | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun - _ -> mkExpectedActualMsg act_ty'' exp_ty'' - ; return (env2, message) } - - -%************************************************************************ -%* * Kind unification %* * %************************************************************************ @@ -1059,63 +1013,66 @@ happy to have types of kind Constraint on either end of an arrow. matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing -matchExpectedFunKind (TyVarTy kvar) = do - maybe_kind <- readMetaTyVar kvar - case maybe_kind of - Indirect fun_kind -> matchExpectedFunKind fun_kind - Flexi -> - do { arg_kind <- newMetaKindVar - ; res_kind <- newMetaKindVar - ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) - ; return (Just (arg_kind,res_kind)) } +matchExpectedFunKind (FunTy arg_kind res_kind) + = return (Just (arg_kind,res_kind)) -matchExpectedFunKind (FunTy arg_kind res_kind) = return (Just (arg_kind,res_kind)) -matchExpectedFunKind _ = return Nothing +matchExpectedFunKind (TyVarTy kvar) + | isTcTyVar kvar, isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> matchExpectedFunKind fun_kind + Flexi -> + do { arg_kind <- newMetaKindVar + ; res_kind <- newMetaKindVar + ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) + ; return (Just (arg_kind,res_kind)) } } ------------------ -unifyKind :: TcKind -- k1 (actual) - -> TcKind -- k2 (expected) - -> TcM Ordering -- Returns the relation between the kinds - -- LT <=> k1 is a sub-kind of k2 +matchExpectedFunKind _ = return Nothing --- unifyKind deals with the top-level sub-kinding story +----------------- +unifyKindX :: TcKind -- k1 (actual) + -> TcKind -- k2 (expected) + -> TcM (Maybe Ordering) + -- Returns the relation between the kinds + -- Just LT <=> k1 is a sub-kind of k2 + -- Nothing <=> incomparable + +-- unifyKindX deals with the top-level sub-kinding story -- but recurses into the simpler unifyKindEq for any sub-terms -- The sub-kinding stuff only applies at top level -unifyKind (TyVarTy kv1) k2 = uKVar False unifyKind EQ kv1 k2 -unifyKind k1 (TyVarTy kv2) = uKVar True unifyKind EQ kv2 k1 +unifyKindX (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindX kv1 k2 +unifyKindX k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindX kv2 k1 -unifyKind k1 k2 -- See Note [Expanding synonyms during unification] - | Just k1' <- tcView k1 = unifyKind k1' k2 - | Just k2' <- tcView k2 = unifyKind k1 k2' +unifyKindX k1 k2 -- See Note [Expanding synonyms during unification] + | Just k1' <- tcView k1 = unifyKindX k1' k2 + | Just k2' <- tcView k2 = unifyKindX k1 k2' -unifyKind k1@(TyConApp kc1 []) k2@(TyConApp kc2 []) - | kc1 == kc2 = return EQ - | kc1 `tcIsSubKindCon` kc2 = return LT - | kc2 `tcIsSubKindCon` kc1 = return GT - | otherwise = unifyKindMisMatch k1 k2 +unifyKindX (TyConApp kc1 []) (TyConApp kc2 []) + | kc1 == kc2 = return (Just EQ) + | kc1 `tcIsSubKindCon` kc2 = return (Just LT) + | kc2 `tcIsSubKindCon` kc1 = return (Just GT) + | otherwise = return Nothing -unifyKind k1 k2 = do { unifyKindEq k1 k2; return EQ } +unifyKindX k1 k2 = unifyKindEq k1 k2 -- In all other cases, let unifyKindEq do the work -uKVar :: Bool -> (TcKind -> TcKind -> TcM a) -> a - -> MetaKindVar -> TcKind -> TcM a -uKVar isFlipped unify_kind eq_res kv1 k2 +uKVar :: SwapFlag -> (TcKind -> TcKind -> TcM (Maybe Ordering)) + -> MetaKindVar -> TcKind -> TcM (Maybe Ordering) +uKVar swapped unify_kind kv1 k2 | isTcTyVar kv1, isMetaTyVar kv1 -- See Note [Unifying kind variables] = do { mb_k1 <- readMetaTyVar kv1 ; case mb_k1 of - Flexi -> do { uUnboundKVar kv1 k2; return eq_res } - Indirect k1 -> if isFlipped then unify_kind k2 k1 - else unify_kind k1 k2 } + Flexi -> uUnboundKVar kv1 k2 + Indirect k1 -> unSwap swapped unify_kind k1 k2 } | TyVarTy kv2 <- k2, kv1 == kv2 - = return eq_res + = return (Just EQ) | TyVarTy kv2 <- k2, isTcTyVar kv2, isMetaTyVar kv2 - = uKVar (not isFlipped) unify_kind eq_res kv2 (TyVarTy kv1) + = uKVar (flipSwap swapped) unify_kind kv2 (TyVarTy kv1) - | otherwise = if isFlipped - then unifyKindMisMatch k2 (TyVarTy kv1) - else unifyKindMisMatch (TyVarTy kv1) k2 + | otherwise + = return Nothing {- Note [Unifying kind variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1133,49 +1090,49 @@ Hence the isTcTyVar tests before using isMetaTyVar. -} --------------------------- -unifyKindEq :: TcKind -> TcKind -> TcM () -unifyKindEq (TyVarTy kv1) k2 = uKVar False unifyKindEq () kv1 k2 -unifyKindEq k1 (TyVarTy kv2) = uKVar True unifyKindEq () kv2 k1 +unifyKindEq :: TcKind -> TcKind -> TcM (Maybe Ordering) +-- Unify two kinds looking for equality not sub-kinding +-- So it returns Nothing or (Just EQ) only +unifyKindEq (TyVarTy kv1) k2 = uKVar NotSwapped unifyKindEq kv1 k2 +unifyKindEq k1 (TyVarTy kv2) = uKVar IsSwapped unifyKindEq kv2 k1 unifyKindEq (FunTy a1 r1) (FunTy a2 r2) - = do { unifyKindEq a1 a2; unifyKindEq r1 r2 } + = do { mb1 <- unifyKindEq a1 a2; mb2 <- unifyKindEq r1 r2 + ; return (if isJust mb1 && isJust mb2 then Just EQ else Nothing) } unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) | kc1 == kc2 = ASSERT (length k1s == length k2s) -- Should succeed since the kind constructors are the same, -- and the kinds are sort-checked, thus fully applied - zipWithM_ unifyKindEq k1s k2s + do { mb_eqs <- zipWithM unifyKindEq k1s k2s + ; return (if all isJust mb_eqs + then Just EQ + else Nothing) } -unifyKindEq k1 k2 = unifyKindMisMatch k1 k2 +unifyKindEq _ _ = return Nothing ---------------- -uUnboundKVar :: MetaKindVar -> TcKind -> TcM () +uUnboundKVar :: MetaKindVar -> TcKind -> TcM (Maybe Ordering) uUnboundKVar kv1 k2@(TyVarTy kv2) - | kv1 == kv2 = return () + | kv1 == kv2 = return (Just EQ) | isTcTyVar kv2, isMetaTyVar kv2 -- Distinct kind variables = do { mb_k2 <- readMetaTyVar kv2 ; case mb_k2 of Indirect k2 -> uUnboundKVar kv1 k2 - Flexi -> writeMetaTyVar kv1 k2 } - | otherwise = writeMetaTyVar kv1 k2 + Flexi -> do { writeMetaTyVar kv1 k2; return (Just EQ) } } + | otherwise + = do { writeMetaTyVar kv1 k2; return (Just EQ) } uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 ; let k2'' = defaultKind k2' -- MetaKindVars must be bound only to simple kinds - ; kindUnifCheck kv1 k2'' - ; writeMetaTyVar kv1 k2'' } ----------------- -kindUnifCheck :: TyVar -> Type -> TcM () -kindUnifCheck kv1 k2 -- k2 is zonked - | elemVarSet kv1 (tyVarsOfType k2) - = failWithTc (kindOccurCheckErr kv1 k2) - | isSigTyVar kv1 - = failWithTc (kindSigVarErr kv1 k2) - | otherwise - = return () + ; if not (elemVarSet kv1 (tyVarsOfType k2'')) + && not (isSigTyVar kv1) + then do { writeMetaTyVar kv1 k2''; return (Just EQ) } + else return Nothing } mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 @@ -1188,28 +1145,7 @@ mkKindErrorCtxt ty1 ty2 k1 k2 env0 k1 <- zonkTcKind k1' k2 <- zonkTcKind k2' return (env4, - vcat [ ptext (sLit "Kind incompatibility when matching types:") + vcat [ ptext (sLit "Kind incompatibility when matching types xx:") , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]) - -unifyKindMisMatch :: TcKind -> TcKind -> TcM a -unifyKindMisMatch ki1 ki2 = do - ki1' <- zonkTcKind ki1 - ki2' <- zonkTcKind ki2 - let msg = hang (ptext (sLit "Couldn't match kind")) - 2 (sep [quotes (ppr ki1'), - ptext (sLit "against"), - quotes (ppr ki2')]) - failWithTc msg - ----------------- -kindOccurCheckErr :: Var -> Type -> SDoc -kindOccurCheckErr tyvar ty - = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:")) - 2 (sep [ppr tyvar, char '=', ppr ty]) - -kindSigVarErr :: Var -> Type -> SDoc -kindSigVarErr tv ty - = hang (ptext (sLit "Cannot unify the kind variable") <+> quotes (ppr tv)) - 2 (ptext (sLit "with the kind") <+> quotes (ppr ty)) \end{code} diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index 4d07229963..aa93536705 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -1,6 +1,6 @@ \begin{code} module TcUnify where -import TcType ( TcTauType, TcKind, Type, Kind ) +import TcType ( TcTauType, Type, Kind ) import VarEnv ( TidyEnv ) import TcRnTypes ( TcM ) import TcEvidence ( TcCoercion ) @@ -10,6 +10,5 @@ import Outputable ( SDoc ) -- TcUnify and Inst unifyType :: TcTauType -> TcTauType -> TcM TcCoercion -unifyKindEq :: TcKind -> TcKind -> TcM () mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) \end{code} diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 42e54ba47b..4599ddf04a 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -17,6 +17,7 @@ module Coercion ( -- * Main data type Coercion(..), Var, CoVar, + LeftOrRight(..), pickLR, -- ** Functions over coercions coVarKind, @@ -31,7 +32,7 @@ module Coercion ( mkReflCo, mkCoVarCo, mkAxInstCo, mkAxInstRHS, mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkNthCo, + mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, mkForAllCo, mkUnsafeCo, mkNewTypeCo, @@ -148,9 +149,17 @@ data Coercion | TransCo Coercion Coercion -- These are destructors - | NthCo Int Coercion -- Zero-indexed + | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) | InstCo Coercion Type deriving (Data.Data, Data.Typeable) + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data.Data, Data.Typeable ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r \end{code} @@ -337,6 +346,7 @@ tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType t tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (LRCo _ co) = tyCoVarsOfCo co tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty tyCoVarsOfCos :: [Coercion] -> VarSet @@ -354,6 +364,7 @@ coVarsOfCo (UnsafeCo _ _) = emptyVarSet coVarsOfCo (SymCo co) = coVarsOfCo co coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (LRCo _ co) = coVarsOfCo co coVarsOfCo (InstCo co _) = coVarsOfCo co coVarsOfCos :: [Coercion] -> VarSet @@ -370,6 +381,7 @@ coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2 coercionSize (SymCo co) = 1 + coercionSize co coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 coercionSize (NthCo _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty \end{code} @@ -404,20 +416,29 @@ ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ pprCo co1 <+> ppr_co TyConPrec co2 ppr_co p co@(ForAllCo {}) = ppr_forall_co p co ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con cos) = angleBrackets (pprTypeNameApp p ppr_co (getName con) cos) +ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos -ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ - ppr_co FunPrec co1 - <+> ptext (sLit ";") - <+> ppr_co FunPrec co2 +ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ + case trans_co_list co [] of + [] -> panic "ppr_co" + (co:cos) -> sep ( ppr_co FunPrec co + : [ char ';' <+> ppr_co FunPrec co | co <- cos]) ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ pprParendCo co <> ptext (sLit "@") <> pprType ty ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2] ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] -ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] +ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] + +trans_co_list :: Coercion -> [Coercion] -> [Coercion] +trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos) +trans_co_list co cos = co : cos +instance Outputable LeftOrRight where + ppr CLeft = ptext (sLit "Left") + ppr CRight = ptext (sLit "Right") ppr_fun_co :: Prec -> Coercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) @@ -625,6 +646,10 @@ mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) where Pair _ty1 _ty2 = coercionKind co +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr (Refl ty) = Refl (pickLR lr (splitAppTy ty)) +mkLRCo lr co = LRCo lr co + ok_tc_app :: Type -> Int -> Bool ok_tc_app ty n = case splitTyConApp_maybe ty of Just (_, tys) -> tys `lengthExceeds` n @@ -759,6 +784,8 @@ coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22) coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2) = d1 == d2 && coreEqCoercion2 env co1 co2 +coreEqCoercion2 env (LRCo d1 co1) (LRCo d2 co2) + = d1 == d2 && coreEqCoercion2 env co1 co2 coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 @@ -900,6 +927,7 @@ subst_co subst co go (SymCo co) = mkSymCo (go co) go (TransCo co1 co2) = mkTransCo (go co1) (go co2) go (NthCo d co) = mkNthCo d (go co) + go (LRCo lr co) = mkLRCo lr (go co) go (InstCo co ty) = mkInstCo (go co) $! go_ty ty substCoVar :: CvSubst -> CoVar -> Coercion @@ -1073,6 +1101,7 @@ seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2 seqCo (SymCo co) = seqCo co seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 seqCo (NthCo _ co) = seqCo co +seqCo (LRCo _ co) = seqCo co seqCo (InstCo co ty) = seqCo co `seq` seqType ty seqCos :: [Coercion] -> () @@ -1114,6 +1143,7 @@ coercionKind co = go co go (SymCo co) = swap $ go co go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) go (NthCo d co) = tyConAppArgN d <$> go co + go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co go (InstCo aco ty) = go_app aco [ty] go_app :: Coercion -> [Type] -> Pair Type diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 388846b8ee..f99b0a1bdd 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -61,6 +61,10 @@ data ClsInst -- forall is_tvs. (...) => is_cls is_tys , is_dfun :: DFunId -- See Note [Haddock assumptions] + -- See Note [Silent superclass arguments] in TcInstDcls + -- for how to map the DFun's type back to the source + -- language instance decl + , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag } @@ -159,6 +163,7 @@ pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) let theta_to_print | debugStyle sty = theta | otherwise = drop (dfunNSilent dfun) theta + -- See Note [Silent superclass arguments] in TcInstDcls in ptext (sLit "instance") <+> ppr flag <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty] where diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index 7d707c33c4..a039fe5b3f 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -145,7 +145,7 @@ opt_co' env sym (TransCo co1 co2) opt_co' env sym (NthCo n co) | TyConAppCo tc cos <- co' - , isDecomposableTyCon tc -- Not synonym families + , isDecomposableTyCon tc -- Not synonym families = ASSERT( n < length cos ) cos !! n | otherwise @@ -153,6 +153,14 @@ opt_co' env sym (NthCo n co) where co' = opt_co env sym co +opt_co' env sym (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co' + = pickLR lr pr_co + | otherwise + = LRCo lr co' + where + co' = opt_co env sym co + opt_co' env sym (InstCo co ty) -- See if the first arg is already a forall -- ...then we can just extend the current substitution @@ -165,7 +173,6 @@ opt_co' env sym (InstCo co ty) = substCoWithTy (getCvInScope env) tv ty' co'_body | otherwise = InstCo co' ty' - where co' = opt_co env sym co ty' = substTy env ty @@ -208,18 +215,19 @@ opt_trans2 _ co1 co2 -- Optimize coercions with a top-level use of transitivity. opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo --- push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) - | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $ - TyConAppCo tc1 (opt_transList is cos1 cos2) - --- push transitivity through matching destructors +-- Push transitivity through matching destructors opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) | d1 == d2 , co1 `compatible_co` co2 = fireTransRule "PushNth" in_co1 in_co2 $ mkNthCo d1 (opt_trans is co1 co2) +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + -- Push transitivity inside instantiation opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) | ty1 `eqType` ty2 @@ -227,11 +235,17 @@ opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) = fireTransRule "TrPushInst" in_co1 in_co2 $ mkInstCo (opt_trans is co1 co2) ty1 --- Push transitivity inside apply +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) + | tc1 == tc2 + = fireTransRule "PushTyConApp" in_co1 in_co2 $ + TyConAppCo tc1 (opt_transList is cos1 cos2) + opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) = fireTransRule "TrPushApp" in_co1 in_co2 $ mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) +-- Eta rules opt_trans_rule is co1@(TyConAppCo tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( length cos1 == length cos2 ) @@ -244,6 +258,16 @@ opt_trans_rule is co1 co2@(TyConAppCo tc cos2) fireTransRule "EtaCompR" co1 co2 $ TyConAppCo tc (opt_transList is cos1 cos2) +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = fireTransRule "EtaAppL" co1 co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = fireTransRule "EtaAppR" co1 co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + -- Push transitivity inside forall opt_trans_rule is co1 co2 | Just (tv1,r1) <- splitForAllCo_maybe co1 @@ -359,6 +383,21 @@ etaForAllCo_maybe co | otherwise = Nothing +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | Pair ty1 ty2 <- coercionKind co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] -- If possible, split a coercion -- g :: T s1 .. sn ~ T t1 .. tn @@ -383,3 +422,25 @@ etaTyConAppCo_maybe tc co | otherwise = Nothing \end{code} + +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Supopse we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +becuase it's poossible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 56e8a2ed39..5919779703 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -12,7 +12,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - SynTyConRhs(..), + SynTyConRhs(..), -- ** Coercion axiom constructors CoAxiom(..), @@ -38,7 +38,7 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isClosedSynTyCon, + isSynTyCon, isOpenSynFamilyTyCon, isDecomposableTyCon, isForeignTyCon, isPromotedDataCon, isPromotedTyCon, @@ -67,7 +67,7 @@ module TyCon( tyConParent, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - synTyConDefn, synTyConRhs, synTyConType, + synTyConDefn_maybe, synTyConRhs_maybe, tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, @@ -359,8 +359,8 @@ data TyCon tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs, -- ^ Contains information about the - -- expansion of the synonym + synTcRhs :: SynTyConRhs Type, -- ^ Contains information about the + -- expansion of the synonym synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' -- of 'TyCon's representing family instances @@ -566,17 +566,28 @@ isNoParent _ = False -------------------- -- | Information pertaining to the expansion of a type synonym (@type@) -data SynTyConRhs +data SynTyConRhs ty = -- | An ordinary type synonyn. SynonymTyCon - Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. + ty -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. -- It acts as a template for the expansion when the 'TyCon' -- is applied to some types. -- | A type synonym family e.g. @type family F x y :: * -> *@ - | SynFamilyTyCon + | SynFamilyTyCon { + synf_open :: Bool, -- See Note [Closed type families] + synf_injective :: Bool + } \end{code} +Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put instnaces where the family + is defined. GHC doesn't support syntax for this yet. + Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A data constructor can be promoted to become a type constructor, @@ -918,7 +929,7 @@ mkPrimTyCon' name kind arity rep is_unlifted } -- | Create a type synonym 'TyCon' -mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon +mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs Type -> TyConParent -> TyCon mkSynTyCon name kind tyvars rhs parent = SynTyCon { tyConName = name, @@ -1106,15 +1117,15 @@ isSynFamilyTyCon :: TyCon -> Bool isSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True isSynFamilyTyCon _ = False +isOpenSynFamilyTyCon :: TyCon -> Bool +isOpenSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon { synf_open = is_open } }) = is_open +isOpenSynFamilyTyCon _ = False + -- | Is this a synonym 'TyCon' that can have may have further instances appear? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True isDataFamilyTyCon _ = False --- | Is this a synonym 'TyCon' that can have no further instances appear? -isClosedSynTyCon :: TyCon -> Bool -isClosedSynTyCon tycon = isSynTyCon tycon && not (isFamilyTyCon tycon) - -- | Injective 'TyCon's can be decomposed, so that -- T ty1 ~ T ty2 => ty1 ~ ty2 isInjectiveTyCon :: TyCon -> Bool @@ -1351,26 +1362,17 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} \begin{code} --- | Extract the 'TyVar's bound by a type synonym and the corresponding (unsubstituted) right hand side. --- If the given 'TyCon' is not a type synonym, panics -synTyConDefn :: TyCon -> ([TyVar], Type) -synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) - = (tyvars, ty) -synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) - --- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. Panics --- if the given 'TyCon' is not a type synonym -synTyConRhs :: TyCon -> SynTyConRhs -synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs -synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) - --- | Find the expansion of the type synonym represented by the given 'TyCon'. The free variables of this --- type will typically include those 'TyVar's bound by the 'TyCon'. Panics if the 'TyCon' is not that of --- a type synonym -synTyConType :: TyCon -> Type -synTyConType tc = case synTcRhs tc of - SynonymTyCon t -> t - _ -> pprPanic "synTyConType" (ppr tc) +-- | Extract the 'TyVar's bound by a vanilla type synonym (not familiy) +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe (SynTyConRhs Type) +synTyConRhs_maybe (SynTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing \end{code} \begin{code} diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 4e8e631015..a8fb161b7f 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -54,7 +54,8 @@ module Type ( isDictLikeTy, mkEqPred, mkPrimEqPred, mkClassPred, - noParenPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe, + noParenPred, isClassPred, isEqPred, + isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, -- Deconstructing predicate types PredTree(..), predTreePredType, classifyPredType, @@ -152,7 +153,7 @@ import Class import TyCon import TysPrim import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy ) -import PrelNames ( eqTyConKey, ipClassName ) +import PrelNames ( eqTyConKey, ipClassNameKey ) -- others import Unique ( Unique, hasKey ) @@ -857,13 +858,20 @@ isEqPred ty = case tyConAppTyCon_maybe ty of _ -> False isIPPred ty = case tyConAppTyCon_maybe ty of - Just tyCon -> tyConName tyCon == ipClassName - _ -> False + Just tc -> isIPTyCon tc + _ -> False + +isIPTyCon :: TyCon -> Bool +isIPTyCon tc = tc `hasKey` ipClassNameKey + +isIPClass :: Class -> Bool +isIPClass cls = cls `hasKey` ipClassNameKey + -- Class and it corresponding TyCon have the same Unique isIPPred_maybe :: Type -> Maybe (FastString, Type) isIPPred_maybe ty = do (tc,[t1,t2]) <- splitTyConApp_maybe ty - guard (tyConName tc == ipClassName) + guard (isIPTyCon tc) x <- isStrLitTy t1 return (x,t2) \end{code} @@ -875,7 +883,7 @@ Make PredTypes -- | Creates a type equality predicate mkEqPred :: Type -> Type -> PredType mkEqPred ty1 ty2 - = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) ) TyConApp eqTyCon [k, ty1, ty2] where k = typeKind ty1 diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index d4a270dd0e..7b5a7aae44 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -51,7 +51,7 @@ module UniqFM ( foldUFM, foldUFM_Directly, mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, - filterUFM, filterUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, sizeUFM, isNullUFM, lookupUFM, lookupUFM_Directly, @@ -146,6 +146,7 @@ mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt +partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) sizeUFM :: UniqFM elt -> Int --hashUFM :: UniqFM elt -> Int @@ -232,6 +233,8 @@ mapUFM f (UFM m) = UFM (M.map f m) mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) filterUFM p (UFM m) = UFM (M.filter p m) filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) +partitionUFM p (UFM m) = case M.partition p m of + (left, right) -> (UFM left, UFM right) sizeUFM (UFM m) = M.size m elemUFM k (UFM m) = M.member (getKey $ getUnique k) m |