| ... |
... |
@@ -37,6 +37,7 @@ import GHC.Core.ConLike ( ConLike(..) ) |
|
37
|
37
|
import GHC.Core.DataCon ( dataConConcreteTyVars, isNewDataCon, dataConOrigArgTys )
|
|
38
|
38
|
import GHC.Core.TyCon
|
|
39
|
39
|
import GHC.Core.TyCo.Rep
|
|
|
40
|
+import GHC.Core.TyCo.FVs
|
|
40
|
41
|
import GHC.Core.TyCo.Ppr
|
|
41
|
42
|
import GHC.Core.TyCo.Subst ( substTyWithInScope )
|
|
42
|
43
|
import GHC.Core.Type
|
| ... |
... |
@@ -2196,9 +2197,9 @@ qlUnify ty1 ty2 |
|
2196
|
2197
|
-- with qualified types).
|
|
2197
|
2198
|
|
|
2198
|
2199
|
go' (TyVarTy tv) ty2
|
|
2199
|
|
- | isMetaTyVar tv = go_kappa tv ty2
|
|
|
2200
|
+ | isQLInstTyVar tv = go_kappa tv ty2
|
|
2200
|
2201
|
go' ty1 (TyVarTy tv)
|
|
2201
|
|
- | isMetaTyVar tv = go_kappa tv ty1
|
|
|
2202
|
+ | isQLInstTyVar tv = go_kappa tv ty1
|
|
2202
|
2203
|
|
|
2203
|
2204
|
go' (CastTy ty1 _) ty2 = go ty1 ty2
|
|
2204
|
2205
|
go' ty1 (CastTy ty2 _) = go ty1 ty2
|
| ... |
... |
@@ -2240,37 +2241,18 @@ qlUnify ty1 ty2 |
|
2240
|
2241
|
; go_flexi kappa ty2 } }
|
|
2241
|
2242
|
|
|
2242
|
2243
|
----------------
|
|
2243
|
|
- -- Swap (kappa1[conc] ~ kappa2[tau])
|
|
2244
|
|
- -- otherwise we'll fail to unify and emit a coercion.
|
|
2245
|
|
- -- Just an optimisation: emitting a coercion is fine
|
|
2246
|
|
- go_flexi kappa (TyVarTy tv2)
|
|
2247
|
|
- | lhsPriority tv2 > lhsPriority kappa
|
|
2248
|
|
- = go_flexi1 tv2 (TyVarTy kappa)
|
|
2249
|
|
- go_flexi kappa ty2
|
|
2250
|
|
- = go_flexi1 kappa ty2
|
|
2251
|
|
-
|
|
2252
|
|
- go_flexi1 kappa ty2 -- ty2 is zonked
|
|
2253
|
|
- = do { cur_lvl <- getTcLevel
|
|
2254
|
|
- -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
|
|
2255
|
|
- -- Here we are in the TcM monad, which does not track enclosing
|
|
2256
|
|
- -- Given equalities; so for quick-look unification we conservatively
|
|
2257
|
|
- -- treat /any/ level outside this one as untouchable. Hence cur_lvl.
|
|
2258
|
|
- ; traceTc "go_flexi1" (ppr kappa $$ ppr ty2)
|
|
2259
|
|
- ; case simpleUnifyCheck UC_QuickLook cur_lvl kappa ty2 of
|
|
2260
|
|
- -- qlUnify depends, regrettably delicately, on the exact choices made
|
|
2261
|
|
- -- by `simpleUnifyCheck`. See (SUC1) in
|
|
2262
|
|
- -- Note [simpleUnifyCheck] in GHC.Tc.Utils.Unify
|
|
2263
|
|
- SUC_CanUnify ->
|
|
2264
|
|
- do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
|
|
2265
|
|
- -- unifyKind: see (UQL2) in Note [QuickLook unification]
|
|
2266
|
|
- -- and (MIV2) in Note [Monomorphise instantiation variables]
|
|
2267
|
|
- ; let ty2' = mkCastTy ty2 co
|
|
2268
|
|
- ; traceTc "qlUnify:update" $
|
|
2269
|
|
- ppr kappa <+> text ":=" <+> ppr ty2
|
|
2270
|
|
- ; liftZonkM $ writeMetaTyVar kappa ty2' }
|
|
2271
|
|
- suc -> do { traceTc "go_flexi2" (ppr suc $$ ppr kappa $$ ppr ty2)
|
|
2272
|
|
- ; return () } -- e.g. occurs-check or forall-bound variable
|
|
2273
|
|
- }
|
|
|
2244
|
+ go_flexi kappa ty2 -- ty2 is zonked
|
|
|
2245
|
+ | anyFreeVarsOfType (== kappa) ty2
|
|
|
2246
|
+ = return () -- Occurs check
|
|
|
2247
|
+ | otherwise
|
|
|
2248
|
+ = do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
|
|
|
2249
|
+ -- unifyKind: see (UQL2) in Note [QuickLook unification]
|
|
|
2250
|
+ -- and (MIV2) in Note [Monomorphise instantiation variables]
|
|
|
2251
|
+ ; let ty2' = mkCastTy ty2 co
|
|
|
2252
|
+ ; traceTc "qlUnify:update" $
|
|
|
2253
|
+ ppr kappa <+> text ":=" <+> ppr ty2
|
|
|
2254
|
+ ; liftZonkM $ writeMetaTyVar kappa ty2'
|
|
|
2255
|
+ ; return () }
|
|
2274
|
2256
|
where
|
|
2275
|
2257
|
kappa_kind = tyVarKind kappa
|
|
2276
|
2258
|
ty2_kind = typeKind ty2
|