- 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 = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
- | Just expr <- shortCutIntLit i ty
- = return (GenInst [] (noLoc expr))
- | otherwise
- = ASSERT( from_integer_name `isHsVar` fromIntegerName ) do -- A LitInst invariant
- from_integer <- tcLookupId fromIntegerName
- method_inst <- tcInstClassOp loc from_integer [ty]
- integer_lit <- mkIntegerLit i
- return (GenInst [method_inst]
- (mkHsApp (L (instLocSpan loc)
- (HsVar (instToId method_inst))) integer_lit))
-
-lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
- | Just expr <- shortCutFracLit f ty
- = return (GenInst [] (noLoc expr))
-
- | otherwise
- = ASSERT( from_rat_name `isHsVar` fromRationalName ) do -- A LitInst invariant
- from_rational <- tcLookupId fromRationalName
- method_inst <- tcInstClassOp loc from_rational [ty]
- rat_lit <- mkRatLit f
- return (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
- (HsVar (instToId method_inst))) rat_lit))
-
-lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
- | Just expr <- shortCutStringLit s ty
- = return (GenInst [] (noLoc expr))
- | otherwise
- = ASSERT( from_string_name `isHsVar` fromStringName ) do -- A LitInst invariant
- from_string <- tcLookupId fromStringName
- method_inst <- tcInstClassOp loc from_string [ty]
- string_lit <- mkStrLit s
- return (GenInst [method_inst]
- (mkHsApp (L (instLocSpan loc)
- (HsVar (instToId method_inst))) string_lit))
-
---------------------- 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 ip_pred = return Nothing -- Implicit parameters
-
-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
-%* *
-%************************************************************************