X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=e7c472b4751cbf3d863b209687da1596e0256eea;hp=97db7b37dde96a07fe018c11d29cf4a8b1f0d385;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hpb=aaed05e88978688e37dc74177dd4eba51a6ab4d0 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 97db7b3..e7c472b 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -96,9 +96,9 @@ Running example: op1_i = /\a. \(d:C a). let this :: C [a] this = df_i a d + -- Note [Subtle interaction of recursion and overlap] local_op1 :: forall b. Ix b => [a] -> b -> b - -- Note [Subtle interaction of recursion and overlap] local_op1 = -- Source code; run the type checker on this -- NB: Type variable 'a' (but not 'b') is in scope in @@ -571,7 +571,7 @@ tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- newtype N a = MkN (Tree [a]) deriving( Foo Int ) -- -- The newtype gives an FC axiom looking like --- axiom CoN a :: N a :=: Tree [a] +-- axiom CoN a :: N a ~ Tree [a] -- (see Note [Newtype coercions] in TyCon for this unusual form of axiom) -- -- So all need is to generate a binding looking like: @@ -588,7 +588,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) rigid_info = InstSkol origin = SigOrigin rigid_info inst_ty = idType dfun_id - ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty + ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty -- inst_head_ty is a PredType ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty @@ -614,13 +614,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) -- Figure out bindings for the superclass context from dfun_dicts -- Don't include this_dict in the 'givens', else - -- sc_dicst get bound by just selecting from this_dict!! + -- sc_dicts get bound by just selecting from this_dict!! ; sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts) + tcSimplifySuperClasses inst_loc this_dict dfun_dicts + (rep_dict:sc_dicts) -- It's possible that the superclass stuff might unified something -- in the envt with one of the clas_tyvars - ; checkSigTyVars class_tyvars + ; checkSigTyVars inst_tvs' ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict) @@ -628,15 +629,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) ; return (unitBag $ noLoc $ - AbsBinds tvs (map instToVar dfun_dicts) - [(tvs, dfun_id, instToId this_dict, [])] + AbsBinds inst_tvs' (map instToVar dfun_dicts) + [(inst_tvs', dfun_id, instToId this_dict, [])] (dict_bind `consBag` sc_binds)) } where ----------------------- -- make_coercion -- The inst_head looks like (C s1 .. sm (T a1 .. ak)) -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak))) - -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm ) + -- with kind (C s1 .. sm (T a1 .. ak) ~ C s1 .. sm ) -- where rep_ty is the (eta-reduced) type rep of T -- So we just replace T with CoT, and insert a 'sym' -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced @@ -735,7 +736,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- Don't include this_dict in the 'givens', else -- sc_dicts get bound by just selecting from this_dict!! sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc dfun_dicts sc_dicts + tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts -- Note [Recursive superclasses] -- It's possible that the superclass stuff might unified something