TcSMonad.lhs 34.7 KB
Newer Older
1
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
2
3
4
5
6
7
8
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

9
10
11
12
13
-- Type definitions for the constraint solver
module TcSMonad ( 

       -- Canonical constraints
    CanonicalCts, emptyCCan, andCCan, andCCans, 
14
    singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, 
15
    isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
batterseapower's avatar
batterseapower committed
16
    isCIrredEvCan, isCFrozenErr,
17

18
19
20
21
    WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList,
    workListFromEq, workListFromNonEq,
    workListFromEqs, workListFromNonEqs, foldrWorkListM,

22
    CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, 
23
    deCanonicalise, mkFrozenError,
24

dimitris's avatar
dimitris committed
25
26
27
    isWanted, isGivenOrSolved, isDerived,
    isGivenOrSolvedCt, isGivenCt_maybe, 
    isWantedCt, isDerivedCt, pprFlavorArising,
28

29
30
    isFlexiTcsTv,

31
    canRewrite, canSolve,
dimitris's avatar
dimitris committed
32
33
    combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
    mkWantedFlavor,
34
    getWantedLoc,
35

36
37
    TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality 
    traceFireTcS, bumpStepCountTcS,
38
    tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS,
39
40
    SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,

41
       -- Creation of evidence variables
batterseapower's avatar
batterseapower committed
42
43
44
    newEvVar,
    newDerivedId, newGivenEqVar,
    newEqVar, newIPVar, newDictVar, newKindConstraint,
45
46

       -- Setting evidence variables 
batterseapower's avatar
batterseapower committed
47
48
49
50
    setEqBind,
    setIPBind,
    setDictBind,
    setEvBind,
51
52
53

    setWantedTyBind,

dimitris's avatar
dimitris committed
54
55
    lookupFlatCacheMap, updateFlatCacheMap,

56
    getInstEnvs, getFamInstEnvs,                -- Getting the environments
57
    getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
58
    getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
59
60

    newFlattenSkolemTy,                         -- Flatten skolems 
61

62
63

    instDFunTypes,                              -- Instantiation
64
    instDFunConstraints,          
65
    newFlexiTcSTy, instFlexiTcS,
66

dreixel's avatar
dreixel committed
67
    compatKind, compatKindTcS, isSubKindTcS, unifyKindTcS,
68

69
    TcsUntouchables,
70
    isTouchableMetaTyVar,
71
    isTouchableMetaTyVar_InRange, 
72
73
74
75
76
77

    getDefaultInfo, getDynFlags,

    matchClass, matchFam, MatchInstResult (..), 
    checkWellStagedDFun, 
    warnTcS,
78
    pprEq                                   -- Smaller utils, re-exported from TcM 
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
                                             -- TODO (DV): these are only really used in the 
                                             -- instance matcher in TcSimplify. I am wondering
                                             -- if the whole instance matcher simply belongs
                                             -- here 
) where 

#include "HsVersions.h"

import HscTypes
import BasicTypes 

import Inst
import InstEnv 
import FamInst 
import FamInstEnv

import qualified TcRnMonad as TcM
import qualified TcMType as TcM
import qualified TcEnv as TcM 
98
       ( checkWellStaged, topIdLvl, tcGetDefaultTys )
dreixel's avatar
dreixel committed
99
import {-# SOURCE #-} qualified TcUnify as TcM ( unifyKindEq, mkKindErrorCtxt )
100
import Kind
101
102
103
104
105
106
import TcType
import DynFlags

import Coercion
import Class
import TyCon
107
108
import TypeRep 

109
110
import Name
import Var
111
import VarEnv
112
113
114
115
import Outputable
import Bag
import MonadUtils
import VarSet
116
import Pair
117
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
118
119
import StaticFlags
import Util
120
121
122

import HsBinds               -- for TcEvBinds stuff 
import Id 
Ian Lynagh's avatar
Ian Lynagh committed
123
import TcRnTypes
124

Ian Lynagh's avatar
Ian Lynagh committed
125
126
import Control.Monad
import Data.IORef
dimitris's avatar
dimitris committed
127
import qualified Data.Map as Map
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
\end{code}


%************************************************************************
%*									*
%*                       Canonical constraints                          *
%*                                                                      *
%*   These are the constraints the low-level simplifier works with      *
%*									*
%************************************************************************

\begin{code}
-- Types without any type functions inside.  However, note that xi
-- types CAN contain unexpanded type synonyms; however, the
-- (transitive) expansions of those type synonyms will not contain any
-- type functions.
type Xi = Type       -- In many comments, "xi" ranges over Xi

type CanonicalCts = Bag CanonicalCt
 
data CanonicalCt
  -- Atomic canonical constraints 
  = CDictCan {  -- e.g.  Num xi
      cc_id     :: EvVar,
      cc_flavor :: CtFlavor, 
      cc_class  :: Class, 
      cc_tyargs :: [Xi]
    }

  | CIPCan {	-- ?x::tau
      -- See note [Canonical implicit parameter constraints].
      cc_id     :: EvVar,
160
      cc_flavor :: CtFlavor,
161
162
163
164
      cc_ip_nm  :: IPName Name,
      cc_ip_ty  :: TcTauType
    }

batterseapower's avatar
batterseapower committed
165
166
167
168
169
170
  | CIrredEvCan {
      cc_id     :: EvVar,
      cc_flavor :: CtFlavor,
      cc_ty     :: Xi
    }

171
172
173
  | CTyEqCan {  -- tv ~ xi	(recall xi means function free)
       -- Invariant: 
       --   * tv not in tvs(xi)   (occurs check)
174
175
       --   * typeKind xi `compatKind` typeKind tv
       --       See Note [Spontaneous solving and kind compatibility]
176
       --   * We prefer unification variables on the left *JUST* for efficiency
177
178
      cc_id     :: EvVar, 
      cc_flavor :: CtFlavor, 
179
180
      cc_tyvar  :: TcTyVar, 
      cc_rhs    :: Xi
181
182
183
184
    }

  | CFunEqCan {  -- F xis ~ xi  
                 -- Invariant: * isSynFamilyTyCon cc_fun 
185
                 --            * typeKind (F xis) `compatKind` typeKind xi
186
187
188
189
190
191
192
193
194
      cc_id     :: EvVar,
      cc_flavor :: CtFlavor, 
      cc_fun    :: TyCon,	-- A type function
      cc_tyargs :: [Xi],	-- Either under-saturated or exactly saturated
      cc_rhs    :: Xi      	--    *never* over-saturated (because if so
      		      		--    we should have decomposed)
                   
    }

195
196
197
198
199
  | CFrozenErr {      -- A "frozen error" does not interact with anything
                      -- See Note [Frozen Errors]
      cc_id     :: EvVar,
      cc_flavor :: CtFlavor
    }
200

201
202
203
204
205
mkFrozenError :: CtFlavor -> EvVar -> CanonicalCt
mkFrozenError fl ev = CFrozenErr { cc_id = ev, cc_flavor = fl }

compatKind :: Kind -> Kind -> Bool
compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 
206

dreixel's avatar
dreixel committed
207
208
209
210
211
212
213
214
215
216
compatKindTcS :: Kind -> Kind -> TcS Bool
-- Because kind unification happens during constraint solving, we have
-- to make sure that two kinds are zonked before we compare them.
compatKindTcS k1 k2 = wrapTcS (TcM.compatKindTcM k1 k2)

isSubKindTcS :: Kind -> Kind -> TcS Bool
isSubKindTcS k1 k2 = wrapTcS (TcM.isSubKindTcM k1 k2)

unifyKindTcS :: Type -> Type     -- Context
             -> Kind -> Kind     -- Corresponding kinds
217
             -> TcS Bool
dreixel's avatar
dreixel committed
218
unifyKindTcS ty1 ty2 ki1 ki2
219
220
221
  = wrapTcS $ TcM.addErrCtxtM ctxt $ do
      (_errs, mb_r) <- TcM.tryTc (TcM.unifyKindEq ki1 ki2)
      return (maybe False (const True) mb_r)
dreixel's avatar
dreixel committed
222
223
  where ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2

224
225
deCanonicalise :: CanonicalCt -> FlavoredEvVar
deCanonicalise ct = mkEvVarX (cc_id ct) (cc_flavor ct)
226
227
228
229
230

tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet
tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) 	       = tyVarsOfTypes tys
231
tyVarsOfCanonical (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty
batterseapower's avatar
batterseapower committed
232
tyVarsOfCanonical (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty
233
tyVarsOfCanonical (CFrozenErr { cc_id = ev })                  = tyVarsOfEvVar ev
234

235
236
237
238
239
240
241
tyVarsOfCDict :: CanonicalCt -> TcTyVarSet 
tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCDict _ct                            = emptyVarSet 

tyVarsOfCDicts :: CanonicalCts -> TcTyVarSet 
tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet

242
243
244
245
246
247
248
249
tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet

instance Outputable CanonicalCt where
  ppr (CDictCan d fl cls tys)     
      = ppr fl <+> ppr d  <+> dcolon <+> pprClassPred cls tys
  ppr (CIPCan ip fl ip_nm ty)     
      = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
batterseapower's avatar
batterseapower committed
250
251
  ppr (CIrredEvCan v fl ty)
      = ppr fl <+> ppr v <+> dcolon <+> ppr ty
252
  ppr (CTyEqCan co fl tv ty)      
253
      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty)
254
  ppr (CFunEqCan co fl tc tys ty) 
255
      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty)
256
257
  ppr (CFrozenErr co fl)
      = ppr fl <+> pprEvVarWithType co
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
\end{code}

Note [Canonical implicit parameter constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The type in a canonical implicit parameter constraint doesn't need to
be a xi (type-function-free type) since we can defer the flattening
until checking this type for equality with another type.  If we
encounter two IP constraints with the same name, they MUST have the
same type, and at that point we can generate a flattened equality
constraint between the types.  (On the other hand, the types in two
class constraints for the same class MAY be equal, so they need to be
flattened in the first place to facilitate comparing them.)

\begin{code}
singleCCan :: CanonicalCt -> CanonicalCts 
singleCCan = unitBag 

andCCan :: CanonicalCts -> CanonicalCts -> CanonicalCts 
andCCan = unionBags

extendCCans :: CanonicalCts -> CanonicalCt -> CanonicalCts 
extendCCans = snocBag 

andCCans :: [CanonicalCts] -> CanonicalCts 
andCCans = unionManyBags

emptyCCan :: CanonicalCts 
emptyCCan = emptyBag

isEmptyCCan :: CanonicalCts -> Bool
isEmptyCCan = isEmptyBag
289

290
291
292
293
294
295
296
297
298
299
300
301
302
isCTyEqCan :: CanonicalCt -> Bool 
isCTyEqCan (CTyEqCan {})  = True 
isCTyEqCan (CFunEqCan {}) = False
isCTyEqCan _              = False 

isCDictCan_Maybe :: CanonicalCt -> Maybe Class
isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls
isCDictCan_Maybe _              = Nothing

isCIPCan_Maybe :: CanonicalCt -> Maybe (IPName Name)
isCIPCan_Maybe  (CIPCan {cc_ip_nm = nm }) = Just nm
isCIPCan_Maybe _                = Nothing

batterseapower's avatar
batterseapower committed
303
304
305
306
isCIrredEvCan :: CanonicalCt -> Bool
isCIrredEvCan (CIrredEvCan {}) = True
isCIrredEvCan _                = False

307
308
309
isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon
isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc
isCFunEqCan_Maybe _ = Nothing
310

311
312
313
isCFrozenErr :: CanonicalCt -> Bool
isCFrozenErr (CFrozenErr {}) = True
isCFrozenErr _               = False
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361


-- A mixture of Given, Wanted, and Derived constraints. 
-- We split between equalities and the rest to process equalities first. 
data WorkList = WorkList { weqs  :: CanonicalCts 
                                 -- NB: weqs includes equalities /and/ family equalities
                         , wrest :: CanonicalCts }

unionWorkList :: WorkList -> WorkList -> WorkList
unionWorkList wl1 wl2
  = WorkList { weqs = weqs wl1 `andCCan` weqs wl2
             , wrest = wrest wl1 `andCCan` wrest wl2 }

unionWorkLists :: [WorkList] -> WorkList 
unionWorkLists = foldr unionWorkList emptyWorkList

isEmptyWorkList :: WorkList -> Bool
isEmptyWorkList wl = isEmptyCCan (weqs wl) && isEmptyCCan (wrest wl)

emptyWorkList :: WorkList
emptyWorkList
  = WorkList { weqs = emptyBag, wrest = emptyBag }

workListFromEq :: CanonicalCt -> WorkList
workListFromEq = workListFromEqs . singleCCan

workListFromNonEq :: CanonicalCt -> WorkList
workListFromNonEq = workListFromNonEqs . singleCCan 

workListFromNonEqs :: CanonicalCts -> WorkList
workListFromNonEqs cts
  = WorkList { weqs = emptyCCan, wrest = cts }

workListFromEqs :: CanonicalCts -> WorkList
workListFromEqs cts
  = WorkList { weqs = cts, wrest = emptyCCan }

foldrWorkListM :: (Monad m) => (CanonicalCt -> r -> m r) 
                           -> r -> WorkList -> m r
-- Prioritizes equalities
foldrWorkListM on_ct r (WorkList {weqs = eqs, wrest = rest })
  = do { r1 <- foldrBagM on_ct r eqs
       ; foldrBagM on_ct r1 rest }

instance Outputable WorkList where 
  ppr wl = vcat [ text "WorkList (Equalities) = " <+> ppr (weqs wl)
                , text "WorkList (Other)      = " <+> ppr (wrest wl) ]

362
363
\end{code}

364
365


366
367
368
369
370
371
372
373
%************************************************************************
%*									*
                    CtFlavor
         The "flavor" of a canonical constraint
%*									*
%************************************************************************

\begin{code}
374
375
376
377
378
379
380
getWantedLoc :: CanonicalCt -> WantedLoc
getWantedLoc ct 
  = ASSERT (isWanted (cc_flavor ct))
    case cc_flavor ct of 
      Wanted wl -> wl 
      _         -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty

381
isWantedCt :: CanonicalCt -> Bool
382
isWantedCt ct = isWanted (cc_flavor ct)
383
384
isDerivedCt :: CanonicalCt -> Bool
isDerivedCt ct = isDerived (cc_flavor ct)
385

dimitris's avatar
dimitris committed
386
387
388
389
390
391
392
isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)

isGivenOrSolvedCt :: CanonicalCt -> Bool
isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)


393
394
395
canSolve :: CtFlavor -> CtFlavor -> Bool 
-- canSolve ctid1 ctid2 
-- The constraint ctid1 can be used to solve ctid2 
dimitris@microsoft.com's avatar
dimitris@microsoft.com committed
396
397
398
399
400
-- "to solve" means a reaction where the active parts of the two constraints match.
--  active(F xis ~ xi) = F xis 
--  active(tv ~ xi)    = tv 
--  active(D xis)      = D xis 
--  active(IP nm ty)   = nm 
401
402
--
-- NB:  either (a `canSolve` b) or (b `canSolve` a) must hold
dimitris@microsoft.com's avatar
dimitris@microsoft.com committed
403
-----------------------------------------
404
canSolve (Given {})   _            = True 
405
canSolve (Wanted {})  (Derived {}) = True
406
canSolve (Wanted {})  (Wanted {})  = True
407
408
canSolve (Derived {}) (Derived {}) = True  -- Important: derived can't solve wanted/given
canSolve _ _ = False  	       	     	   -- (There is no *evidence* for a derived.)
409

410
411
canRewrite :: CtFlavor -> CtFlavor -> Bool 
-- canRewrite ctid1 ctid2 
dimitris@microsoft.com's avatar
dimitris@microsoft.com committed
412
-- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 
413
canRewrite = canSolve 
dimitris@microsoft.com's avatar
dimitris@microsoft.com committed
414

415
416
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted 
dimitris's avatar
dimitris committed
417
418
419
420
combineCtLoc (Wanted loc) _    = loc
combineCtLoc _ (Wanted loc)    = loc
combineCtLoc (Derived loc ) _  = loc
combineCtLoc _ (Derived loc )  = loc
421
combineCtLoc _ _ = panic "combineCtLoc: both given"
422

dimitris's avatar
dimitris committed
423
424
425
426
427
mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
mkSolvedFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
mkSolvedFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
428

dimitris's avatar
dimitris committed
429
430
431
432
mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
mkGivenFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
mkGivenFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
433
434

mkWantedFlavor :: CtFlavor -> CtFlavor
435
436
mkWantedFlavor (Wanted  loc) = Wanted loc
mkWantedFlavor (Derived loc) = Wanted loc
dimitris's avatar
dimitris committed
437
mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
\end{code}

%************************************************************************
%*									*
%*		The TcS solver monad                                    *
%*									*
%************************************************************************

Note [The TcS monad]
~~~~~~~~~~~~~~~~~~~~
The TcS monad is a weak form of the main Tc monad

All you can do is
    * fail
    * allocate new variables
    * fill in evidence variables

Filling in a dictionary evidence variable means to create a binding
for it, so TcS carries a mutable location where the binding can be
added.  This is initialised from the innermost implication constraint.

\begin{code}
data TcSEnv
  = TcSEnv { 
      tcs_ev_binds :: EvBindsVar,
          -- Evidence bindings

465
      tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
466
467
          -- Global type bindings

468
      tcs_context :: SimplContext,
469
                     
470
471
      tcs_untch :: TcsUntouchables,

dimitris's avatar
dimitris committed
472
473
474
475
      tcs_ic_depth   :: Int,       -- Implication nesting depth
      tcs_count      :: IORef Int, -- Global step count

      tcs_flat_map   :: IORef FlatCache
476
477
    }

dimitris's avatar
dimitris committed
478
data FlatCache 
batterseapower's avatar
batterseapower committed
479
  = FlatCache { givenFlatCache  :: Map.Map FunEqHead (TcType,EqVar,CtFlavor)
dimitris's avatar
dimitris committed
480
                -- Invariant: all CtFlavors here satisfy isGiven
batterseapower's avatar
batterseapower committed
481
              , wantedFlatCache :: Map.Map FunEqHead (TcType,EqVar,CtFlavor) }
dimitris's avatar
dimitris committed
482
483
484
485
486
487
488
489
490
                -- Invariant: all CtFlavors here satisfy isWanted

emptyFlatCache :: FlatCache
emptyFlatCache 
 = FlatCache { givenFlatCache  = Map.empty, wantedFlatCache = Map.empty }

newtype FunEqHead = FunEqHead (TyCon,[Xi])

instance Eq FunEqHead where
dimitris's avatar
dimitris committed
491
  FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
dimitris's avatar
dimitris committed
492
493
494
495

instance Ord FunEqHead where
  FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2) 
    = case compare tc1 tc2 of 
dimitris's avatar
dimitris committed
496
        EQ    -> cmpTypes xis1 xis2
dimitris's avatar
dimitris committed
497
498
        other -> other

499
500
501
502
type TcsUntouchables = (Untouchables,TcTyVarSet)
-- Like the TcM Untouchables, 
-- but records extra TcsTv variables generated during simplification
-- See Note [Extra TcsTv untouchables] in TcSimplify
503
504
505
\end{code}

\begin{code}
506
data SimplContext
507
508
509
510
  = SimplInfer SDoc	   -- Inferring type of a let-bound thing
  | SimplRuleLhs RuleName  -- Inferring type of a RULE lhs
  | SimplInteractive	   -- Inferring type at GHCi prompt
  | SimplCheck SDoc	   -- Checking a type signature or RULE rhs
511
512

instance Outputable SimplContext where
513
514
515
  ppr (SimplInfer d)   = ptext (sLit "SimplInfer") <+> d
  ppr (SimplCheck d)   = ptext (sLit "SimplCheck") <+> d
  ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n)
516
517
518
519
520
521
522
523
524
525
  ppr SimplInteractive = ptext (sLit "SimplInteractive")

isInteractive :: SimplContext -> Bool
isInteractive SimplInteractive = True
isInteractive _                = False

simplEqsOnly :: SimplContext -> Bool
-- Simplify equalities only, not dictionaries
-- This is used for the LHS of rules; ee
-- Note [Simplifying RULE lhs constraints] in TcSimplify
526
527
simplEqsOnly (SimplRuleLhs {}) = True
simplEqsOnly _                 = False
528
529

performDefaulting :: SimplContext -> Bool
530
531
532
533
performDefaulting (SimplInfer {})   = False
performDefaulting (SimplRuleLhs {}) = False
performDefaulting SimplInteractive  = True
performDefaulting (SimplCheck {})   = True
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570

---------------
newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 

instance Functor TcS where
  fmap f m = TcS $ fmap f . unTcS m

instance Monad TcS where 
  return x  = TcS (\_ -> return x) 
  fail err  = TcS (\_ -> fail err) 
  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)

-- Basic functionality 
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
wrapTcS :: TcM a -> TcS a 
-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
-- and TcS is supposed to have limited functionality
wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds

wrapErrTcS :: TcM a -> TcS a 
-- The thing wrapped should just fail
-- There's no static check; it's up to the user
-- Having a variant for each error message is too painful
wrapErrTcS = wrapTcS

wrapWarnTcS :: TcM a -> TcS a 
-- The thing wrapped should just add a warning, or no-op
-- There's no static check; it's up to the user
wrapWarnTcS = wrapTcS

failTcS, panicTcS :: SDoc -> TcS a
failTcS      = wrapTcS . TcM.failWith
panicTcS doc = pprPanic "TcCanonical" doc

traceTcS :: String -> SDoc -> TcS ()
traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc

571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
bumpStepCountTcS :: TcS ()
bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
                                    ; n <- TcM.readTcRef ref
                                    ; TcM.writeTcRef ref (n+1) }

traceFireTcS :: Int -> SDoc -> TcS ()
-- Dump a rule-firing trace
traceFireTcS depth doc 
  = TcS $ \env -> 
    TcM.ifDOptM Opt_D_dump_cs_trace $ 
    do { n <- TcM.readTcRef (tcs_count env)
       ; let msg = int n 
                <> text (replicate (tcs_ic_depth env) '>')
                <> brackets (int depth) <+> doc
       ; TcM.dumpTcRn msg }
586
587

runTcS :: SimplContext
588
       -> Untouchables 	       -- Untouchables
589
       -> TcS a		       -- What to run
590
       -> TcM (a, Bag EvBind)
591
runTcS context untouch tcs 
592
  = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
593
       ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
594
       ; step_count <- TcM.newTcRef 0
dimitris's avatar
dimitris committed
595
       ; flat_cache_var <- TcM.newTcRef emptyFlatCache
596
597
       ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
                          , tcs_ty_binds = ty_binds_var
598
                          , tcs_context  = context
599
                          , tcs_untch    = (untouch, emptyVarSet) -- No Tcs untouchables yet
600
601
			  , tcs_count    = step_count
			  , tcs_ic_depth = 0
dimitris's avatar
dimitris committed
602
                          , tcs_flat_map = flat_cache_var
603
                          }
604
605

	     -- Run the computation
606
       ; res <- unTcS tcs env
607
608
	     -- Perform the type unifications required
       ; ty_binds <- TcM.readTcRef ty_binds_var
609
       ; mapM_ do_unification (varEnvElts ty_binds)
610

Ian Lynagh's avatar
Ian Lynagh committed
611
612
613
614
615
616
       ; when debugIsOn $ do {
             count <- TcM.readTcRef step_count
           ; when (opt_PprStyle_Debug && count > 0) $
             TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") 
                                <+> int count <+> ppr context)
         }
617
             -- And return
618
       ; ev_binds      <- TcM.readTcRef evb_ref
619
       ; return (res, evBindMapBinds ev_binds) }
620
621
  where
    do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
622

623
nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a
624
625
626
627
628
nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
  = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds 
    	    	   , tcs_untch = (_outer_range, outer_tcs)
		   , tcs_count = count
		   , tcs_ic_depth = idepth
dimitris's avatar
dimitris committed
629
630
631
632
                   , tcs_context = ctxt 
                   , tcs_flat_map = orig_flat_cache_var
                   } ->
    do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
633
634
635
636
       		   -- The inner_range should be narrower than the outer one
		   -- (thus increasing the set of untouchables) but 
		   -- the inner Tcs-untouchables must be unioned with the
		   -- outer ones!
dimitris's avatar
dimitris committed
637
638

       ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
639
640
641
       ; flat_cache_var  <- TcM.newTcRef orig_flat_cache
       -- One could be more conservative as well: 
       -- ; flat_cache_var  <- TcM.newTcRef emptyFlatCache 
dimitris's avatar
dimitris committed
642
643
644
645
646
647
648
649
650
651
652
653

                            -- Consider copying the results the tcs_flat_map of the 
                            -- incomping constraint, but we must make sure that we
                            -- have pushed everything in, which seems somewhat fragile
       ; let nest_env = TcSEnv { tcs_ev_binds = ref
                               , tcs_ty_binds = ty_binds
                               , tcs_untch    = inner_untch
                               , tcs_count    = count
                               , tcs_ic_depth = idepth+1
                               , tcs_context  = ctxtUnderImplic ctxt 
                               , tcs_flat_map = flat_cache_var }
       ; thing_inside nest_env }
654

655
656
657
658
659
recoverTcS :: TcS a -> TcS a -> TcS a
recoverTcS (TcS recovery_code) (TcS thing_inside)
  = TcS $ \ env ->
    TcM.recoverM (recovery_code env) (thing_inside env)

660
661
ctxtUnderImplic :: SimplContext -> SimplContext
-- See Note [Simplifying RULE lhs constraints] in TcSimplify
662
663
664
ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") 
                                               <+> doubleQuotes (ftext n))
ctxtUnderImplic ctxt              = ctxt
665

666
tryTcS :: TcS a -> TcS a
dimitris's avatar
dimitris committed
667
-- Like runTcS, but from within the TcS monad
668
-- Ignore all the evidence generated, and do not affect caller's evidence!
dimitris's avatar
dimitris committed
669
tryTcS tcs
670
  = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
671
                    ; ev_binds_var <- TcM.newTcEvBinds
dimitris's avatar
dimitris committed
672
                    ; flat_cache_var <- TcM.newTcRef emptyFlatCache
673
                    ; let env1 = env { tcs_ev_binds = ev_binds_var
dimitris's avatar
dimitris committed
674
675
676
                                     , tcs_ty_binds = ty_binds_var
                                     , tcs_flat_map = flat_cache_var }
                   ; unTcS tcs env1 })
677
678
679
680
681
682
683
684
685
686
687
688
689

-- Update TcEvBinds 
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

getDynFlags :: TcS DynFlags
getDynFlags = wrapTcS TcM.getDOpts

getTcSContext :: TcS SimplContext
getTcSContext = TcS (return . tcs_context)

getTcEvBinds :: TcS EvBindsVar
getTcEvBinds = TcS (return . tcs_ev_binds) 

690
getUntouchables :: TcS TcsUntouchables
691
692
getUntouchables = TcS (return . tcs_untch)

693
getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
694
695
getTcSTyBinds = TcS (return . tcs_ty_binds)

696
getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
697
getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
698

dimitris's avatar
dimitris committed
699
700
701
702
703
getFlatCacheMapVar :: TcS (IORef FlatCache)
getFlatCacheMapVar
  = TcS (return . tcs_flat_map)

lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor 
batterseapower's avatar
batterseapower committed
704
                   -> TcS (Maybe (TcType,EqVar,CtFlavor))
dimitris's avatar
dimitris committed
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
-- For givens, we lookup in given flat cache
lookupFlatCacheMap tc xis (Given {})
  = do { cache_ref <- getFlatCacheMapVar
       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
       ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) }
-- For wanteds, we first lookup in givenFlatCache.
-- If we get nothing back then we lookup in wantedFlatCache.
lookupFlatCacheMap tc xis (Wanted {})
  = do { cache_ref <- getFlatCacheMapVar
       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
       ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of
           Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map)
           other   -> return other }
lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing

updateFlatCacheMap :: TyCon -> [Xi]
batterseapower's avatar
batterseapower committed
721
722
                   -> TcType -> CtFlavor -> EqVar -> TcS ()
updateFlatCacheMap _tc _xis _tv (Derived {}) _eqv
dimitris's avatar
dimitris committed
723
  = return () -- Not caching deriveds
batterseapower's avatar
batterseapower committed
724
updateFlatCacheMap tc xis ty fl eqv
dimitris's avatar
dimitris committed
725
726
727
728
  = do { cache_ref <- getFlatCacheMapVar
       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
       ; let new_cache_map
              | isGivenOrSolved fl
batterseapower's avatar
batterseapower committed
729
              = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,eqv,fl) $
dimitris's avatar
dimitris committed
730
731
                                             givenFlatCache cache_map }
              | isWanted fl
batterseapower's avatar
batterseapower committed
732
              = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,eqv,fl) $
dimitris's avatar
dimitris committed
733
734
735
736
                                              wantedFlatCache cache_map }
              | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
       ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }

737

738
739
740
741
742
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
  = do { EvBindsVar ev_ref _ <- getTcEvBinds 
       ; wrapTcS $ TcM.readTcRef ev_ref }

batterseapower's avatar
batterseapower committed
743
744
setEqBind :: EqVar -> LCoercion -> TcS () 
setEqBind eqv co = setEvBind eqv (EvCoercionBox co)
745
746
747

setWantedTyBind :: TcTyVar -> TcType -> TcS () 
-- Add a type binding
748
-- We never do this twice!
749
750
751
752
setWantedTyBind tv ty 
  = do { ref <- getTcSTyBinds
       ; wrapTcS $ 
         do { ty_binds <- TcM.readTcRef ref
Ian Lynagh's avatar
Ian Lynagh committed
753
754
755
756
757
            ; when debugIsOn $
                  TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $
                  vcat [ text "TERRIBLE ERROR: double set of meta type variable"
                       , ppr tv <+> text ":=" <+> ppr ty
                       , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
758
            ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
759
760
761
762
763
764
765
766
767

setIPBind :: EvVar -> EvTerm -> TcS () 
setIPBind = setEvBind 

setDictBind :: EvVar -> EvTerm -> TcS () 
setDictBind = setEvBind 

setEvBind :: EvVar -> EvTerm -> TcS () 
-- Internal
batterseapower's avatar
batterseapower committed
768
setEvBind ev t
769
  = do { tc_evbinds <- getTcEvBinds
batterseapower's avatar
batterseapower committed
770
       ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t }
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810

warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
warnTcS loc warn_if doc 
  | warn_if   = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
  | otherwise = return ()

getDefaultInfo ::  TcS (SimplContext, [Type], (Bool, Bool))
getDefaultInfo 
  = do { ctxt <- getTcSContext
       ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
       ; return (ctxt, tys, flags) }

-- Just get some environments needed for instance looking up and matching
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

getInstEnvs :: TcS (InstEnv, InstEnv) 
getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs 

getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) 
getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs

getTopEnv :: TcS HscEnv 
getTopEnv = wrapTcS $ TcM.getTopEnv 

getGblEnv :: TcS TcGblEnv 
getGblEnv = wrapTcS $ TcM.getGblEnv 

-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS () 
checkWellStagedDFun pred dfun_id loc 
  = wrapTcS $ TcM.setCtLoc loc $ 
    do { use_stage <- TcM.getStage
       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
  where
    pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
    bind_lvl = TcM.topIdLvl dfun_id

pprEq :: TcType -> TcType -> SDoc
batterseapower's avatar
batterseapower committed
811
pprEq ty1 ty2 = pprType $ mkEqPred (ty1,ty2)
812
813

isTouchableMetaTyVar :: TcTyVar -> TcS Bool
814
isTouchableMetaTyVar tv 
815
816
817
  = do { untch <- getUntouchables
       ; return $ isTouchableMetaTyVar_InRange untch tv } 

818
819
isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool 
isTouchableMetaTyVar_InRange (untch,untch_tcs) tv 
820
  = case tcTyVarDetails tv of 
821
822
      MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs)
                        -- See Note [Touchable meta type variables] 
823
824
825
826
      MetaTv {}      -> inTouchableRange untch tv 
      _              -> False 


827
828
\end{code}

829

830
831
832
833
834
835
836
837
838
839
Note [Touchable meta type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Meta type variables allocated *by the constraint solver itself* are always
touchable.  Example: 
   instance C a b => D [a] where...
if we use this instance declaration we "make up" a fresh meta type
variable for 'b', which we must later guess.  (Perhaps C has a
functional dependency.)  But since we aren't in the constraint *generator*
we can't allocate a Unique in the touchable range for this implication
constraint.  Instead, we mark it as a "TcsTv", which makes it always-touchable.
840
841


842
\begin{code}
843
844
845
846
847
-- Flatten skolems
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

newFlattenSkolemTy :: TcType -> TcS TcType
newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
848
849
850

newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
newFlattenSkolemTyVar ty
851
  = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique
852
                            ; let name = TcM.mkTcTyVarName uniq (fsLit "f")
853
854
855
856
                            ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } 
       ; traceTcS "New Flatten Skolem Born" $ 
           (ppr tv <+> text "[:= " <+> ppr ty <+> text "]")
       ; return tv }
857
858
859
860
861

-- Instantiations 
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

instDFunTypes :: [Either TyVar TcType] -> TcS [TcType] 
862
863
864
865
instDFunTypes mb_inst_tys 
  = mapM inst_tv mb_inst_tys
  where
    inst_tv :: Either TyVar TcType -> TcS Type
866
    inst_tv (Left tv)  = mkTyVarTy <$> instFlexiTcS tv
867
    inst_tv (Right ty) = return ty 
868
869
870
871

instDFunConstraints :: TcThetaType -> TcS [EvVar] 
instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds 

872

873
instFlexiTcS :: TyVar -> TcS TcTyVar 
874
875
876
-- Like TcM.instMetaTyVar but the variable that is created is always
-- touchable; we are supposed to guess its instantiation. 
-- See Note [Touchable meta type variables] 
877
instFlexiTcS tv = instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) 
878

879
880
881
882
883
newFlexiTcSTy :: Kind -> TcS TcType  
newFlexiTcSTy knd 
  = wrapTcS $
    do { uniq <- TcM.newUnique 
       ; ref  <- TcM.newMutVar  Flexi 
884
       ; let name = TcM.mkTcTyVarName uniq (fsLit "uf")
885
886
       ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) }

887
888
889
890
891
892
isFlexiTcsTv :: TyVar -> Bool
isFlexiTcsTv tv
  | not (isTcTyVar tv)                  = False
  | MetaTv TcsTv _ <- tcTyVarDetails tv = True
  | otherwise                           = False

893
newKindConstraint :: TcTyVar -> Kind -> TcS CoVar
894
895
-- Create new wanted CoVar that constrains the type to have the specified kind. 
newKindConstraint tv knd 
896
  = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd 
897
       ; let ty_k = mkTyVarTy tv_k
batterseapower's avatar
batterseapower committed
898
899
       ; eqv <- newEqVar (mkTyVarTy tv) ty_k
       ; return eqv }
900

901
902
instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar
instFlexiTcSHelper tvname tvkind
903
904
905
906
907
908
  = wrapTcS $ 
    do { uniq <- TcM.newUnique 
       ; ref  <- TcM.newMutVar  Flexi 
       ; let name = setNameUnique tvname uniq 
             kind = tvkind 
       ; return (mkTcTyVar name kind (MetaTv TcsTv ref)) }
909
910
911
912

-- Superclasses and recursive dictionaries 
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

913
914
newEvVar :: TcPredType -> TcS EvVar
newEvVar pty = wrapTcS $ TcM.newEvVar pty
915

916
917
918
newDerivedId :: TcPredType -> TcS EvVar 
newDerivedId pty = wrapTcS $ TcM.newEvVar pty

batterseapower's avatar
batterseapower committed
919
newGivenEqVar :: TcType -> TcType -> Coercion -> TcS EvVar 
920
921
922
923
-- Note we create immutable variables for given or derived, since we
-- must bind them to TcEvBinds (because their evidence may involve 
-- superclasses). However we should be able to override existing
-- 'derived' evidence, even in TcEvBinds 
batterseapower's avatar
batterseapower committed
924
925
926
newGivenEqVar ty1 ty2 co 
  = do { cv <- newEqVar ty1 ty2
       ; setEvBind cv (EvCoercionBox co) 
927
928
       ; return cv } 

batterseapower's avatar
batterseapower committed
929
930
newEqVar :: TcType -> TcType -> TcS EvVar
newEqVar ty1 ty2 = wrapTcS $ TcM.newEq ty1 ty2 
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954

newIPVar :: IPName Name -> TcType -> TcS EvVar 
newIPVar nm ty = wrapTcS $ TcM.newIP nm ty 

newDictVar :: Class -> [TcType] -> TcS EvVar 
newDictVar cl tys = wrapTcS $ TcM.newDict cl tys 
\end{code} 


\begin{code} 
-- Matching and looking up classes and family instances
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

data MatchInstResult mi
  = MatchInstNo         -- No matching instance 
  | MatchInstSingle mi  -- Single matching instance
  | MatchInstMany       -- Multiple matching instances


matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType])) 
-- Look up a class constraint in the instance environment
matchClass clas tys
  = do	{ let pred = mkClassPred clas tys 
        ; instEnvs <- getInstEnvs
955
        ; case lookupInstEnv instEnvs clas tys of {
956
            ([], unifs, _)               -- Nothing matches  
957
958
959
960
961
                -> do { traceTcS "matchClass not matching"
                                 (vcat [ text "dict" <+> ppr pred, 
                                         text "unifs" <+> ppr unifs ]) 
                      ; return MatchInstNo  
                      } ;  
962
	    ([(ispec, inst_tys)], [], _) -- A single match 
963
964
965
966
		-> do	{ let dfun_id = is_dfun ispec
			; traceTcS "matchClass success"
				   (vcat [text "dict" <+> ppr pred, 
				          text "witness" <+> ppr dfun_id
967
                                           <+> ppr (idType dfun_id) ])
968
				  -- Record that this dfun is needed
969
                        ; return $ MatchInstSingle (dfun_id, inst_tys)
970
                        } ;
971
     	    (matches, unifs, _)          -- More than one matches 
972
973
974
975
976
977
978
979
		-> do	{ traceTcS "matchClass multiple matches, deferring choice"
			           (vcat [text "dict" <+> ppr pred,
				   	  text "matches" <+> ppr matches,
				   	  text "unifs" <+> ppr unifs])
                        ; return MatchInstMany 
		        }
	}
        }
980

981
matchFam :: TyCon -> [Type] -> TcS (Maybe (TyCon, [Type]))
982
matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args
983
\end{code}