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