import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
tcClassDecl2, getGenericInstances )
import TcRnMonad
import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
tcClassDecl2, getGenericInstances )
import TcRnMonad
-import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr,
+import TcMType ( tcSkolType, checkValidTheta, checkValidInstHead, instTypeErr,
-import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType,
+import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType,
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv2,
InstInfo(..), InstBindings(..),
import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv2,
InstInfo(..), InstBindings(..),
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
import DataCon ( classDataCon )
import Class ( classBigSig )
import Var ( Id, idName, idType )
import MkId ( mkDictFunId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Name ( Name, getSrcLoc )
import DataCon ( classDataCon )
import Class ( classBigSig )
import Var ( Id, idName, idType )
import MkId ( mkDictFunId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Name ( Name, getSrcLoc )
-import NameSet ( unitNameSet, emptyNameSet, nameSetToList, unionNameSets )
+import NameSet ( unitNameSet, emptyNameSet, unionNameSets )
import UnicodeUtil ( stringToUtf8 )
import Maybe ( catMaybes )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
import UnicodeUtil ( stringToUtf8 )
import Maybe ( catMaybes )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
= -- Prime error recovery, set source location
recoverM (returnM Nothing) $
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
= -- Prime error recovery, set source location
recoverM (returnM Nothing) $
= do { -- (a) Default methods from class decls
(dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
filter (isClassDecl.unLoc) tycl_decls
= do { -- (a) Default methods from class decls
(dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
filter (isClassDecl.unLoc) tycl_decls
tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
= -- Prime error recovery
tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
= -- Prime error recovery
inst_ty = idType dfun_id
(inst_tyvars, _) = tcSplitForAllTys inst_ty
-- The tyvars of the instance decl scope over the 'where' part
inst_ty = idType dfun_id
(inst_tyvars, _) = tcSplitForAllTys inst_ty
-- The tyvars of the instance decl scope over the 'where' part
let
Just pred = tcSplitPredTy_maybe inst_head'
(clas, inst_tys') = getClassPredTys pred
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
-- Instantiate the super-class context with inst_tys
let
Just pred = tcSplitPredTy_maybe inst_head'
(clas, inst_tys') = getClassPredTys pred
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
-- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta
- origin = InstanceDeclOrigin
+ sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys') sc_theta
+ origin = SigOrigin rigid_info
newDicts origin dfun_theta' `thenM` \ dfun_arg_dicts ->
newDicts origin [pred] `thenM` \ [this_dict] ->
-- Default-method Ids may be mentioned in synthesised RHSs,
newDicts origin dfun_theta' `thenM` \ dfun_arg_dicts ->
newDicts origin [pred] `thenM` \ [this_dict] ->
-- Default-method Ids may be mentioned in synthesised RHSs,
let -- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
in
let -- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
in
dfun_theta' inst_tys' avail_insts
op_items binds `thenM` \ (meth_ids, meth_binds) ->
-- Figure out bindings for the superclass context
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
dfun_theta' inst_tys' avail_insts
op_items binds `thenM` \ (meth_ids, meth_binds) ->
-- Figure out bindings for the superclass context
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
- `thenM` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
+ `thenM` \ (sc_binds_inner, sc_binds_outer) ->
+
+ -- It's possible that the superclass stuff might have done unification
+ checkSigTyVars inst_tyvars' `thenM_`
-- Deal with 'SPECIALISE instance' pragmas by making them
-- look like SPECIALISE pragmas for the dfun
-- Deal with 'SPECIALISE instance' pragmas by making them
-- look like SPECIALISE pragmas for the dfun
- zonked_inst_tyvars
- (map instToId dfun_arg_dicts)
- [(inst_tyvars', dfun_id, this_dict_id)]
- inlines all_binds
+ inst_tyvars'
+ (map instToId dfun_arg_dicts)
+ [(inst_tyvars', dfun_id, this_dict_id)]
+ inlines all_binds
avail_insts op_items (VanillaInst monobinds uprags)
= -- Check that all the method bindings come from this class
let
avail_insts op_items (VanillaInst monobinds uprags)
= -- Check that all the method bindings come from this class
let
all_insts = avail_insts ++ catMaybes meth_insts
xtve = inst_tyvars `zip` inst_tyvars'
tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags
all_insts = avail_insts ++ catMaybes meth_insts
xtve = inst_tyvars `zip` inst_tyvars'
tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags
- returnM ([meth_id | (_,meth_id,_) <- meth_infos],
- unionManyBags meth_binds_s)
+ returnM (meth_ids, unionManyBags meth_binds_s)
return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
-- Instantiate rep_tys with the relevant type variables
return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
-- Instantiate rep_tys with the relevant type variables
-- We must simplify this all the way down
-- lest we build superclass loops
-- See Note [Superclass loops] above
tcSimplifyTop sc_lie `thenM` \ sc_binds2 ->
-- We must simplify this all the way down
-- lest we build superclass loops
-- See Note [Superclass loops] above
tcSimplifyTop sc_lie `thenM` \ sc_binds2 ->