2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 The @Inst@ type: dictionaries or method instances
11 deeplyInstantiate, instCall, instStupidTheta,
12 emitWanted, emitWanteds,
14 newOverloadedLit, mkOverLit,
16 tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv,
17 instCallConstraints, newMethodFromName,
20 -- Simple functions over evidence variables
23 tyVarsOfWanteds, tyVarsOfWanted, tyVarsOfWantedEvVar, tyVarsOfWantedEvVars,
24 tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
25 tidyWanteds, tidyWanted, tidyWantedEvVar, tidyWantedEvVars,
26 tidyEvVar, tidyImplication
30 #include "HsVersions.h"
32 import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp )
33 import {-# SOURCE #-} TcUnify( unifyType )
50 import Var ( Var, TyVar, EvVar, varType, setVarType )
65 %************************************************************************
69 %************************************************************************
72 emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
73 emitWanteds origin theta = mapM (emitWanted origin) theta
75 emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
76 emitWanted origin pred = do { loc <- getCtLoc origin
77 ; ev <- newWantedEvVar pred
78 ; emitConstraint (WcEvVar (WantedEvVar ev loc))
81 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
82 -- Used when Name is the wired-in name for a wired-in class method,
83 -- so the caller knows its type for sure, which should be of form
84 -- forall a. C a => <blah>
85 -- newMethodFromName is supposed to instantiate just the outer
86 -- type variable and constraint
88 newMethodFromName origin name inst_ty
89 = do { id <- tcLookupId name
90 -- Use tcLookupId not tcLookupGlobalId; the method is almost
91 -- always a class op, but with -XRebindableSyntax GHC is
92 -- meant to find whatever thing is in scope, and that may
93 -- be an ordinary function.
95 ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id)
97 subst = zipOpenTvSubst [the_tv] [inst_ty]
99 ; wrap <- ASSERT( null rest && isSingleton theta )
100 instCall origin [inst_ty] (substTheta subst theta)
101 ; return (mkHsWrap wrap (HsVar id)) }
105 %************************************************************************
107 Deep instantiation and skolemisation
109 %************************************************************************
111 Note [Deep skolemisation]
112 ~~~~~~~~~~~~~~~~~~~~~~~~~
113 deeplySkolemise decomposes and skolemises a type, returning a type
114 with all its arrows visible (ie not buried under foralls)
118 deeplySkolemise (Int -> forall a. Ord a => blah)
119 = ( wp, [a], [d:Ord a], Int -> blah )
120 where wp = \x:Int. /\a. \(d:Ord a). <hole> x
122 deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
123 = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
124 where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
127 if deeplySkolemise ty = (wrap, tvs, evs, rho)
130 and 'wrap' binds tvs, evs
132 ToDo: this eta-abstraction plays fast and loose with termination,
133 because it can introduce extra lambdas. Maybe add a `seq` to
141 -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
143 deeplySkolemise skol_info ty
144 | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
145 = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
146 ; tvs1 <- mapM (tcInstSkolTyVar skol_info) tvs
147 ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1)
148 ; ev_vars1 <- newEvVars (substTheta subst theta)
149 ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise skol_info (substTy subst ty')
150 ; return ( mkWpLams ids1
152 <.> mkWpLams ev_vars1
154 <.> mkWpEvVarApps ids1
156 , ev_vars1 ++ ev_vars2
157 , mkFunTys arg_tys rho ) }
160 = return (idHsWrapper, [], [], ty)
162 deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
163 -- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha
165 -- if deeplyInstantiate ty = (wrap, rho)
167 -- then wrap e :: rho
169 deeplyInstantiate orig ty
170 | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
171 = do { (_, tys, subst) <- tcInstTyVars tvs
172 ; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
173 ; wrap1 <- instCall orig tys (substTheta subst theta)
174 ; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho)
175 ; return (mkWpLams ids1
178 <.> mkWpEvVarApps ids1,
179 mkFunTys arg_tys rho2) }
181 | otherwise = return (idHsWrapper, ty)
185 %************************************************************************
189 %************************************************************************
193 instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
194 -- Instantiate the constraints of a call
195 -- (instCall o tys theta)
196 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
197 -- (b) Throws these dictionaries into the LIE
198 -- (c) Returns an HsWrapper ([.] tys dicts)
200 instCall orig tys theta
201 = do { dict_app <- instCallConstraints orig theta
202 ; return (dict_app <.> mkWpTyApps tys) }
205 instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
206 -- Instantiates the TcTheta, puts all constraints thereby generated
207 -- into the LIE, and returns a HsWrapper to enclose the call site.
209 instCallConstraints _ [] = return idHsWrapper
211 instCallConstraints origin (EqPred ty1 ty2 : preds) -- Try short-cut
212 = do { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
213 ; coi <- unifyType ty1 ty2
214 ; co_fn <- instCallConstraints origin preds
215 ; let co = case coi of
218 ; return (co_fn <.> WpEvApp (EvCoercion co)) }
220 instCallConstraints origin (pred : preds)
221 = do { ev_var <- emitWanted origin pred
222 ; co_fn <- instCallConstraints origin preds
223 ; return (co_fn <.> WpEvApp (EvId ev_var)) }
226 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
227 -- Similar to instCall, but only emit the constraints in the LIE
228 -- Used exclusively for the 'stupid theta' of a data constructor
229 instStupidTheta orig theta
230 = do { _co <- instCallConstraints orig theta -- Discard the coercion
234 %************************************************************************
238 %************************************************************************
240 In newOverloadedLit we convert directly to an Int or Integer if we
241 know that's what we want. This may save some time, by not
242 temporarily generating overloaded literals, but it won't catch all
243 cases (the rest are caught in lookupInst).
246 newOverloadedLit :: CtOrigin
249 -> TcM (HsOverLit TcId)
250 newOverloadedLit orig
251 lit@(OverLit { ol_val = val, ol_rebindable = rebindable
252 , ol_witness = meth_name }) res_ty
255 , Just expr <- shortCutLit val res_ty
256 -- Do not generate a LitInst for rebindable syntax.
257 -- Reason: If we do, tcSimplify will call lookupInst, which
258 -- will call tcSyntaxName, which does unification,
259 -- which tcSimplify doesn't like
260 = return (lit { ol_witness = expr, ol_type = res_ty })
263 = do { hs_lit <- mkOverLit val
264 ; let lit_ty = hsLitType hs_lit
265 ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
266 -- Overloaded literals must have liftedTypeKind, because
267 -- we're instantiating an overloaded function here,
268 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
269 -- However this'll be picked up by tcSyntaxOp if necessary
270 ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
271 ; return (lit { ol_witness = witness, ol_type = res_ty }) }
274 mkOverLit :: OverLitVal -> TcM HsLit
275 mkOverLit (HsIntegral i)
276 = do { integer_ty <- tcMetaTy integerTyConName
277 ; return (HsInteger i integer_ty) }
279 mkOverLit (HsFractional r)
280 = do { rat_ty <- tcMetaTy rationalTyConName
281 ; return (HsRat r rat_ty) }
283 mkOverLit (HsIsString s) = return (HsString s)
289 %************************************************************************
293 Used only for arrow syntax -- find a way to nuke this
295 %************************************************************************
297 Suppose we are doing the -XRebindableSyntax thing, and we encounter
298 a do-expression. We have to find (>>) in the current environment, which is
299 done by the rename. Then we have to check that it has the same type as
300 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
303 (>>) :: HB m n mn => m a -> n b -> mn b
305 So the idea is to generate a local binding for (>>), thus:
307 let then72 :: forall a b. m a -> m b -> m b
308 then72 = ...something involving the user's (>>)...
310 ...the do-expression...
312 Now the do-expression can proceed using then72, which has exactly
315 In fact tcSyntaxName just generates the RHS for then72, because we only
316 want an actual binding in the do-expression case. For literals, we can
317 just use the expression inline.
320 tcSyntaxName :: CtOrigin
321 -> TcType -- Type to instantiate it at
322 -> (Name, HsExpr Name) -- (Standard name, user name)
323 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
324 -- *** NOW USED ONLY FOR CmdTop (sigh) ***
325 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
326 -- So we do not call it from lookupInst, which is called from tcSimplify
328 tcSyntaxName orig ty (std_nm, HsVar user_nm)
330 = do rhs <- newMethodFromName orig std_nm ty
333 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
334 std_id <- tcLookupId std_nm
336 -- C.f. newMethodAtLoc
337 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
338 sigma1 = substTyWith [tv] [ty] tau
339 -- Actually, the "tau-type" might be a sigma-type in the
340 -- case of locally-polymorphic methods.
342 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
344 -- Check that the user-supplied thing has the
345 -- same type as the standard one.
346 -- Tiresome jiggling because tcCheckSigma takes a located expression
348 expr <- tcPolyExpr (L span user_nm_expr) sigma1
349 return (std_nm, unLoc expr)
351 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
352 -> TcRn (TidyEnv, SDoc)
353 syntaxNameCtxt name orig ty tidy_env = do
354 inst_loc <- getCtLoc orig
356 msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
357 ptext (sLit "(needed by a syntactic construct)"),
358 nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
359 nest 2 (pprArisingAt inst_loc)]
360 return (tidy_env, msg)
364 %************************************************************************
368 %************************************************************************
371 getOverlapFlag :: TcM OverlapFlag
373 = do { dflags <- getDOpts
374 ; let overlap_ok = xopt Opt_OverlappingInstances dflags
375 incoherent_ok = xopt Opt_IncoherentInstances dflags
376 overlap_flag | incoherent_ok = Incoherent
377 | overlap_ok = OverlapOk
378 | otherwise = NoOverlap
380 ; return overlap_flag }
382 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
383 -- Gets both the external-package inst-env
384 -- and the home-pkg inst env (includes module being compiled)
385 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
386 return (eps_inst_env eps, tcg_inst_env env) }
388 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
389 -- Add new locally-defined instances
390 tcExtendLocalInstEnv dfuns thing_inside
391 = do { traceDFuns dfuns
393 ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
394 ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
395 tcg_inst_env = inst_env' }
396 ; setGblEnv env' thing_inside }
398 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
399 -- Check that the proposed new instance is OK,
400 -- and then add it to the home inst env
401 addLocalInst home_ie ispec
402 = do { -- Instantiate the dfun type so that we extend the instance
403 -- envt with completely fresh template variables
404 -- This is important because the template variables must
405 -- not overlap with anything in the things being looked up
406 -- (since we do unification).
408 -- We use tcInstSkolType because we don't want to allocate fresh
409 -- *meta* type variables.
411 -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
412 -- these variables must be bindable by tcUnifyTys. See
413 -- the call to tcUnifyTys in InstEnv, and the special
414 -- treatment that instanceBindFun gives to isOverlappableTyVar
415 -- This is absurdly delicate.
417 let dfun = instanceDFunId ispec
418 ; (tvs', theta', tau') <- tcInstSkolType UnkSkol (idType dfun)
419 ; let (cls, tys') = tcSplitDFunHead tau'
420 dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
421 ispec' = setInstanceDFunId ispec dfun'
423 -- Load imported instances, so that we report
424 -- duplicates correctly
426 ; let inst_envs = (eps_inst_env eps, home_ie)
428 -- Check functional dependencies
429 ; case checkFunDeps inst_envs ispec' of
430 Just specs -> funDepErr ispec' specs
433 -- Check for duplicate instance decls
434 ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
435 ; dup_ispecs = [ dup_ispec
436 | (dup_ispec, _) <- matches
437 , let (_,_,_,dup_tys) = instanceHead dup_ispec
438 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
439 -- Find memebers of the match list which ispec itself matches.
440 -- If the match is 2-way, it's a duplicate
442 dup_ispec : _ -> dupInstErr ispec' dup_ispec
445 -- OK, now extend the envt
446 ; return (extendInstEnv home_ie ispec') }
448 traceDFuns :: [Instance] -> TcRn ()
450 = traceTc "Adding instances:" (vcat (map pp ispecs))
452 pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
453 -- Print the dfun name itself too
455 funDepErr :: Instance -> [Instance] -> TcRn ()
456 funDepErr ispec ispecs
458 addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
459 2 (pprInstances (ispec:ispecs)))
460 dupInstErr :: Instance -> Instance -> TcRn ()
461 dupInstErr ispec dup_ispec
463 addErr (hang (ptext (sLit "Duplicate instance declarations:"))
464 2 (pprInstances [ispec, dup_ispec]))
466 addDictLoc :: Instance -> TcRn a -> TcRn a
467 addDictLoc ispec thing_inside
468 = setSrcSpan (mkSrcSpan loc loc) thing_inside
470 loc = getSrcLoc ispec
473 %************************************************************************
475 Simple functions over evidence variables
477 %************************************************************************
480 hasEqualities :: [EvVar] -> Bool
481 -- Has a bunch of canonical constraints (all givens) got any equalities in it?
482 hasEqualities givens = any (has_eq . evVarPred) givens
484 has_eq (EqPred {}) = True
485 has_eq (IParam {}) = False
486 has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls)
489 tyVarsOfWanteds :: WantedConstraints -> TyVarSet
490 tyVarsOfWanteds = foldrBag (unionVarSet . tyVarsOfWanted) emptyVarSet
492 tyVarsOfWanted :: WantedConstraint -> TyVarSet
493 tyVarsOfWanted (WcEvVar wev) = tyVarsOfWantedEvVar wev
494 tyVarsOfWanted (WcImplic impl) = tyVarsOfImplication impl
496 tyVarsOfImplication :: Implication -> TyVarSet
497 tyVarsOfImplication implic = tyVarsOfWanteds (ic_wanted implic)
498 `minusVarSet` (ic_skols implic)
500 tyVarsOfWantedEvVar :: WantedEvVar -> TyVarSet
501 tyVarsOfWantedEvVar (WantedEvVar ev _) = tyVarsOfEvVar ev
503 tyVarsOfWantedEvVars :: Bag WantedEvVar -> TyVarSet
504 tyVarsOfWantedEvVars = foldrBag (unionVarSet . tyVarsOfWantedEvVar) emptyVarSet
506 tyVarsOfEvVar :: EvVar -> TyVarSet
507 tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
509 tyVarsOfEvVars :: [EvVar] -> TyVarSet
510 tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
513 tidyWanteds :: TidyEnv -> WantedConstraints -> WantedConstraints
514 tidyWanteds env = mapBag (tidyWanted env)
516 tidyWanted :: TidyEnv -> WantedConstraint -> WantedConstraint
517 tidyWanted env (WcEvVar wev) = WcEvVar (tidyWantedEvVar env wev)
518 tidyWanted env (WcImplic implic) = WcImplic (tidyImplication env implic)
520 tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar
521 tidyWantedEvVar env (WantedEvVar ev loc) = WantedEvVar (tidyEvVar env ev) loc
523 tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
524 tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
526 tidyEvVar :: TidyEnv -> EvVar -> EvVar
527 tidyEvVar env v = setVarType v (tidyType env (varType v))
529 tidyImplication :: TidyEnv -> Implication -> Implication
530 tidyImplication env implic@(Implic { ic_skols = skols, ic_given = given
531 , ic_wanted = wanted })
532 = implic { ic_skols = mkVarSet skols'
533 , ic_given = map (tidyEvVar env') given
534 , ic_wanted = tidyWanteds env' wanted }
536 (env', skols') = mapAccumL tidyTyVarBndr env (varSetElems skols)