- span = instLocSpan loc
-
---------------------- Literals ------------------------
--- Look for short cuts first: if the literal is *definitely* a
--- int, integer, float or a double, generate the real thing here.
--- This is essential (see nofib/spectral/nucleic).
--- [Same shortcut as in newOverloadedLit, but we
--- may have done some unification by now]
-
-lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
- , ol_rebindable = rebindable }
- , tci_ty = ty, tci_loc = iloc})
- | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
- | Just witness <- shortCutLit lit_val ty
- = do { let lit' = lit { ol_witness = witness, ol_type = ty }
- ; return (GenInst [] (L loc (HsOverLit lit'))) }
-
- | 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)