ed12eff8831b8b4d494a9c50370f908537fe84bb
[ghc.git] / compiler / typecheck / Inst.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 The @Inst@ type: dictionaries or method instances
7 -}
8
9 {-# LANGUAGE CPP, MultiWayIf #-}
10
11 module Inst (
12 deeplySkolemise, deeplyInstantiate,
13 instCall, instDFunType, instStupidTheta,
14 newWanted, newWanteds,
15
16 newOverloadedLit, mkOverLit,
17
18 newClsInst,
19 tcGetInsts, tcGetInstEnvs, getOverlapFlag,
20 tcExtendLocalInstEnv,
21 instCallConstraints, newMethodFromName,
22 tcSyntaxName,
23
24 -- Simple functions over evidence variables
25 tyCoVarsOfWC,
26 tyCoVarsOfCt, tyCoVarsOfCts,
27 ) where
28
29 #include "HsVersions.h"
30
31 import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp )
32 import {-# SOURCE #-} TcUnify( unifyType, noThing )
33
34 import FastString
35 import HsSyn
36 import TcHsSyn
37 import TcRnMonad
38 import TcEnv
39 import TcEvidence
40 import InstEnv
41 import DataCon ( dataConWrapId )
42 import TysWiredIn ( heqDataCon )
43 import FunDeps
44 import TcMType
45 import Type
46 import TcType
47 import HscTypes
48 import Class( Class )
49 import MkId( mkDictFunId )
50 import Id
51 import Name
52 import Var ( EvVar )
53 import VarEnv
54 import PrelNames
55 import SrcLoc
56 import DynFlags
57 import Util
58 import Outputable
59 import Control.Monad( unless )
60 import Data.Maybe( isJust )
61
62 {-
63 ************************************************************************
64 * *
65 Creating and emittind constraints
66 * *
67 ************************************************************************
68 -}
69
70 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
71 -- Used when Name is the wired-in name for a wired-in class method,
72 -- so the caller knows its type for sure, which should be of form
73 -- forall a. C a => <blah>
74 -- newMethodFromName is supposed to instantiate just the outer
75 -- type variable and constraint
76
77 newMethodFromName origin name inst_ty
78 = do { id <- tcLookupId name
79 -- Use tcLookupId not tcLookupGlobalId; the method is almost
80 -- always a class op, but with -XRebindableSyntax GHC is
81 -- meant to find whatever thing is in scope, and that may
82 -- be an ordinary function.
83
84 ; let ty = piResultTy (idType id) inst_ty
85 (theta, _caller_knows_this) = tcSplitPhiTy ty
86 ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
87 instCall origin [inst_ty] theta
88
89 ; return (mkHsWrap wrap (HsVar (noLoc id))) }
90
91 {-
92 ************************************************************************
93 * *
94 Deep instantiation and skolemisation
95 * *
96 ************************************************************************
97
98 Note [Deep skolemisation]
99 ~~~~~~~~~~~~~~~~~~~~~~~~~
100 deeplySkolemise decomposes and skolemises a type, returning a type
101 with all its arrows visible (ie not buried under foralls)
102
103 Examples:
104
105 deeplySkolemise (Int -> forall a. Ord a => blah)
106 = ( wp, [a], [d:Ord a], Int -> blah )
107 where wp = \x:Int. /\a. \(d:Ord a). <hole> x
108
109 deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
110 = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
111 where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
112
113 In general,
114 if deeplySkolemise ty = (wrap, tvs, evs, rho)
115 and e :: rho
116 then wrap e :: ty
117 and 'wrap' binds tvs, evs
118
119 ToDo: this eta-abstraction plays fast and loose with termination,
120 because it can introduce extra lambdas. Maybe add a `seq` to
121 fix this
122 -}
123
124 deeplySkolemise
125 :: TcSigmaType
126 -> TcM ( HsWrapper
127 , [TyVar] -- all skolemised variables
128 , [EvVar] -- all "given"s
129 , TcRhoType)
130
131 deeplySkolemise ty
132 | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
133 = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
134 ; (subst, tvs1) <- tcInstSkolTyVars tvs
135 ; ev_vars1 <- newEvVars (substTheta subst theta)
136 ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
137 ; return ( mkWpLams ids1
138 <.> mkWpTyLams tvs1
139 <.> mkWpLams ev_vars1
140 <.> wrap
141 <.> mkWpEvVarApps ids1
142 , tvs1 ++ tvs2
143 , ev_vars1 ++ ev_vars2
144 , mkFunTys arg_tys rho ) }
145
146 | otherwise
147 = return (idHsWrapper, [], [], ty)
148
149 deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
150 -- Int -> forall a. a -> a ==> (\x:Int. [] x alpha) :: Int -> alpha
151 -- In general if
152 -- if deeplyInstantiate ty = (wrap, rho)
153 -- and e :: ty
154 -- then wrap e :: rho
155
156 deeplyInstantiate orig ty
157 | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
158 = do { (subst, tvs') <- tcInstTyVars tvs
159 ; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
160 ; let theta' = substTheta subst theta
161 ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
162 ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
163 , text "type" <+> ppr ty
164 , text "with" <+> ppr tvs'
165 , text "args:" <+> ppr ids1
166 , text "theta:" <+> ppr theta' ])
167 ; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho)
168 ; return (mkWpLams ids1
169 <.> wrap2
170 <.> wrap1
171 <.> mkWpEvVarApps ids1,
172 mkFunTys arg_tys rho2) }
173
174 | otherwise = return (idHsWrapper, ty)
175
176 {-
177 ************************************************************************
178 * *
179 Instantiating a call
180 * *
181 ************************************************************************
182
183 Note [Handling boxed equality]
184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
185 The solver deals entirely in terms of unboxed (primitive) equality.
186 There should never be a boxed Wanted equality. Ever. But, what if
187 we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
188 is boxed, so naive treatment here would emit a boxed Wanted equality.
189
190 So we simply check for this case and make the right boxing of evidence.
191
192 -}
193
194 ----------------
195 instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
196 -- Instantiate the constraints of a call
197 -- (instCall o tys theta)
198 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
199 -- (b) Throws these dictionaries into the LIE
200 -- (c) Returns an HsWrapper ([.] tys dicts)
201
202 instCall orig tys theta
203 = do { dict_app <- instCallConstraints orig theta
204 ; return (dict_app <.> mkWpTyApps tys) }
205
206 ----------------
207 instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
208 -- Instantiates the TcTheta, puts all constraints thereby generated
209 -- into the LIE, and returns a HsWrapper to enclose the call site.
210
211 instCallConstraints orig preds
212 | null preds
213 = return idHsWrapper
214 | otherwise
215 = do { evs <- mapM go preds
216 ; traceTc "instCallConstraints" (ppr evs)
217 ; return (mkWpEvApps evs) }
218 where
219 go pred
220 | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
221 = do { co <- unifyType noThing ty1 ty2
222 ; return (EvCoercion co) }
223
224 -- Try short-cut #2
225 | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
226 , tc `hasKey` heqTyConKey
227 = do { co <- unifyType noThing ty1 ty2
228 ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) }
229
230 | otherwise
231 = emitWanted orig pred
232
233 instDFunType :: DFunId -> [DFunInstType]
234 -> TcM ( [TcType] -- instantiated argument types
235 , TcThetaType ) -- instantiated constraint
236 -- See Note [DFunInstType: instantiating types] in InstEnv
237 instDFunType dfun_id dfun_inst_tys
238 = do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys
239 ; return (inst_tys, substTheta subst dfun_theta) }
240 where
241 (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)
242
243 go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
244 go subst [] [] = return (subst, [])
245 go subst (tv:tvs) (Just ty : mb_tys)
246 = do { (subst', tys) <- go (extendTCvSubst subst tv ty) tvs mb_tys
247 ; return (subst', ty : tys) }
248 go subst (tv:tvs) (Nothing : mb_tys)
249 = do { (subst', tv') <- tcInstTyVarX subst tv
250 ; (subst'', tys) <- go subst' tvs mb_tys
251 ; return (subst'', mkTyVarTy tv' : tys) }
252 go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
253
254 ----------------
255 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
256 -- Similar to instCall, but only emit the constraints in the LIE
257 -- Used exclusively for the 'stupid theta' of a data constructor
258 instStupidTheta orig theta
259 = do { _co <- instCallConstraints orig theta -- Discard the coercion
260 ; return () }
261
262 {-
263 ************************************************************************
264 * *
265 Literals
266 * *
267 ************************************************************************
268
269 In newOverloadedLit we convert directly to an Int or Integer if we
270 know that's what we want. This may save some time, by not
271 temporarily generating overloaded literals, but it won't catch all
272 cases (the rest are caught in lookupInst).
273 -}
274
275 newOverloadedLit :: CtOrigin
276 -> HsOverLit Name
277 -> TcRhoType
278 -> TcM (HsOverLit TcId)
279 newOverloadedLit orig lit res_ty
280 = do dflags <- getDynFlags
281 newOverloadedLit' dflags orig lit res_ty
282
283 newOverloadedLit' :: DynFlags
284 -> CtOrigin
285 -> HsOverLit Name
286 -> TcRhoType
287 -> TcM (HsOverLit TcId)
288 newOverloadedLit' dflags orig
289 lit@(OverLit { ol_val = val, ol_rebindable = rebindable
290 , ol_witness = meth_name }) res_ty
291
292 | not rebindable
293 , Just expr <- shortCutLit dflags val res_ty
294 -- Do not generate a LitInst for rebindable syntax.
295 -- Reason: If we do, tcSimplify will call lookupInst, which
296 -- will call tcSyntaxName, which does unification,
297 -- which tcSimplify doesn't like
298 = return (lit { ol_witness = expr, ol_type = res_ty
299 , ol_rebindable = rebindable })
300
301 | otherwise
302 = do { hs_lit <- mkOverLit val
303 ; let lit_ty = hsLitType hs_lit
304 ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
305 -- Overloaded literals must have liftedTypeKind, because
306 -- we're instantiating an overloaded function here,
307 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
308 -- However this'll be picked up by tcSyntaxOp if necessary
309 ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
310 ; return (lit { ol_witness = witness, ol_type = res_ty
311 , ol_rebindable = rebindable }) }
312
313 ------------
314 mkOverLit :: OverLitVal -> TcM HsLit
315 mkOverLit (HsIntegral src i)
316 = do { integer_ty <- tcMetaTy integerTyConName
317 ; return (HsInteger src i integer_ty) }
318
319 mkOverLit (HsFractional r)
320 = do { rat_ty <- tcMetaTy rationalTyConName
321 ; return (HsRat r rat_ty) }
322
323 mkOverLit (HsIsString src s) = return (HsString src s)
324
325 {-
326 ************************************************************************
327 * *
328 Re-mappable syntax
329
330 Used only for arrow syntax -- find a way to nuke this
331 * *
332 ************************************************************************
333
334 Suppose we are doing the -XRebindableSyntax thing, and we encounter
335 a do-expression. We have to find (>>) in the current environment, which is
336 done by the rename. Then we have to check that it has the same type as
337 Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
338 this:
339
340 (>>) :: HB m n mn => m a -> n b -> mn b
341
342 So the idea is to generate a local binding for (>>), thus:
343
344 let then72 :: forall a b. m a -> m b -> m b
345 then72 = ...something involving the user's (>>)...
346 in
347 ...the do-expression...
348
349 Now the do-expression can proceed using then72, which has exactly
350 the expected type.
351
352 In fact tcSyntaxName just generates the RHS for then72, because we only
353 want an actual binding in the do-expression case. For literals, we can
354 just use the expression inline.
355 -}
356
357 tcSyntaxName :: CtOrigin
358 -> TcType -- Type to instantiate it at
359 -> (Name, HsExpr Name) -- (Standard name, user name)
360 -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
361 -- USED ONLY FOR CmdTop (sigh) ***
362 -- See Note [CmdSyntaxTable] in HsExpr
363
364 tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))
365 | std_nm == user_nm
366 = do rhs <- newMethodFromName orig std_nm ty
367 return (std_nm, rhs)
368
369 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
370 std_id <- tcLookupId std_nm
371 let
372 -- C.f. newMethodAtLoc
373 ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
374 sigma1 = substTyWith [tv] [ty] tau
375 -- Actually, the "tau-type" might be a sigma-type in the
376 -- case of locally-polymorphic methods.
377
378 addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
379
380 -- Check that the user-supplied thing has the
381 -- same type as the standard one.
382 -- Tiresome jiggling because tcCheckSigma takes a located expression
383 span <- getSrcSpanM
384 expr <- tcPolyExpr (L span user_nm_expr) sigma1
385 return (std_nm, unLoc expr)
386
387 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
388 -> TcRn (TidyEnv, SDoc)
389 syntaxNameCtxt name orig ty tidy_env
390 = do { inst_loc <- getCtLocM orig (Just TypeLevel)
391 ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
392 <+> ptext (sLit "(needed by a syntactic construct)")
393 , nest 2 (ptext (sLit "has the required type:")
394 <+> ppr (tidyType tidy_env ty))
395 , nest 2 (pprCtLoc inst_loc) ]
396 ; return (tidy_env, msg) }
397
398 {-
399 ************************************************************************
400 * *
401 Instances
402 * *
403 ************************************************************************
404 -}
405
406 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
407 -- Construct the OverlapFlag from the global module flags,
408 -- but if the overlap_mode argument is (Just m),
409 -- set the OverlapMode to 'm'
410 getOverlapFlag overlap_mode
411 = do { dflags <- getDynFlags
412 ; let overlap_ok = xopt Opt_OverlappingInstances dflags
413 incoherent_ok = xopt Opt_IncoherentInstances dflags
414 use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
415 , overlapMode = x }
416 default_oflag | incoherent_ok = use (Incoherent "")
417 | overlap_ok = use (Overlaps "")
418 | otherwise = use (NoOverlap "")
419
420 final_oflag = setOverlapModeMaybe default_oflag overlap_mode
421 ; return final_oflag }
422
423 tcGetInsts :: TcM [ClsInst]
424 -- Gets the local class instances.
425 tcGetInsts = fmap tcg_insts getGblEnv
426
427 newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
428 -> Class -> [Type] -> TcM ClsInst
429 newClsInst overlap_mode dfun_name tvs theta clas tys
430 = do { (subst, tvs') <- freshenTyVarBndrs tvs
431 -- Be sure to freshen those type variables,
432 -- so they are sure not to appear in any lookup
433 ; let tys' = substTys subst tys
434 theta' = substTheta subst theta
435 dfun = mkDictFunId dfun_name tvs' theta' clas tys'
436 -- Substituting in the DFun type just makes sure that
437 -- we are using TyVars rather than TcTyVars
438 -- Not sure if this is really the right place to do so,
439 -- but it'll do fine
440 ; oflag <- getOverlapFlag overlap_mode
441 ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
442 ; dflags <- getDynFlags
443 ; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst)
444 ; return inst }
445
446 instOrphWarn :: ClsInst -> SDoc
447 instOrphWarn inst
448 = hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
449 $$ text "To avoid this"
450 $$ nest 4 (vcat possibilities)
451 where
452 possibilities =
453 text "move the instance declaration to the module of the class or of the type, or" :
454 text "wrap the type with a newtype and declare the instance on the new type." :
455 []
456
457 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
458 -- Add new locally-defined instances
459 tcExtendLocalInstEnv dfuns thing_inside
460 = do { traceDFuns dfuns
461 ; env <- getGblEnv
462 ; (inst_env', cls_insts') <- foldlM addLocalInst
463 (tcg_inst_env env, tcg_insts env)
464 dfuns
465 ; let env' = env { tcg_insts = cls_insts'
466 , tcg_inst_env = inst_env' }
467 ; setGblEnv env' thing_inside }
468
469 addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
470 -- Check that the proposed new instance is OK,
471 -- and then add it to the home inst env
472 -- If overwrite_inst, then we can overwrite a direct match
473 addLocalInst (home_ie, my_insts) ispec
474 = do {
475 -- Load imported instances, so that we report
476 -- duplicates correctly
477
478 -- 'matches' are existing instance declarations that are less
479 -- specific than the new one
480 -- 'dups' are those 'matches' that are equal to the new one
481 ; isGHCi <- getIsGHCi
482 ; eps <- getEps
483 ; tcg_env <- getGblEnv
484
485 -- In GHCi, we *override* any identical instances
486 -- that are also defined in the interactive context
487 -- See Note [Override identical instances in GHCi]
488 ; let home_ie'
489 | isGHCi = deleteFromInstEnv home_ie ispec
490 | otherwise = home_ie
491
492 -- If we're compiling sig-of and there's an external duplicate
493 -- instance, silently ignore it (that's the instance we're
494 -- implementing!) NB: we still count local duplicate instances
495 -- as errors.
496 -- See Note [Signature files and type class instances]
497 global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv
498 | otherwise = eps_inst_env eps
499 inst_envs = InstEnvs { ie_global = global_ie
500 , ie_local = home_ie'
501 , ie_visible = tcVisibleOrphanMods tcg_env }
502
503 -- Check for inconsistent functional dependencies
504 ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
505 ; unless (null inconsistent_ispecs) $
506 funDepErr ispec inconsistent_ispecs
507
508 -- Check for duplicate instance decls.
509 ; let (_tvs, cls, tys) = instanceHead ispec
510 (matches, _, _) = lookupInstEnv False inst_envs cls tys
511 dups = filter (identicalClsInstHead ispec) (map fst matches)
512 ; unless (null dups) $
513 dupInstErr ispec (head dups)
514
515 ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
516
517 {-
518 Note [Signature files and type class instances]
519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
520 Instances in signature files do not have an effect when compiling:
521 when you compile a signature against an implementation, you will
522 see the instances WHETHER OR NOT the instance is declared in
523 the file (this is because the signatures go in the EPS and we
524 can't filter them out easily.) This is also why we cannot
525 place the instance in the hi file: it would show up as a duplicate,
526 and we don't have instance reexports anyway.
527
528 However, you might find them useful when typechecking against
529 a signature: the instance is a way of indicating to GHC that
530 some instance exists, in case downstream code uses it.
531
532 Implementing this is a little tricky. Consider the following
533 situation (sigof03):
534
535 module A where
536 instance C T where ...
537
538 module ASig where
539 instance C T
540
541 When compiling ASig, A.hi is loaded, which brings its instances
542 into the EPS. When we process the instance declaration in ASig,
543 we should ignore it for the purpose of doing a duplicate check,
544 since it's not actually a duplicate. But don't skip the check
545 entirely, we still want this to fail (tcfail221):
546
547 module ASig where
548 instance C T
549 instance C T
550
551 Note that in some situations, the interface containing the type
552 class instances may not have been loaded yet at all. The usual
553 situation when A imports another module which provides the
554 instances (sigof02m):
555
556 module A(module B) where
557 import B
558
559 See also Note [Signature lazy interface loading]. We can't
560 rely on this, however, since sometimes we'll have spurious
561 type class instances in the EPS, see #9422 (sigof02dm)
562
563 ************************************************************************
564 * *
565 Errors and tracing
566 * *
567 ************************************************************************
568 -}
569
570 traceDFuns :: [ClsInst] -> TcRn ()
571 traceDFuns ispecs
572 = traceTc "Adding instances:" (vcat (map pp ispecs))
573 where
574 pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
575 2 (ppr ispec)
576 -- Print the dfun name itself too
577
578 funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
579 funDepErr ispec ispecs
580 = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
581 (ispec : ispecs)
582
583 dupInstErr :: ClsInst -> ClsInst -> TcRn ()
584 dupInstErr ispec dup_ispec
585 = addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
586 [ispec, dup_ispec]
587
588 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
589 addClsInstsErr herald ispecs
590 = setSrcSpan (getSrcSpan (head sorted)) $
591 addErr (hang herald 2 (pprInstances sorted))
592 where
593 sorted = sortWith getSrcLoc ispecs
594 -- The sortWith just arranges that instances are dislayed in order
595 -- of source location, which reduced wobbling in error messages,
596 -- and is better for users