-lookupInst :: Inst s
- -> TcM s ([Inst s],
- TcDictBinds s) -- The new binding
-
--- Dictionaries
-
-lookupInst dict@(Dict _ clas ty orig loc)
- = case lookupMEnv matchTy (get_inst_env clas orig) ty of
- Nothing -> tcAddSrcLoc loc $
- tcAddErrCtxt (pprOrigin orig loc) $
- failTc (noInstanceErr dict)
-
- Just (dfun_id, tenv)
- -> let
- (tyvars, rho) = splitForAllTy (idType dfun_id)
- ty_args = map (assoc "lookupInst" tenv) tyvars
- -- tenv should bind all the tyvars
- in
- tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
- let
- (theta, tau) = splitRhoTy dfun_rho
- in
- newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
- let
- rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
- in
- returnTc (dicts, VarMonoBind (instToId dict) rhs)
-
-
--- Methods
-
-lookupInst inst@(Method _ id tys rho orig loc)
- = tcSplitRhoTy rho `thenNF_Tc` \ (theta, _) ->
- newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
- returnTc (dicts, VarMonoBind (instToId inst) (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
-
--- Literals
-
-lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
- | i >= toInteger minInt && i <= toInteger maxInt
- = -- It's overloaded but small enough to fit into an Int
- tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
- newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) int_lit))
-
- | otherwise
- = -- Alas, it is overloaded and a big literal!
- tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
- newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))