TcCanonical.lhs 66.9 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
module TcCanonical(
10
11
12
13
14
    canonicalize,
    canOccursCheck, canEq, canEvVar,
    rewriteWithFunDeps,
    emitFDWorkAsWanted, emitFDWorkAsDerived,
    StopOrContinue (..)
15
16
17
18
 ) where

#include "HsVersions.h"

19
import BasicTypes ( IPName )
20
import TcErrors
21
import TcRnTypes
22
23
import FunDeps
import qualified TcMType as TcM
24
import TcType
25
import Type
dreixel's avatar
dreixel committed
26
import Kind
27
import TcEvidence
28
29
30
import Class
import TyCon
import TypeRep
31
import Name ( Name )
32
import Var
33
import VarEnv
34
import Outputable
35
import Control.Monad    ( when, unless, zipWithM, foldM )
36
37
38
import MonadUtils
import Control.Applicative ( (<|>) )

39
import TrieMap
40
import VarSet
41
import TcSMonad
42
import FastString
43

44
45
46
47
import Data.Maybe ( isNothing )
import Pair ( pSnd )

\end{code}
48
49
50
51


%************************************************************************
%*                                                                      *
52
%*                      The Canonicaliser                               *
53
54
55
%*                                                                      *
%************************************************************************

56
57
Note [Canonicalization]
~~~~~~~~~~~~~~~~~~~~~~~
58

59
60
61
62
Canonicalization converts a flat constraint to a canonical form. It is
unary (i.e. treats individual constraints one at a time), does not do
any zonking, but lives in TcS monad because it needs to create fresh
variables (for flattening) and consult the inerts (for efficiency).
63

64
65
66
67
68
The execution plan for canonicalization is the following:
 
  1) Decomposition of equalities happens as necessary until we reach a 
     variable or type family in one side. There is no decomposition step
     for other forms of constraints. 
69

70
71
72
73
  2) If, when we decompose, we discover a variable on the head then we 
     look at inert_eqs from the current inert for a substitution for this 
     variable and contine decomposing. Hence we lazily apply the inert 
     substitution if it is needed. 
74

75
76
  3) If no more decomposition is possible, we deeply apply the substitution
     from the inert_eqs and continue with flattening.
77

78
79
80
81
82
  4) During flattening, we examine whether we have already flattened some 
     function application by looking at all the CTyFunEqs with the same 
     function in the inert set. The reason for deeply applying the inert 
     substitution at step (3) is to maximise our chances of matching an 
     already flattened family application in the inert. 
83

84
85
86
87
The net result is that a constraint coming out of the canonicalization 
phase cannot be rewritten any further from the inerts (but maybe /it/ can 
rewrite an inert or still interact with an inert in a further phase in the
simplifier.
dimitris's avatar
dimitris committed
88

89
\begin{code}
90

91
92
93
94
95
96
97
-- Informative results of canonicalization
data StopOrContinue 
  = ContinueWith Ct   -- Either no canonicalization happened, or if some did 
                      -- happen, it is still safe to just keep going with this 
                      -- work item. 
  | Stop              -- Some canonicalization happened, extra work is now in 
                      -- the TcS WorkList. 
98

99
100
101
instance Outputable StopOrContinue where
  ppr Stop             = ptext (sLit "Stop")
  ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w
102
103


104
105
continueWith :: Ct -> TcS StopOrContinue
continueWith = return . ContinueWith
106

107
108
109
110
111
112
113
114
andWhenContinue :: TcS StopOrContinue 
                -> (Ct -> TcS StopOrContinue) 
                -> TcS StopOrContinue
andWhenContinue tcs1 tcs2
  = do { r <- tcs1
       ; case r of
           Stop            -> return Stop
           ContinueWith ct -> tcs2 ct }
115
116
117

\end{code}

118
119
120
121
122
Note [Caching for canonicals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
Our plan with pre-canonicalization is to be able to solve a constraint really fast from existing
bindings in TcEvBinds. So one may think that the condition (isCNonCanonical) is not necessary. 
However consider the following setup:
123

124
125
InertSet = { [W] d1 : Num t } 
WorkList = { [W] d2 : Num t, [W] c : t ~ Int} 
126

127
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
Now, we prioritize equalities, but in our concrete example (should_run/mc17.hs) the first (d2) constraint 
is dealt with first, because (t ~ Int) is an equality that only later appears in the worklist since it is
pulled out from a nested implication constraint. So, let's examine what happens:
 
   - We encounter work item (d2 : Num t)

   - Nothing is yet in EvBinds, so we reach the interaction with inerts 
     and set:
              d2 := d1 
    and we discard d2 from the worklist. The inert set remains unaffected.

   - Now the equation ([W] c : t ~ Int) is encountered and kicks-out (d1 : Num t) from the inerts.
     Then that equation gets spontaneously solved, perhaps. We end up with:
        InertSet : { [G] c : t ~ Int }
        WorkList : { [W] d1 : Num t} 

   - Now we examine (d1), we observe that there is a binding for (Num t) in the evidence binds and 
     we set: 
             d1 := d2 
     and end up in a loop!

Now, the constraints that get kicked out from the inert set are always Canonical, so by restricting
the use of the pre-canonicalizer to NonCanonical constraints we eliminate this danger. Moreover, for 
canonical constraints we already have good caching mechanisms (effectively the interaction solver) 
and we are interested in reducing things like superclasses of the same non-canonical constraint being 
generated hence I don't expect us to lose a lot by introducing the (isCNonCanonical) restriction.

A similar situation can arise in TcSimplify, at the end of the solve_wanteds function, where constraints
from the inert set are returned as new work -- our substCt ensures however that if they are not rewritten
by subst, they remain canonical and hence we will not attempt to solve them from the EvBinds. If on the 
other hand they did get rewritten and are now non-canonical they will still not match the EvBinds, so we 
are again good.
159

160
161


162
\begin{code}
163

164
165
166
167
168
169
-- Top-level canonicalization
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

canonicalize :: Ct -> TcS StopOrContinue
canonicalize ct@(CNonCanonical { cc_id = ev, cc_flavor = fl, cc_depth  = d })
  = do { traceTcS "canonicalize (non-canonical)" (ppr ct)
170
171
       ; {-# SCC "canEvVar" #-}
         canEvVar ev (classifyPredType (evVarPred ev)) d fl }
172
173
174
175
176

canonicalize (CDictCan { cc_id = ev, cc_depth = d
                       , cc_flavor = fl
                       , cc_class  = cls
                       , cc_tyargs = xis })
177
178
  = {-# SCC "canClass" #-}
    canClass d fl ev cls xis -- Do not add any superclasses
179
180
181
182
canonicalize (CTyEqCan { cc_id = ev, cc_depth = d
                       , cc_flavor = fl
                       , cc_tyvar  = tv
                       , cc_rhs    = xi })
183
184
  = {-# SCC "canEqLeafTyVarLeftRec" #-}
    canEqLeafTyVarLeftRec d fl ev tv xi
185
186
187
188
189
190

canonicalize (CFunEqCan { cc_id = ev, cc_depth = d
                        , cc_flavor = fl
                        , cc_fun    = fn
                        , cc_tyargs = xis1
                        , cc_rhs    = xi2 })
191
192
  = {-# SCC "canEqLeafFunEqLeftRec" #-}
    canEqLeafFunEqLeftRec d fl ev (fn,xis1) xi2
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

canonicalize (CIPCan { cc_id = ev, cc_depth = d
                     , cc_flavor = fl
                     , cc_ip_nm  = nm
                     , cc_ip_ty  = xi })
  = canIP d fl ev nm xi
canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl
                          , cc_depth = d
                          , cc_ty = xi })
  = canIrred d fl ev xi


canEvVar :: EvVar -> PredTree 
         -> SubGoalDepth -> CtFlavor -> TcS StopOrContinue
canEvVar ev pred_classifier d fl 
  = case pred_classifier of
      ClassPred cls tys -> canClass d fl ev cls tys 
                                        `andWhenContinue` emit_superclasses
      EqPred ty1 ty2    -> canEq    d fl ev ty1 ty2
      IPPred nm ty      -> canIP    d fl ev nm ty
      IrredPred ev_ty   -> canIrred d fl ev ev_ty
      TuplePred tys     -> canTuple d fl ev tys
  where emit_superclasses ct@(CDictCan {cc_id = v_new
                                       , cc_tyargs = xis_new, cc_class = cls })
            -- Add superclasses of this one here, See Note [Adding superclasses]. 
            -- But only if we are not simplifying the LHS of a rule. 
          = do { sctxt <- getTcSContext
               ; unless (simplEqsOnly sctxt) $ 
                        newSCWorkFromFlavored d v_new fl cls xis_new
               ; continueWith ct }
        emit_superclasses _ = panic "emit_superclasses of non-class!"


-- Tuple canonicalisation
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
canTuple :: SubGoalDepth -- Depth 
         -> CtFlavor -> EvVar -> [PredType] -> TcS StopOrContinue
canTuple d fl ev tys
  = do { traceTcS "can_pred" (text "TuplePred!") 
       ; evs <- zipWithM can_pred_tup_one tys [0..]
233
234
235
236
       ; if (isWanted fl) then 
             do {_unused_fl <- setEvBind ev (EvTupleMk evs) fl
                ; return Stop }
         else return Stop }
237
238
239
  where 
     can_pred_tup_one ty n
          = do { evc <- newEvVar fl ty
240
241
242
243
244
245
               ; let ev' = evc_the_evvar evc
               ; fl' <- if isGivenOrSolved fl then 
                            setEvBind ev' (EvTupleSel ev n) fl
                        else return fl
               ; when (isNewEvVar evc) $
                      addToWork (canEvVar ev' (classifyPredType (evVarPred ev')) d fl')
246
247
248
249
250
251
252
253
254
255
256
257
               ; return ev' }

-- Implicit Parameter Canonicalization
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
canIP :: SubGoalDepth -- Depth 
      -> CtFlavor -> EvVar 
      -> IPName Name -> Type -> TcS StopOrContinue
-- Precondition: EvVar is implicit parameter evidence
canIP d fl v nm ty
  =    -- Note [Canonical implicit parameter constraints] explains why it's 
       -- possible in principle to not flatten, but since flattening applies 
       -- the inert substitution we choose to flatten anyway.
258
    do { (xi,co) <- flatten d fl (mkIPPred nm ty)
259
       ; let no_flattening = isTcReflCo co 
260
       ; if no_flattening then
261
262
263
264
            let IPPred _ xi_in = classifyPredType xi 
            in continueWith $ CIPCan { cc_id = v, cc_flavor = fl
                                     , cc_ip_nm = nm, cc_ip_ty = xi_in
                                     , cc_depth = d }
265
266
267
         else do { evc <- newEvVar fl xi
                 ; let v_new          = evc_the_evvar evc
                       IPPred _ ip_xi = classifyPredType xi
268
269
                 ; fl_new <- case fl of 
                               Wanted {}  -> setEvBind v (EvCast v_new co) fl 
270
                               Given {}   -> setEvBind v_new (EvCast v (mkTcSymCo co)) fl
271
                               Derived {} -> return fl
272
273
                 ; if isNewEvVar evc then
                       continueWith $ CIPCan { cc_id     = v_new
274
                                             , cc_flavor = fl_new, cc_ip_nm = nm
275
276
277
278
                                             , cc_ip_ty  = ip_xi
                                             , cc_depth  = d }
                   else return Stop } }
\end{code}
279

280
281
282
283
284
285
286
287
288
289
290
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}
291

292
293
294
295
296
297
298
299
300
301
-- Class Canonicalization
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

canClass :: SubGoalDepth -- Depth
         -> CtFlavor -> EvVar  
         -> Class -> [Type] -> TcS StopOrContinue
-- Precondition: EvVar is class evidence 
-- Note: Does NOT add superclasses, but the /caller/ is responsible for adding them!
canClass d fl v cls tys
  = do { -- sctx <- getTcSContext
302
       ; (xis, cos) <- flattenMany d fl tys
303
       ; let co = mkTcTyConAppCo (classTyCon cls) cos 
304
305
             xi = mkClassPred cls xis

306
       ; let no_flattening = all isTcReflCo cos
307
                  -- No flattening, continue with canonical
308
       ; if no_flattening then 
309
310
311
312
313
314
             continueWith $ CDictCan { cc_id = v, cc_flavor = fl
                                     , cc_tyargs = xis, cc_class = cls
                                     , cc_depth = d }
                   -- Flattening happened
         else do { evc <- newEvVar fl xi
                 ; let v_new = evc_the_evvar evc
315
316
                 ; fl_new <- case fl of
                     Wanted  {} -> setEvBind v (EvCast v_new co) fl
317
                     Given   {} -> setEvBind v_new (EvCast v (mkTcSymCo co)) fl
318
                     Derived {} -> return fl
319
320
                    -- Continue only if flat constraint is new
                 ; if isNewEvVar evc then
321
                        continueWith $ CDictCan { cc_id = v_new, cc_flavor = fl_new
322
323
324
                                                , cc_tyargs = xis, cc_class = cls
                                                , cc_depth  = d }
                   else return Stop } }
325
326
327
328
329
330
331
332
333
334
335
336
337
338
\end{code}

Note [Adding superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~ 
Since dictionaries are canonicalized only once in their lifetime, the
place to add their superclasses is canonicalisation (The alternative
would be to do it during constraint solving, but we'd have to be
extremely careful to not repeatedly introduced the same superclass in
our worklist). Here is what we do:

For Givens: 
       We add all their superclasses as Givens. 

For Wanteds: 
339
340
       Generally speaking we want to be able to add superclasses of 
       wanteds for two reasons:
341

342
343
344
345
346
347
348
349
350
       (1) Oportunities for improvement. Example: 
                  class (a ~ b) => C a b 
           Wanted constraint is: C alpha beta 
           We'd like to simply have C alpha alpha. Similar 
           situations arise in relation to functional dependencies. 
           
       (2) To have minimal constraints to quantify over: 
           For instance, if our wanted constraint is (Eq a, Ord a) 
           we'd only like to quantify over Ord a. 
351

352
353
354
355
356
357
358
359
360
361
362
363
       To deal with (1) above we only add the superclasses of wanteds
       which may lead to improvement, that is: equality superclasses or 
       superclasses with functional dependencies. 

       We deal with (2) completely independently in TcSimplify. See 
       Note [Minimize by SuperClasses] in TcSimplify. 


       Moreover, in all cases the extra improvement constraints are 
       Derived. Derived constraints have an identity (for now), but 
       we don't do anything with their evidence. For instance they 
       are never used to rewrite other constraints. 
364

365
       See also [New Wanted Superclass Work] in TcInteract. 
366

367
368
369

For Deriveds: 
       We do nothing.
370
371
372

Here's an example that demonstrates why we chose to NOT add
superclasses during simplification: [Comes from ticket #4497]
dimitris's avatar
dimitris committed
373
 
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
   class Num (RealOf t) => Normed t
   type family RealOf x

Assume the generated wanted constraint is: 
   RealOf e ~ e, Normed e 
If we were to be adding the superclasses during simplification we'd get: 
   Num uf, Normed e, RealOf e ~ e, RealOf e ~ uf 
==> 
   e ~ uf, Num uf, Normed e, RealOf e ~ e 
==> [Spontaneous solve] 
   Num uf, Normed uf, RealOf uf ~ uf 

While looks exactly like our original constraint. If we add the superclass again we'd loop. 
By adding superclasses definitely only once, during canonicalisation, this situation can't 
happen.

\begin{code}
391

392
393
newSCWorkFromFlavored :: SubGoalDepth -- Depth
                      -> EvVar -> CtFlavor -> Class -> [Xi] -> TcS ()
394
-- Returns superclasses, see Note [Adding superclasses]
395
newSCWorkFromFlavored d ev flavor cls xis 
batterseapower's avatar
batterseapower committed
396
  | isDerived flavor 
397
398
  = return ()  -- Deriveds don't yield more superclasses because we will
               -- add them transitively in the case of wanteds. 
399

batterseapower's avatar
batterseapower committed
400
  | Just gk <- isGiven_maybe flavor 
dimitris's avatar
dimitris committed
401
402
  = case gk of 
      GivenOrig -> do { let sc_theta = immSuperClasses cls xis 
403
404
405
                      ; sc_vars <- mapM (newEvVar flavor) sc_theta
                      ; sc_cts <- zipWithM (\scv ev_trm -> 
                                                do { let sc_evvar = evc_the_evvar scv
406
407
                                                   ; _unused_fl <- setEvBind sc_evvar ev_trm flavor
                                                      -- unused because it's the same
408
409
410
411
412
413
414
415
416
                                                   ; return $ 
                                                     CNonCanonical { cc_id = sc_evvar
                                                                   , cc_flavor = flavor
                                                                   , cc_depth = d }}) 
                                           sc_vars [EvSuperClass ev n | n <- [0..]]
                        -- Emit now, canonicalize later in a lazier fashion
                      ; traceTcS "newSCWorkFromFlavored" $
                                 text "Emitting superclass work:" <+> ppr sc_cts
                      ; updWorkListTcS $ appendWorkListCt sc_cts }
417
      GivenSolved {} -> return ()
dimitris's avatar
dimitris committed
418
419
420
421
      -- Seems very dangerous to add the superclasses for dictionaries that may be 
      -- partially solved because we may end up with evidence loops.

  | isEmptyVarSet (tyVarsOfTypes xis)
422
423
  = return () -- Wanteds with no variables yield no deriveds.
              -- See Note [Improvement from Ground Wanteds]
424
425
426
427

  | otherwise -- Wanted case, just add those SC that can lead to improvement. 
  = do { let sc_rec_theta = transSuperClasses cls xis 
             impr_theta   = filter is_improvement_pty sc_rec_theta 
batterseapower's avatar
batterseapower committed
428
             Wanted wloc  = flavor
429
430
431
432
433
434
435
436
437
438
       ; sc_cts <- mapM (\pty -> do { scv <- newEvVar (Derived wloc) pty
                                    ; if isNewEvVar scv then 
                                          return [ CNonCanonical { cc_id = evc_the_evvar scv
                                                                 , cc_flavor = Derived wloc
                                                                 , cc_depth = d } ]  
                                      else return [] }
                        ) impr_theta
       ; let sc_cts_flat = concat sc_cts
       ; traceTcS "newSCWorkFromFlavored" (text "Emitting superclass work:" <+> ppr sc_cts_flat)
       ; updWorkListTcS $ appendWorkListCt sc_cts_flat }
439
440
441

is_improvement_pty :: PredType -> Bool 
-- Either it's an equality, or has some functional dependency
442
is_improvement_pty ty = go (classifyPredType ty)
batterseapower's avatar
batterseapower committed
443
444
  where
    go (EqPred {})         = True 
445
446
    go (ClassPred cls _tys) = not $ null fundeps
      where (_,fundeps) = classTvsFds cls
batterseapower's avatar
batterseapower committed
447
    go (IPPred {})         = False
448
    go (TuplePred ts)      = any is_improvement_pty ts
batterseapower's avatar
batterseapower committed
449
    go (IrredPred {})      = True -- Might have equalities after reduction?
450
\end{code}
451
452
453



454
455
456
457
458
459
460
461
\begin{code}
-- Irreducibles canonicalization
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
canIrred :: SubGoalDepth -- Depth
         -> CtFlavor -> EvVar -> TcType -> TcS StopOrContinue
-- Precondition: ty not a tuple and no other evidence form
canIrred d fl v ty 
  = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) 
462
463
464
       ; (xi,co) <- flatten d fl ty -- co :: xi ~ ty
       ; let no_flattening = xi `eqType` ty 
                             -- In this particular case it is not safe to 
465
                             -- say 'isTcReflCo' because the new constraint may
466
                             -- be reducible!
467
468
469
470
471
472
473
474
475
       ; if no_flattening then
            continueWith $ CIrredEvCan { cc_id = v, cc_flavor = fl
                                       , cc_ty = xi, cc_depth  = d }
         else do
      {   -- Flattening consults and applies family equations from the
          -- inerts, so 'xi' may become reducible. So just recursively
          -- canonicalise the resulting evidence variable
        evc <- newEvVar fl xi
      ; let v' = evc_the_evvar evc
476
477
      ; fl' <- case fl of 
          Wanted  {} -> setEvBind v (EvCast v' co) fl
478
          Given   {} -> setEvBind v' (EvCast v (mkTcSymCo co)) fl
479
          Derived {} -> return fl
480
481
      
      ; if isNewEvVar evc then 
482
            canEvVar v' (classifyPredType (evVarPred v')) d fl'
483
484
485
        else
            return Stop }
      }
486

487
\end{code}
488

489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
%************************************************************************
%*                                                                      *
%*        Flattening (eliminating all function symbols)                 *
%*                                                                      *
%************************************************************************

Note [Flattening]
~~~~~~~~~~~~~~~~~~~~
  flatten ty  ==>   (xi, cc)
    where
      xi has no type functions
      cc = Auxiliary given (equality) constraints constraining
           the fresh type variables in xi.  Evidence for these 
           is always the identity coercion, because internally the
           fresh flattening skolem variables are actually identified
           with the types they have been generated to stand in for.

Note that it is flatten's job to flatten *every type function it sees*.
flatten is only called on *arguments* to type functions, by canEqGiven.

Recall that in comments we use alpha[flat = ty] to represent a
flattening skolem variable alpha which has been generated to stand in
for ty.

----- Example of flattening a constraint: ------
  flatten (List (F (G Int)))  ==>  (xi, cc)
    where
      xi  = List alpha
      cc  = { G Int ~ beta[flat = G Int],
              F beta ~ alpha[flat = F beta] }
Here
  * alpha and beta are 'flattening skolem variables'.
  * All the constraints in cc are 'given', and all their coercion terms 
    are the identity.

NB: Flattening Skolems only occur in canonical constraints, which
are never zonked, so we don't need to worry about zonking doing
accidental unflattening.

Note that we prefer to leave type synonyms unexpanded when possible,
so when the flattener encounters one, it first asks whether its
transitive expansion contains any type function applications.  If so,
it expands the synonym and proceeds; if not, it simply returns the
unexpanded synonym.

\begin{code}

-- Flatten a bunch of types all at once.
flattenMany :: SubGoalDepth -- Depth
538
            -> CtFlavor -> [Type] -> TcS ([Xi], [TcCoercion])
539
-- Coercions :: Xi ~ Type 
540
-- Returns True iff (no flattening happened)
541
flattenMany d ctxt tys 
542
543
  = -- pprTrace "flattenMany" empty $
    go tys 
544
545
546
547
  where go []       = return ([],[])
        go (ty:tys) = do { (xi,co)    <- flatten d ctxt ty
                         ; (xis,cos)  <- go tys
                         ; return (xi:xis,co:cos) }
548
549
550
551
552

-- Flatten a type to get rid of type function applications, returning
-- the new type-function-free type, and a collection of new equality
-- constraints.  See Note [Flattening] for more detail.
flatten :: SubGoalDepth -- Depth
553
        -> CtFlavor -> TcType -> TcS (Xi, TcCoercion)
554
555
556
-- Postcondition: Coercion :: Xi ~ TcType
flatten d ctxt ty 
  | Just ty' <- tcView ty
557
558
559
  = do { (xi, co) <- flatten d ctxt ty'
       ; return (xi,co) }
	
560
       -- DV: The following is tedious to do but maybe we should return to this
561
562
       -- Preserve type synonyms if possible
       -- ; if no_flattening
563
       --   then return (xi, mkTcReflCo xi,no_flattening) -- Importantly, not xi!
564
565
       --   else return (xi,co,no_flattening) 
       -- }
566

567
flatten d ctxt v@(TyVarTy _)
568
  = do { ieqs <- getInertEqs
569
       ; let co = liftInertEqsTy ieqs ctxt v           -- co : v ~ ty
570
             ty = pSnd (tcCoercionKind co)
571
       ; if v `eqType` ty then
572
             return (ty,mkTcReflCo ty)
573
574
575
576
         else -- NB recursive call. Why? See Note [Non-idempotent inert substitution]
              -- Actually I believe that applying the substition only *twice* will suffice
         
             do { (ty_final,co') <- flatten d ctxt ty  -- co' : ty_final ~ ty
577
                ; return (ty_final,co' `mkTcTransCo` mkTcSymCo co) } }
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610

\end{code}

Note [Non-idempotent inert substitution]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The inert substitution is not idempotent in the broad sense. It is only idempotent in 
that it cannot rewrite the RHS of other inert equalities any further. An example of such 
an inert substitution is:

 [Ś] g1 : ta8 ~ ta4
 [W] g2 : ta4 ~ a5Fj

Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on
an RHS of an equality. Now, imagine a constraint:

 [W] g3: ta8 ~ Int 

coming in. If we simply apply once the inert substitution we will get: 

 [W] g3_1: ta4 ~ Int 

and because potentially ta4 is untouchable we will try to insert g3_1 in the inert set, 
getting a panic since the inert only allows ONE equation per LHS type variable (as it 
should).

For this reason, when we reach to flatten a type variable, we flatten it recursively, 
so that we can make sure that the inert substitution /is/ fully applied.

This insufficient rewriting was the reason for #5668.

\begin{code}

611
612

flatten d ctxt (AppTy ty1 ty2)
613
614
  = do { (xi1,co1) <- flatten d ctxt ty1
       ; (xi2,co2) <- flatten d ctxt ty2
615
       ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) }
616
617

flatten d ctxt (FunTy ty1 ty2)
618
619
  = do { (xi1,co1) <- flatten d ctxt ty1
       ; (xi2,co2) <- flatten d ctxt ty2
620
       ; return (mkFunTy xi1 xi2, mkTcFunCo co1 co2) }
621
622
623
624
625

flatten d fl (TyConApp tc tys)
  -- For a normal type constructor or data family application, we just
  -- recursively flatten the arguments.
  | not (isSynFamilyTyCon tc)
626
    = do { (xis,cos) <- flattenMany d fl tys
627
         ; return (mkTyConApp tc xis, mkTcTyConAppCo tc cos) }
628
629
630
631
632
633

  -- Otherwise, it's a type function application, and we have to
  -- flatten it away as well, and generate a new given equality constraint
  -- between the application and a newly generated flattening skolem variable.
  | otherwise
  = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
634
      do { (xis, cos) <- flattenMany d fl tys
635
636
637
638
639
         ; let (xi_args, xi_rest)  = splitAt (tyConArity tc) xis
	       	 -- The type function might be *over* saturated
		 -- in which case the remaining arguments should
		 -- be dealt with by AppTys
               fam_ty = mkTyConApp tc xi_args
640
         ; (ret_co, rhs_xi, ct) <-
641
642
             do { is_cached <- getCachedFlatEq tc xi_args fl Any
                ; case is_cached of
643
                    Just (rhs_xi,ret_eq) -> 
644
                        do { traceTcS "is_cached!" $ ppr ret_eq
645
                           ; return (ret_eq, rhs_xi, []) }
646
647
                    Nothing
                        | isGivenOrSolved fl ->
648
                            do { rhs_xi_var <- newFlattenSkolemTy fam_ty
649
                               ; (fl',eqv) 
650
                                   <- newGivenEqVar fl fam_ty rhs_xi_var (mkTcReflCo fam_ty)
651
                               ; let ct  = CFunEqCan { cc_id     = eqv
652
                                                     , cc_flavor = fl' -- Given
653
654
                                                     , cc_fun    = tc 
                                                     , cc_tyargs = xi_args 
655
                                                     , cc_rhs    = rhs_xi_var 
656
657
                                                     , cc_depth  = d }
                                           -- Update the flat cache: just an optimisation!
658
                               ; updateFlatCache eqv fl' tc xi_args rhs_xi_var WhileFlattening
659
                               ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) }
660
661
                        | otherwise ->
                    -- Derived or Wanted: make a new /unification/ flatten variable
662
                            do { rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
663
                               ; let wanted_flavor = mkWantedFlavor fl
664
                               ; evc <- newEqVar wanted_flavor fam_ty rhs_xi_var
665
666
667
668
669
670
                               ; let eqv = evc_the_evvar evc -- Not going to be cached
                                     ct = CFunEqCan { cc_id = eqv
                                                    , cc_flavor = wanted_flavor
                                                    -- Always Wanted, not Derived
                                                    , cc_fun = tc
                                                    , cc_tyargs = xi_args
671
                                                    , cc_rhs    = rhs_xi_var 
672
673
                                                    , cc_depth  = d }
                                          -- Update the flat cache: just an optimisation!
674
                               ; updateFlatCache eqv fl tc xi_args rhs_xi_var WhileFlattening
675
                               ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } }
676
677
678
679
680

           -- Emit the flat constraints
         ; updWorkListTcS $ appendWorkListEqs ct

         ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos
681
682
         ; return ( mkAppTys rhs_xi xi_rest    -- NB mkAppTys: rhs_xi might not be a type variable
	   	    	     	    	       --    cf Trac #5655
683
684
                  , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo tc cos_args)
                               cos_rest
685
                  ) }
686
687
688
689
690
691
692


flatten d ctxt ty@(ForAllTy {})
-- We allow for-alls when, but only when, no type function
-- applications inside the forall involve the bound type variables.
  = do { let (tvs, rho) = splitForAllTys ty
       ; when (under_families tvs rho) $ flattenForAllErrorTcS ctxt ty
693
       ; (rho', co) <- flatten d ctxt rho
694
       ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710

  where under_families tvs rho 
            = go (mkVarSet tvs) rho 
            where go _bound (TyVarTy _tv) = False
                  go bound (TyConApp tc tys)
                      | isSynFamilyTyCon tc
                      , (args,rest) <- splitAt (tyConArity tc) tys
                      = (tyVarsOfTypes args `intersectsVarSet` bound) || any (go bound) rest
                      | otherwise = any (go bound) tys
                  go bound (FunTy arg res)  = go bound arg || go bound res
                  go bound (AppTy fun arg)  = go bound fun || go bound arg
                  go bound (ForAllTy tv ty) = go (bound `extendVarSet` tv) ty


getCachedFlatEq :: TyCon -> [Xi] -> CtFlavor 
                -> FlatEqOrigin
711
                -> TcS (Maybe (Xi, TcCoercion))
712
713
714
715
716
717
718
719
-- Returns a coercion between (TyConApp tc xi_args ~ xi) if such an inert item exists
-- But also applies the substitution to the item via calling flatten recursively
getCachedFlatEq tc xi_args fl feq_origin
  = do { let pty = mkTyConApp tc xi_args
       ; traceTcS "getCachedFlatEq" $ ppr (mkTyConApp tc xi_args)
       ; flat_cache <- getTcSEvVarFlatCache
       ; inerts <- getTcSInerts
       ; case lookupFunEq pty fl (inert_funeqs inerts) of
dimitris's avatar
dimitris committed
720
721
722
           Nothing 
               -> lookup_in_flat_cache pty flat_cache
           res -> return res }
723
724
725
726
727
728
  where lookup_in_flat_cache pty flat_cache 
          = case lookupTM pty flat_cache of
              Just (co',(xi',fl',when_generated)) -- ev' :: (TyConApp tc xi_args) ~ xi'
               | fl' `canRewrite` fl
               , feq_origin `origin_matches` when_generated
               -> do { traceTcS "getCachedFlatEq" $ text "success!"
729
                     ; (xi'',co) <- flatten 0 fl' xi' -- co :: xi'' ~ xi'
dimitris's avatar
dimitris committed
730
731
732
                                    -- The only purpose of this flattening is to apply the
                                    -- inert substitution (since everything in the flat cache
                                    -- by construction will have a family-free RHS.
733
                     ; return $ Just (xi'', co' `mkTcTransCo` (mkTcSymCo co)) }
734
735
736
737
738
739
740
741
742
743
              _ -> do { traceTcS "getCachedFlatEq" $ text "failure!" <+> pprEvVarCache flat_cache
                      ; return Nothing }

-----------------
addToWork :: TcS StopOrContinue -> TcS ()
addToWork tcs_action = tcs_action >>= stop_or_emit
  where stop_or_emit Stop              = return ()
        stop_or_emit (ContinueWith ct) = updWorkListTcS $ 
                                         extendWorkListCt ct

744
745
canEqEvVarsCreated :: SubGoalDepth 
                   -> [CtFlavor] -> [EvVarCreated] -> [Type] -> [Type]
746
747
                   -> TcS StopOrContinue
canEqEvVarsCreated _d _fl [] _ _    = return Stop
748
canEqEvVarsCreated d (fl:fls) (evc:evcs) (ty1:tys1) (ty2:tys2) 
749
750
751
752
753
754
755
756
  | isNewEvVar evc 
  = let do_one evc0 sy1 sy2
          | isNewEvVar evc0 
          = canEq_ d fl (evc_the_evvar evc0) sy1 sy2
          | otherwise = return ()
    in do { _unused <- zipWith3M do_one evcs tys1 tys2 
          ; canEq d fl (evc_the_evvar evc) ty1 ty2 }
  | otherwise 
757
  = canEqEvVarsCreated d fls evcs tys1 tys2
758
759
760
761
762
763
764
765
766
767
canEqEvVarsCreated _ _ _ _ _ = return Stop


canEq_ :: SubGoalDepth 
       -> CtFlavor -> EqVar -> Type -> Type -> TcS ()
canEq_ d fl eqv ty1 ty2 = addToWork (canEq d fl eqv ty1 ty2)

canEq :: SubGoalDepth 
      -> CtFlavor -> EqVar -> Type -> Type -> TcS StopOrContinue
canEq _d fl eqv ty1 ty2
768
  | eqType ty1 ty2	-- Dealing with equality here avoids
769
    	     	 	-- later spurious occurs checks for a~a
770
  = do { when (isWanted fl) $ 
771
              do { _ <- setEqBind eqv (mkTcReflCo ty1) fl; return () }
772
       ; return Stop }
773

774
775
776
777
778
779
-- Split up an equality between function types into two equalities.
canEq d fl eqv (FunTy s1 t1) (FunTy s2 t2)
  = do { argeqv <- newEqVar fl s1 s2
       ; reseqv <- newEqVar fl t1 t2
       ; let argeqv_v = evc_the_evvar argeqv
             reseqv_v = evc_the_evvar reseqv
780
       ; (fl1,fl2) <- case fl of
781
           Wanted {} ->
782
               do { _ <- setEqBind eqv (mkTcFunCo (mkTcCoVarCo argeqv_v) (mkTcCoVarCo reseqv_v)) fl
783
                  ; return (fl,fl) }
784
           Given {} ->
785
786
               do { fl1 <- setEqBind argeqv_v (mkTcNthCo 0 (mkTcCoVarCo eqv)) fl
                  ; fl2 <- setEqBind reseqv_v (mkTcNthCo 1 (mkTcCoVarCo eqv)) fl 
787
788
                  ; return (fl1,fl2)
                  }
789
           Derived {} ->
790
               return (fl,fl)
791

792
       ; canEqEvVarsCreated d [fl2,fl1] [reseqv,argeqv] [t1,s1] [t2,s2] }
793
794

-- If one side is a variable, orient and flatten,
795
-- WITHOUT expanding type synonyms, so that we tend to 
796
-- substitute a ~ Age rather than a ~ Int when @type Age = Int@
797
798
799
800
canEq d fl eqv ty1@(TyVarTy {}) ty2 
  = canEqLeaf d fl eqv ty1 ty2
canEq d fl eqv ty1 ty2@(TyVarTy {})
  = canEqLeaf d fl eqv ty1 ty2
801

802
canEq d fl eqv ty1@(TyConApp fn tys) ty2 
803
  | isSynFamilyTyCon fn, length tys == tyConArity fn
804
805
  = canEqLeaf d fl eqv ty1 ty2
canEq d fl eqv ty1 ty2@(TyConApp fn tys)
806
  | isSynFamilyTyCon fn, length tys == tyConArity fn
807
  = canEqLeaf d fl eqv ty1 ty2
808

809
canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
810
  | isDecomposableTyCon tc1 && isDecomposableTyCon tc2
811
812
813
  , tc1 == tc2
  , length tys1 == length tys2
  = -- Generate equalities for each of the corresponding arguments
814
815
    do { let (kis1,  tys1') = span isKind tys1
             (_kis2, tys2') = span isKind tys2
816
       ; let kicos = map mkTcReflCo kis1
817
818

       ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2'
819
       ; fls <- case fl of 
820
           Wanted {} -> 
821
             do { _ <- setEqBind eqv
822
                         (mkTcTyConAppCo tc1 (kicos ++ map (mkTcCoVarCo . evc_the_evvar) argeqvs)) fl
823
                ; return (map (\_ -> fl) argeqvs) }
824
825
           Given {} ->
             let do_one argeqv n = setEqBind (evc_the_evvar argeqv) 
826
                                             (mkTcNthCo n (mkTcCoVarCo eqv)) fl
827
828
             in zipWithM do_one argeqvs [(length kicos)..]
           Derived {} -> return (map (\_ -> fl) argeqvs)
829

830
       ; canEqEvVarsCreated d fls argeqvs tys1' tys2' }
831
832
833

-- See Note [Equality between type applications]
--     Note [Care with type applications] in TcUnify
834
canEq d fl eqv ty1 ty2
835
836
837
  | Nothing <- tcView ty1  -- Naked applications ONLY
  , Nothing <- tcView ty2  -- See Note [Naked given applications]
  , Just (s1,t1) <- tcSplitAppTy_maybe ty1
838
  , Just (s2,t2) <- tcSplitAppTy_maybe ty2
839
840
841
  = ASSERT( not (isKind t1) && not (isKind t2) )
    if isGivenOrSolved fl then 
        do { traceTcS "canEq/(app case)" $
842
                text "Ommitting decomposition of given equality between: " 
843
844
845
846
847
848
849
850
851
852
853
                    <+> ppr ty1 <+> text "and" <+> ppr ty2
                   -- We cannot decompose given applications
                   -- because we no longer have 'left' and 'right'
           ; return Stop }
    else
        do { evc1 <- newEqVar fl s1 s2
           ; evc2 <- newEqVar fl t1 t2
           ; let eqv1 = evc_the_evvar evc1
                 eqv2 = evc_the_evvar evc2
 
           ; when (isWanted fl) $
854
                  do { _ <- setEqBind eqv (mkTcAppCo (mkTcCoVarCo eqv1) (mkTcCoVarCo eqv2)) fl
855
                     ; return () }
856
           
857
           ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] }
858

859

860
canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {})
861
862
 | tcIsForAllTy s1, tcIsForAllTy s2, 
   Wanted {} <- fl 
863
 = canEqFailure d fl eqv
864
 | otherwise
865
 = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2)
866
      ; return Stop }
867
868

-- Finally expand any type synonym applications.
869
870
871
canEq d fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2
canEq d fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2'
canEq d fl eqv _ _                               = canEqFailure d fl eqv
872

873
874
875
canEqFailure :: SubGoalDepth 
             -> CtFlavor -> EvVar -> TcS StopOrContinue
canEqFailure d fl eqv = do { emitFrozenError fl eqv d; return Stop }
876
877
\end{code}

878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
Note [Naked given applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider: 
   data A a 
   type T a = A a 
and the given equality:  
   [G] A a ~ T Int 
We will reach the case canEq where we do a tcSplitAppTy_maybe, but if
we dont have the guards (Nothing <- tcView ty1) (Nothing <- tcView
ty2) then the given equation is going to fall through and get
completely forgotten!

What we want instead is this clause to apply only when there is no
immediate top-level synonym; if there is one it will be later on
unfolded by the later stages of canEq.

Test-case is in typecheck/should_compile/GivenTypeSynonym.hs


897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
Note [Equality between type applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we see an equality of the form s1 t1 ~ s2 t2 we can always split
it up into s1 ~ s2 /\ t1 ~ t2, since s1 and s2 can't be type
functions (type functions use the TyConApp constructor, which never
shows up as the LHS of an AppTy).  Other than type functions, types
in Haskell are always 

  (1) generative: a b ~ c d implies a ~ c, since different type
      constructors always generate distinct types

  (2) injective: a b ~ a d implies b ~ d; we never generate the
      same type from different type arguments.


Note [Canonical ordering for equality constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Implemented as (<+=) below:

  - Type function applications always come before anything else.  
  - Variables always come before non-variables (other than type
      function applications).

Note that we don't need to unfold type synonyms on the RHS to check
the ordering; that is, in the rules above it's OK to consider only
whether something is *syntactically* a type function application or
not.  To illustrate why this is OK, suppose we have an equality of the
form 'tv ~ S a b c', where S is a type synonym which expands to a
top-level application of the type function F, something like

  type S a b c = F d e

Then to canonicalize 'tv ~ S a b c' we flatten the RHS, and since S's
expansion contains type function applications the flattener will do
the expansion and then generate a skolem variable for the type
function application, so we end up with something like this:

  tv ~ x
  F d e ~ x

where x is the skolem variable.  This is one extra equation than
absolutely necessary (we could have gotten away with just 'F d e ~ tv'
if we had noticed that S expanded to a top-level type function
application and flipped it around in the first place) but this way
keeps the code simpler.

Unlike the OutsideIn(X) draft of May 7, 2010, we do not care about the
ordering of tv ~ tv constraints.  There are several reasons why we
might:

  (1) In order to be able to extract a substitution that doesn't
      mention untouchable variables after we are done solving, we might
      prefer to put touchable variables on the left. However, in and
      of itself this isn't necessary; we can always re-orient equality
      constraints at the end if necessary when extracting a substitution.

  (2) To ensure termination we might think it necessary to put
      variables in lexicographic order. However, this isn't actually 
      necessary as outlined below.

While building up an inert set of canonical constraints, we maintain
the invariant that the equality constraints in the inert set form an
acyclic rewrite system when viewed as L-R rewrite rules.  Moreover,
the given constraints form an idempotent substitution (i.e. none of
the variables on the LHS occur in any of the RHS's, and type functions
never show up in the RHS at all), the wanted constraints also form an
idempotent substitution, and finally the LHS of a given constraint
never shows up on the RHS of a wanted constraint.  There may, however,
be a wanted LHS that shows up in a given RHS, since we do not rewrite
given constraints with wanted constraints.

Suppose we have an inert constraint set


  tg_1 ~ xig_1         -- givens
  tg_2 ~ xig_2
  ...
  tw_1 ~ xiw_1         -- wanteds
  tw_2 ~ xiw_2
  ...

where each t_i can be either a type variable or a type function
application. Now suppose we take a new canonical equality constraint,
t' ~ xi' (note among other things this means t' does not occur in xi')
and try to react it with the existing inert set.  We show by induction
on the number of t_i which occur in t' ~ xi' that this process will
terminate.

There are several ways t' ~ xi' could react with an existing constraint:

TODO: finish this proof.  The below was for the case where the entire
inert set is an idempotent subustitution...

(b) We could have t' = t_j for some j.  Then we obtain the new
    equality xi_j ~ xi'; note that neither xi_j or xi' contain t_j.  We
    now canonicalize the new equality, which may involve decomposing it
    into several canonical equalities, and recurse on these.  However,
    none of the new equalities will contain t_j, so they have fewer
    occurrences of the t_i than the original equation.

(a) We could have t_j occurring in xi' for some j, with t' /=
    t_j. Then we substitute xi_j for t_j in xi' and continue.  However,
    since none of the t_i occur in xi_j, we have decreased the
    number of t_i that occur in xi', since we eliminated t_j and did not
    introduce any new ones.

\begin{code}
data TypeClassifier 
Ian Lynagh's avatar
Ian Lynagh committed
1005
  = FskCls TcTyVar      -- ^ Flatten skolem 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1006
  | VarCls TcTyVar      -- ^ Non-flatten-skolem variable 
Ian Lynagh's avatar
Ian Lynagh committed
1007
1008
  | FunCls TyCon [Type] -- ^ Type function, exactly saturated
  | OtherCls TcType     -- ^ Neither of the above
1009

1010
{- Useless these days! 
1011
unClassify :: TypeClassifier -> TcType
1012
1013
1014
1015
unClassify (VarCls tv)      = TyVarTy tv
unClassify (FskCls tv) = TyVarTy tv 
unClassify (FunCls fn tys)  = TyConApp fn tys
unClassify (OtherCls ty)    = ty
1016
-} 
1017
1018

classify :: TcType -> TypeClassifier
1019
1020
1021
1022
1023

classify (TyVarTy tv) 
  | isTcTyVar tv, 
    FlatSkol {} <- tcTyVarDetails tv = FskCls tv
  | otherwise                        = VarCls tv
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
classify (TyConApp tc tys) | isSynFamilyTyCon tc
                           , tyConArity tc == length tys
                           = FunCls tc tys
classify ty                | Just ty' <- tcView ty
	                   = case classify ty' of
                               OtherCls {} -> OtherCls ty
                               var_or_fn   -> var_or_fn
                           | otherwise 
                           = OtherCls ty

-- See note [Canonical ordering for equality constraints].
1035
reOrient :: CtFlavor -> TypeClassifier -> TypeClassifier -> Bool	
1036
1037
1038
1039
1040
-- (t1 `reOrient` t2) responds True 
--   iff we should flip to (t2~t1)
-- We try to say False if possible, to minimise evidence generation
--
-- Postcondition: After re-orienting, first arg is not OTherCls
1041
1042
1043
1044
1045
1046
1047
reOrient _fl (OtherCls {}) (FunCls {})   = True
reOrient _fl (OtherCls {}) (FskCls {})   = True
reOrient _fl (OtherCls {}) (VarCls {})   = True
reOrient _fl (OtherCls {}) (OtherCls {}) = panic "reOrient"  -- One must be Var/Fun

reOrient _fl (FunCls {})   (VarCls _tv)  = False  
  -- But consider the following variation: isGiven fl && isMetaTyVar tv
1048
1049

  -- See Note [No touchables as FunEq RHS] in TcSMonad
1050
reOrient _fl (FunCls {}) _                = False             -- Fun/Other on rhs
1051

1052
reOrient _fl (VarCls {}) (FunCls {})      = True 
1053

1054
reOrient _fl (VarCls {}) (FskCls {})      = False
1055

1056
1057
reOrient _fl (VarCls {})  (OtherCls {})   = False
reOrient _fl (VarCls tv1)  (VarCls tv2)  
1058
1059
1060
  | isMetaTyVar tv2 && not (isMetaTyVar tv1) = True 
  | otherwise                                = False 
  -- Just for efficiency, see CTyEqCan invariants 
1061

1062
reOrient _fl (FskCls {}) (VarCls tv2)     = isMetaTyVar tv2 
1063
  -- Just for efficiency, see CTyEqCan invariants
1064

1065
1066
1067
reOrient _fl (FskCls {}) (FskCls {})     = False
reOrient _fl (FskCls {}) (FunCls {})     = True 
reOrient _fl (FskCls {}) (OtherCls {})   = False 
1068
1069

------------------
1070
1071

canEqLeaf :: SubGoalDepth -- Depth
batterseapower's avatar
batterseapower committed
1072
          -> CtFlavor -> EqVar 
1073
1074
          -> Type -> Type 
          -> TcS StopOrContinue
1075
1076
1077
1078
-- Canonicalizing "leaf" equality constraints which cannot be
-- decomposed further (ie one of the types is a variable or
-- saturated type function application).  

1079
1080
1081
1082
-- Preconditions: 
--    * one of the two arguments is variable or family applications
--    * the two types are not equal (looking through synonyms)
canEqLeaf d fl eqv s1 s2 
1083
  | cls1 `re_orient` cls2
1084
  = do { traceTcS "canEqLeaf (reorienting)" $ ppr eqv <+> dcolon <+> pprEq s1 s2
1085
       ; delCachedEvVar eqv fl
1086
1087
       ; evc <- newEqVar fl s2 s1
       ; let eqv' = evc_the_evvar evc
1088
       ; fl' <- case fl of 
1089
1090
           Wanted {}  -> setEqBind eqv (mkTcSymCo (mkTcCoVarCo eqv')) fl 
           Given {}   -> setEqBind eqv' (mkTcSymCo (mkTcCoVarCo eqv)) fl 
1091
           Derived {} -> return fl 
1092
       ; if isNewEvVar evc then 
1093
             do { canEqLeafOriented d fl' eqv' s2 s1 }
1094
1095
         else return Stop 
       }
1096
  | otherwise
1097
1098
  = do { traceTcS "canEqLeaf" $ ppr (mkEqPred (s1,s2))
       ; canEqLeafOriented d fl eqv s1 s2 }
1099
  where
1100
    re_orient = reOrient fl 
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
    cls1 = classify s1
    cls2 = classify s2

canEqLeafOriented :: SubGoalDepth -- Depth
                  -> CtFlavor -> EqVar 
                  -> TcType -> TcType -> TcS StopOrContinue
-- By now s1 will either be a variable or a type family application
canEqLeafOriented d fl eqv s1 s2
  | let k1 = typeKind s1
  , let k2 = typeKind s2
  -- Establish kind invariants for CFunEqCan and CTyEqCan
dreixel's avatar
dreixel committed
1112
  = do { are_compat <- compatKindTcS k1 k2
1113
       ; can_unify <- if not are_compat
1114
                      then unifyKindTcS s1 s2 k1 k2
1115
1116
1117
                      else return False
         -- If the kinds cannot be unified or are not compatible, don't fail
         -- right away; instead, emit a frozen error
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
       ; if (not are_compat && not can_unify) then
             canEqFailure d fl eqv
         else can_eq_kinds_ok d fl eqv s1 s2 }

  where can_eq_kinds_ok d fl eqv s1 s2
          | Just (fn,tys1) <- splitTyConApp_maybe s1
          = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2
          | Just tv <- getTyVar_maybe s1
          = canEqLeafTyVarLeftRec d fl eqv tv s2
          | otherwise
          = pprPanic "canEqLeafOriented" $
            text "Non-variable or non-family equality LHS" <+> ppr eqv <+> 
                                                       dcolon <+> ppr (evVarPred eqv)
canEqLeafFunEqLeftRec :: SubGoalDepth
                      -> CtFlavor 
                      -> EqVar 
                      -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue
canEqLeafFunEqLeftRec d fl eqv (fn,tys1) ty2  -- eqv :: F tys1 ~ ty2
1136
1137
  = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2
       ; (xis1,cos1) <- 
1138
1139
1140
           {-# SCC "flattenMany" #-}
           flattenMany d fl tys1 -- Flatten type function arguments
                                 -- cos1 :: xis1 ~ tys1
1141

1142
1143
--       ; inerts <- getTcSInerts
--        ; let fam_eqs   = inert_funeqs inerts
1144

1145
1146
1147
1148
1149
1150
1151
1152
       ; let flat_ty = mkTyConApp fn xis1

       ; is_cached <- getCachedFlatEq fn xis1 fl WhenSolved
                      -- Lookup if we have solved this goal already
{-
       ; let is_cached = {-# SCC "lookupFunEq" #-} 
                         lookupFunEq flat_ty fl fam_eqs
-}
1153
       ; let no_flattening = all isTcReflCo cos1
1154
                      
1155
1156
1157
1158
1159
1160
       ; if no_flattening && isNothing is_cached then 
             canEqLeafFunEqLeft d fl eqv (fn,xis1) ty2
         else do
       { let (final_co, final_ty)
                 | no_flattening        -- Just in inerts
                 , Just (rhs_ty, ret_eq) <- is_cached
1161
                 = (mkTcSymCo ret_eq, rhs_ty)
1162
                 | Nothing <- is_cached -- Just flattening
1163
                 = (mkTcTyConAppCo fn cos1, flat_ty)
1164
                 | Just (rhs_ty, ret_eq) <- is_cached  -- Both
1165
                 = (mkTcSymCo ret_eq `mkTcTransCo` mkTcTyConAppCo fn cos1, rhs_ty)
1166
                 | otherwise = panic "No flattening and not cached!"
1167
       ; delCachedEvVar eqv fl
1168
1169
       ; evc <- newEqVar fl final_ty ty2
       ; let new_eqv = evc_the_evvar evc
1170
1171
       ; fl' <- case fl of
           Wanted {}  -> setEqBind eqv 
1172
1173
                           (mkTcSymCo final_co `mkTcTransCo` (mkTcCoVarCo new_eqv)) fl
           Given {}   -> setEqBind new_eqv (final_co `mkTcTransCo` (mkTcCoVarCo eqv)) fl
1174
           Derived {} -> return fl
1175
1176
       ; if isNewEvVar evc then
             if isNothing is_cached then
1177
1178
                 {-# SCC "canEqLeafFunEqLeft" #-}
                 canEqLeafFunEqLeft d fl' new_eqv (fn,xis1) ty2
1179
             else
1180
                 canEq (d+1) fl' new_eqv final_ty ty2
1181
1182
1183
1184
         else return Stop
       }
       }

1185
lookupFunEq :: PredType -> CtFlavor -> TypeMap Ct -> Maybe (TcType, TcCoercion)
1186
1187
1188
1189
lookupFunEq pty fl fam_eqs = lookup_funeq pty fam_eqs
  where lookup_funeq pty fam_eqs
          | Just ct <- lookupTM pty fam_eqs
          , cc_flavor ct `canRewrite` fl 
1190
          = Just (cc_rhs ct, mkTcCoVarCo (cc_id ct))
1191
1192
1193
1194
1195
1196
1197
1198
          | otherwise 
          = Nothing

canEqLeafFunEqLeft :: SubGoalDepth -- Depth
                   -> CtFlavor -> EqVar -> (TyCon,[Xi]) 
                   -> TcType -> TcS StopOrContinue
-- Precondition: No more flattening is needed for the LHS
canEqLeafFunEqLeft d fl eqv (fn,xis1) s2
1199
 = {-# SCC "canEqLeafFunEqLeft" #-}
1200
1201
   do { traceTcS "canEqLeafFunEqLeft" $ pprEq (mkTyConApp fn xis1) s2
      ; (xi2,co2) <- 
1202
1203
          {-# SCC "flatten" #-} 
          flatten d fl s2 -- co2 :: xi2 ~ s2
1204
      ; let no_flattening_happened = isTcReflCo co2
1205
1206
1207
1208
1209
1210
1211
      ; if no_flattening_happened then 
            continueWith $ CFunEqCan { cc_id     = eqv
                                     , cc_flavor = fl
                                     , cc_fun    = fn
                                     , cc_tyargs = xis1 
                                     , cc_rhs    = xi2 
                                     , cc_depth  = d }
1212
1213
1214
1215
        else do { delCachedEvVar eqv fl
                ; evc <- 
                    {-# SCC "newEqVar" #-}
                    newEqVar fl (mkTyConApp fn xis1) xi2
1216
                ; let new_eqv = evc_the_evvar evc -- F xis1 ~ xi2 
1217
1218
                      new_cv  = mkTcCoVarCo new_eqv
                      cv      = mkTcCoVarCo eqv    -- F xis1 ~ s2
1219
                ; fl' <- case fl of
1220
1221
                    Wanted {} -> setEqBind eqv (new_cv `mkTcTransCo` co2) fl 
                    Given {}  -> setEqBind new_eqv (cv `mkTcTransCo` mkTcSymCo co2) fl
1222
                    Derived {} -> return fl
1223
1224
1225
                ; if isNewEvVar evc then 
                      do { continueWith $
                           CFunEqCan { cc_id = new_eqv
1226
                                     , cc_flavor = fl'
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
                                     , cc_fun    = fn
                                     , cc_tyargs = xis1 
                                     , cc_rhs    = xi2 
                                     , cc_depth  = d } }
                  else return Stop }  }


canEqLeafTyVarLeftRec :: SubGoalDepth
                      -> CtFlavor -> EqVar
                      -> TcTyVar -> TcType -> TcS StopOrContinue
canEqLeafTyVarLeftRec d fl eqv tv s2              -- eqv :: tv ~ s2
1238
1239
  = do {  traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2
       ; (xi1,co1) <- flatten d fl (mkTyVarTy tv) -- co1 :: xi1 ~ tv
1240
       ; case isTcReflCo co1 of 
1241
1242
1243
1244
1245
1246
1247
1248
             True -- If reflco and variable, just go on
               | Just tv' <- getTyVar_maybe xi1 
                 -> canEqLeafTyVarLeft d fl eqv tv' s2
             _ -> -- If not a variable or not refl co, must rewrite and go on
               do { delCachedEvVar eqv fl
                  ; evc <- newEqVar fl xi1 s2  -- new_ev :: xi1 ~ s2
                  ; let new_ev = evc_the_evvar evc
                  ; fl' <- case fl of 
1249
                    Wanted  {} -> setEqBind eqv 
1250
                                    (mkTcSymCo co1 `mkTcTransCo` mkTcCoVarCo new_ev) fl
1251
                    Given   {} -> setEqBind new_ev
1252
                                    (co1 `mkTcTransCo` mkTcCoVarCo eqv) fl
1253
                    Derived {} -> return fl
1254
                  ; if isNewEvVar evc then
1255
                      do { canEq d fl' new_ev xi1 s2 }
1256
1257
                    else return Stop
                  }
1258
1259
1260
1261
1262
1263
1264
       }

canEqLeafTyVarLeft :: SubGoalDepth -- Depth
                   -> CtFlavor -> EqVar
                   -> TcTyVar -> TcType -> TcS StopOrContinue
-- Precondition LHS is fully rewritten from inerts (but not RHS)
canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
1265
1266
1267
  = do { traceTcS "canEqLeafTyVarLeft" (pprEq (mkTyVarTy tv) s2)
       ; (xi2, co) <- flatten d fl s2   -- Flatten RHS   co : xi2 ~ s2
                                               
1268
       ; let no_flattening_happened = isTcReflCo co
1269
             
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
       ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv  =" <+> ppr tv
                                                     , text "s2  =" <+> ppr s2
                                                     , text "xi2 =" <+> ppr xi2]))

                      -- Flattening the RHS may reveal an identity coercion, which should
                      -- not be reported as occurs check error! 
       ; let is_same_tv
               | Just tv' <- getTyVar_maybe xi2, tv' == tv
               = True
               | otherwise = False
       ; if is_same_tv then
1281
1282
1283
             do { delCachedEvVar eqv fl
                ; when (isWanted fl) $ 
                       do { _ <- setEqBind eqv co fl; return () }
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
                ; return Stop }
         else
    do { -- Do an occurs check, and return a possibly
         -- unfolded version of the RHS, if we had to 
         -- unfold any type synonyms to get rid of tv.
         occ_check_result <- canOccursCheck fl tv xi2

       ; let xi2'
              | Just xi2_unfolded <- occ_check_result
              = xi2_unfolded
              | otherwise = xi2


       ; if no_flattening_happened then
             if isNothing occ_check_result then 
1299