import FamInstEnv
import TcDeriv
import TcEnv
-import RnEnv ( lookupImportedName )
+import RnEnv ( lookupGlobalOccRn )
import TcHsType
import TcUnify
import TcSimplify
; mapM_ (checkIndexes clas inst_tys) ats
}
- checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
+ checkIndexes clas inst_tys (hsAT, ATyCon tycon)
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
- checkIndexes' clas inst_tys hsAT
- (tyConTyVars tycon,
- snd . fromJust . tyConFamInst_maybe $ tycon)
+ = checkIndexes' clas inst_tys hsAT
+ (tyConTyVars tycon,
+ snd . fromJust . tyConFamInst_maybe $ tycon)
checkIndexes _ _ _ = panic "checkIndexes"
checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
addErrCtxt (atInstCtxt atName) $
case find ((atName ==) . tyConName) (classATs clas) of
Nothing -> addErrTc $ badATErr clas atName -- not in this class
- Just atDecl ->
- case assocTyConArgPoss_maybe atDecl of
+ Just atycon ->
+ case assocTyConArgPoss_maybe atycon of
Nothing -> panic "checkIndexes': AT has no args poss?!?"
Just poss ->
-- which must be type variables; and (3) variables in AT and
-- instance head will be different `Name's even if their
-- source lexemes are identical.
+ --
+ -- e.g. class C a b c where
+ -- data D b a :: * -> * -- NB (1) b a, omits c
+ -- instance C [x] Bool Char where
+ -- data D Bool [x] v = MkD x [v] -- NB (2) v
+ -- -- NB (3) the x in 'instance C...' have differnt
+ -- -- Names to x's in 'data D...'
--
-- Re (1), `poss' contains a permutation vector to extract the
-- class parameters in the right order.
; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
- ; let dict_bind = mkVarBind (instToId this_dict) (noLoc body)
+ ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
; return (unitBag $ noLoc $
AbsBinds inst_tvs' (map instToVar dfun_dicts)
checkSigTyVars inst_tyvars'
-- Deal with 'SPECIALISE instance' pragmas
- prags <- tcPrags NonRecursive dfun_id (filter isSpecInstLSig uprags)
+ prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
-- Create the result bindings
let
-- See Note [Inline dfuns] below
sc_dict_vars = map instToVar sc_dicts
- dict_bind = mkVarBind this_dict_id dict_rhs
+ dict_bind = L loc (VarBind this_dict_id dict_rhs)
dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs
inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys')
(dataConWrapId dict_constr)
-- member) are dealt with by the common MkId.mkDataConWrapId code rather
-- than needing to be repeated here.
+
main_bind = noLoc $ AbsBinds
inst_tyvars'
dfun_lam_vars
-- then clashes with its friends
; uniq1 <- newUnique
; let local_meth_name = mkInternalName uniq1 sel_occ loc -- Same OccName
- this_dict_bind = mkVarBind (instToId cloned_this) $
+ this_dict_bind = L loc $ VarBind (instToId cloned_this) $
L loc $ wrapId meth_wrapper dfun_id
mb_this_bind | null tyvars = Nothing
| otherwise = Just (cloned_this, this_dict_bind)
{ -- Build the typechecked version directly,
-- without calling typecheck_method;
-- see Note [Default methods in instances]
- dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
+ dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
-- Might not be imported, but will be an OrigName
; dm_id <- tcLookupId dm_name
; return (wrapId dm_wrapper dm_id, emptyBag) } }
wrongATArgErr :: Type -> Type -> SDoc
wrongATArgErr ty instTy =
sep [ ptext (sLit "Type indexes must match class instance head")
- , ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>
- ppr instTy
+ , ptext (sLit "Found") <+> quotes (ppr ty)
+ <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
\end{code}