- span = instLocSrcSpan 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]
-
-lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
- | Just expr <- shortCutIntLit i ty
- = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
- -- expr may be a constructor application
- | otherwise
- = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
- tcLookupId fromIntegerName `thenM` \ from_integer ->
- tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
- mkIntegerLit i `thenM` \ integer_lit ->
- returnM (GenInst [method_inst]
- (mkHsApp (L (instLocSrcSpan loc)
- (HsVar (instToId method_inst))) integer_lit))
-
-lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
- | Just expr <- shortCutFracLit f ty
- = returnM (GenInst [] (noLoc expr))
-
- | otherwise
- = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
- tcLookupId fromRationalName `thenM` \ from_rational ->
- tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
- mkRatLit f `thenM` \ rat_lit ->
- returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc)
- (HsVar (instToId method_inst))) rat_lit))
-
--- Dictionaries
-lookupInst (Dict _ pred loc)
- = do { mb_result <- lookupPred pred
- ; case mb_result of {
- Nothing -> return NoInstance ;
- Just (tenv, dfun_id) -> do
-
- -- tenv is a substitution that instantiates the dfun_id
- -- to match the requested result type.
- --
- -- We ASSUME that the dfun is quantified over the very same tyvars
- -- that are bound by the tenv.
- --
- -- However, the dfun
- -- might have some tyvars that *only* appear in arguments
- -- dfun :: forall a b. C a b, Ord b => D [a]
- -- We instantiate b to a flexi type variable -- it'll presumably
- -- become fixed later via functional dependencies
- { 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 the open_tvs to instantiate any un-substituted tyvars.
- ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- open_tvs = filter (`notElemTvSubst` tenv) tyvars
- ; open_tvs' <- mappM tcInstTyVar open_tvs
- ; let
- tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
- -- Since the open_tvs' are freshly made, they cannot possibly be captured by
- -- any nested for-alls in rho. So the in-scope set is unchanged
- dfun_rho = substTy tenv' rho
- (theta, _) = tcSplitPhiTy dfun_rho
- src_loc = instLocSrcSpan loc
- dfun = HsVar dfun_id
- tys = map (substTyVar tenv') tyvars
- ; if null theta then
- returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
- else do
- { (dicts, dict_app) <- instCallDicts loc theta
- ; let co_fn = dict_app <.> mkWpTyApps tys
- ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
- }}}}
-
----------------
-lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
--- 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 {
- ([(tenv, ispec)], [])
- -> 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 (tenv, dfun_id)) } ;
-
- (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 ip_pred = return Nothing
-
-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}