- | otherwise
- = do { hs_lit <- mkOverLit lit_val
- ; from_thing <- tcLookupId (hsOverLitName lit_val)
- -- Not rebindable, so hsOverLitName is the right thing
- ; method_inst <- tcInstClassOp iloc from_thing [ty]
- ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
- (L loc (HsLit hs_lit))
- lit' = lit { ol_witness = witness, ol_type = ty }
- ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
- where
- loc = instLocSpan iloc
-
---------------------- Dictionaries ------------------------
-lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
- = do { mb_result <- lookupPred pred
- ; case mb_result of {
- Nothing -> return NoInstance ;
- Just (dfun_id, mb_inst_tys) -> do
-
- { use_stage <- getStage
- ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
- (topIdLvl dfun_id) use_stage
-
- -- It's possible that not all the tyvars are in
- -- the substitution, tenv. For example:
- -- instance C X a => D X where ...
- -- (presumably there's a functional dependency in class C)
- -- Hence mb_inst_tys :: Either TyVar TcType
-
- ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
- inst_tv (Right ty) = return ty
- ; tys <- mapM inst_tv mb_inst_tys
- ; let
- (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
- src_loc = instLocSpan loc
- dfun = HsVar dfun_id
- ; if null theta then
- return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
- else do
- { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
- ; let co_fn = dict_app <.> mkWpTyApps tys
- ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
- }}}}
-
----------------
-lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
--- Look up a class constraint in the instance environment
-lookupPred pred@(ClassP clas tys)
- = do { eps <- getEps
- ; tcg_env <- getGblEnv
- ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
- ; case lookupInstEnv inst_envs clas tys of {
- ([(ispec, inst_tys)], [])
- -> do { let dfun_id = is_dfun ispec
- ; traceTc (text "lookupInst success" <+>
- vcat [text "dict" <+> ppr pred,
- text "witness" <+> ppr dfun_id
- <+> ppr (idType dfun_id) ])
- -- Record that this dfun is needed
- ; record_dfun_usage dfun_id
- ; return (Just (dfun_id, inst_tys)) } ;
-
- (matches, unifs)
- -> do { traceTc (text "lookupInst fail" <+>
- vcat [text "dict" <+> ppr pred,
- text "matches" <+> ppr matches,
- text "unifs" <+> ppr unifs])
- -- In the case of overlap (multiple matches) we report
- -- NoInstance here. That has the effect of making the
- -- context-simplifier return the dict as an irreducible one.
- -- Then it'll be given to addNoInstanceErrs, which will do another
- -- lookupInstEnv to get the detailed info about what went wrong.
- ; return Nothing }
- }}
-
-lookupPred (IParam {}) = return Nothing -- Implicit parameters
-lookupPred (EqPred {}) = panic "lookupPred EqPred"
-
-record_dfun_usage :: Id -> TcRn ()
-record_dfun_usage dfun_id
- = do { hsc_env <- getTopEnv
- ; let dfun_name = idName dfun_id
- dfun_mod = nameModule dfun_name
- ; if isInternalName dfun_name || -- Internal name => defined in this module
- modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
- then return () -- internal, or in another package
- else do { tcg_env <- getGblEnv
- ; updMutVar (tcg_inst_uses tcg_env)
- (`addOneToNameSet` idName dfun_id) }}
-
-
-tcGetInstEnvs :: TcM (InstEnv, InstEnv)
--- Gets both the external-package inst-env
--- and the home-pkg inst env (includes module being compiled)
-tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
- return (eps_inst_env eps, tcg_inst_env env) }
-\end{code}
-
-
-
-%************************************************************************
-%* *
- Re-mappable syntax
-%* *
-%************************************************************************
-
-Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
-a do-expression. We have to find (>>) in the current environment, which is
-done by the rename. Then we have to check that it has the same type as
-Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
-this:
-
- (>>) :: HB m n mn => m a -> n b -> mn b
-
-So the idea is to generate a local binding for (>>), thus:
-
- let then72 :: forall a b. m a -> m b -> m b
- then72 = ...something involving the user's (>>)...
- in
- ...the do-expression...
-
-Now the do-expression can proceed using then72, which has exactly
-the expected type.
-
-In fact tcSyntaxName just generates the RHS for then72, because we only
-want an actual binding in the do-expression case. For literals, we can
-just use the expression inline.
-
-\begin{code}
-tcSyntaxName :: InstOrigin
- -> TcType -- Type to instantiate it at
- -> (Name, HsExpr Name) -- (Standard name, user name)
- -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
--- *** NOW USED ONLY FOR CmdTop (sigh) ***
--- NB: tcSyntaxName calls tcExpr, and hence can do unification.
--- So we do not call it from lookupInst, which is called from tcSimplify
-
-tcSyntaxName orig ty (std_nm, HsVar user_nm)
- | std_nm == user_nm
- = do id <- newMethodFromName orig ty std_nm
- return (std_nm, HsVar id)
-
-tcSyntaxName orig ty (std_nm, user_nm_expr) = do
- std_id <- tcLookupId std_nm
- let
- -- C.f. newMethodAtLoc
- ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
- sigma1 = substTyWith [tv] [ty] tau
- -- Actually, the "tau-type" might be a sigma-type in the
- -- case of locally-polymorphic methods.
-
- addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
-
- -- Check that the user-supplied thing has the
- -- same type as the standard one.
- -- Tiresome jiggling because tcCheckSigma takes a located expression
- span <- getSrcSpanM
- expr <- tcPolyExpr (L span user_nm_expr) sigma1
- return (std_nm, unLoc expr)
-
-syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
- -> TcRn (TidyEnv, SDoc)
-syntaxNameCtxt name orig ty tidy_env = do
- inst_loc <- getInstLoc orig
- let
- msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
- ptext (sLit "(needed by a syntactic construct)"),
- nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
- nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
-
- return (tidy_env, msg)
-\end{code}
-
-%************************************************************************
-%* *
- EqInsts
-%* *
-%************************************************************************