[project @ 2002-10-18 13:35:46 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / Inst.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
5
6 \begin{code}
7 module Inst ( 
8         LIE, emptyLIE, unitLIE, plusLIE, consLIE, 
9         plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
10         showLIE,
11
12         Inst, 
13         pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
14
15         newDictsFromOld, newDicts, cloneDict,
16         newMethod, newMethodFromName, newMethodWithGivenTy, 
17         newMethodWith, newMethodAtLoc,
18         newOverloadedLit, newIPDict, 
19         tcInstCall, tcInstDataCon, tcSyntaxName,
20
21         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
22         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
23         instLoc, getDictClassTys, dictPred,
24
25         lookupInst, lookupSimpleInst, LookupInstResult(..),
26
27         isDict, isClassDict, isMethod, 
28         isLinearInst, linearInstType, isIPDict, isInheritableInst,
29         isTyVarDict, isStdClassTyVarDict, isMethodFor, 
30         instBindingRequired, instCanBeGeneralised,
31
32         zonkInst, zonkInsts,
33         instToId, instName,
34
35         InstOrigin(..), InstLoc, pprInstLoc
36     ) where
37
38 #include "HsVersions.h"
39
40 import {-# SOURCE #-}   TcExpr( tcExpr )
41
42 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
43 import TcHsSyn  ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
44                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
45                 )
46 import TcRnMonad
47 import TcEnv    ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
48 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
49 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
50                   zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
51                 )
52 import TcType   ( Type, TcType, TcThetaType, TcTyVarSet,
53                   SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
54                   tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
55                   tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
56                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
57                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
58                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
59                   isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
60                   getClassPredTys, getClassPredTys_maybe, mkPredName,
61                   isInheritablePred, isIPPred,
62                   tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
63                 )
64 import CoreFVs  ( idFreeTyVars )
65 import Class    ( Class )
66 import DataCon  ( DataCon,dataConSig )
67 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
68 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
69 import Name     ( Name, mkMethodOcc, getOccName )
70 import PprType  ( pprPred, pprParendType )      
71 import Subst    ( emptyInScopeSet, mkSubst, 
72                   substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
73                 )
74 import Literal  ( inIntRange )
75 import Var      ( TyVar )
76 import VarEnv   ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
77 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
78 import TysWiredIn ( floatDataCon, doubleDataCon )
79 import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
80 import Util     ( equalLength )
81 import BasicTypes( IPName(..), mapIPName, ipNameName )
82 import UniqSupply( uniqsFromSupply )
83 import Outputable
84 \end{code}
85
86
87 Selection
88 ~~~~~~~~~
89 \begin{code}
90 instName :: Inst -> Name
91 instName inst = idName (instToId inst)
92
93 instToId :: Inst -> TcId
94 instToId (Dict id _ _)         = id
95 instToId (Method id _ _ _ _ _) = id
96 instToId (LitInst id _ _ _)    = id
97
98 instLoc (Dict _ _         loc) = loc
99 instLoc (Method _ _ _ _ _ loc) = loc
100 instLoc (LitInst _ _ _    loc) = loc
101
102 dictPred (Dict _ pred _ ) = pred
103 dictPred inst             = pprPanic "dictPred" (ppr inst)
104
105 getDictClassTys (Dict _ pred _) = getClassPredTys pred
106
107 -- fdPredsOfInst is used to get predicates that contain functional 
108 -- dependencies; i.e. should participate in improvement
109 fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
110                               | otherwise       = []
111 fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
112 fdPredsOfInst other                    = []
113
114 fdPredsOfInsts :: [Inst] -> [PredType]
115 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
116
117 isInheritableInst (Dict _ pred _)          = isInheritablePred pred
118 isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
119 isInheritableInst other                    = True
120
121
122 ipNamesOfInsts :: [Inst] -> [Name]
123 ipNamesOfInst  :: Inst   -> [Name]
124 -- Get the implicit parameters mentioned by these Insts
125 -- NB: ?x and %x get different Names
126 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
127
128 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
129 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
130 ipNamesOfInst other                    = []
131
132 tyVarsOfInst :: Inst -> TcTyVarSet
133 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
134 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
135 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
136                                          -- The id might have free type variables; in the case of
137                                          -- locally-overloaded class methods, for example
138
139
140 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
141 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
142 \end{code}
143
144 Predicates
145 ~~~~~~~~~~
146 \begin{code}
147 isDict :: Inst -> Bool
148 isDict (Dict _ _ _) = True
149 isDict other        = False
150
151 isClassDict :: Inst -> Bool
152 isClassDict (Dict _ pred _) = isClassPred pred
153 isClassDict other           = False
154
155 isTyVarDict :: Inst -> Bool
156 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
157 isTyVarDict other           = False
158
159 isIPDict :: Inst -> Bool
160 isIPDict (Dict _ pred _) = isIPPred pred
161 isIPDict other           = False
162
163 isMethod :: Inst -> Bool
164 isMethod (Method _ _ _ _ _ _) = True
165 isMethod other                = False
166
167 isMethodFor :: TcIdSet -> Inst -> Bool
168 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
169 isMethodFor ids inst                         = False
170
171 isLinearInst :: Inst -> Bool
172 isLinearInst (Dict _ pred _) = isLinearPred pred
173 isLinearInst other           = False
174         -- We never build Method Insts that have
175         -- linear implicit paramters in them.
176         -- Hence no need to look for Methods
177         -- See TcExpr.tcId 
178
179 linearInstType :: Inst -> TcType        -- %x::t  -->  t
180 linearInstType (Dict _ (IParam _ ty) _) = ty
181
182
183 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
184                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
185                                         other             -> False
186 \end{code}
187
188 Two predicates which deal with the case where class constraints don't
189 necessarily result in bindings.  The first tells whether an @Inst@
190 must be witnessed by an actual binding; the second tells whether an
191 @Inst@ can be generalised over.
192
193 \begin{code}
194 instBindingRequired :: Inst -> Bool
195 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
196 instBindingRequired other                      = True
197
198 instCanBeGeneralised :: Inst -> Bool
199 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
200 instCanBeGeneralised other                      = True
201 \end{code}
202
203
204 %************************************************************************
205 %*                                                                      *
206 \subsection{Building dictionaries}
207 %*                                                                      *
208 %************************************************************************
209
210 \begin{code}
211 newDicts :: InstOrigin
212          -> TcThetaType
213          -> TcM [Inst]
214 newDicts orig theta
215   = getInstLoc orig             `thenM` \ loc ->
216     newDictsAtLoc loc theta
217
218 cloneDict :: Inst -> TcM Inst
219 cloneDict (Dict id ty loc) = newUnique  `thenM` \ uniq ->
220                              returnM (Dict (setIdUnique id uniq) ty loc)
221
222 newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
223 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
224
225 -- Local function, similar to newDicts, 
226 -- but with slightly different interface
227 newDictsAtLoc :: InstLoc
228               -> TcThetaType
229               -> TcM [Inst]
230 newDictsAtLoc inst_loc@(_,loc,_) theta
231   = newUniqueSupply             `thenM` \ us ->
232     returnM (zipWith mk_dict (uniqsFromSupply us) theta)
233   where
234     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
235
236 -- For vanilla implicit parameters, there is only one in scope
237 -- at any time, so we used to use the name of the implicit parameter itself
238 -- But with splittable implicit parameters there may be many in 
239 -- scope, so we make up a new name.
240 newIPDict :: InstOrigin -> IPName Name -> Type 
241           -> TcM (IPName Id, Inst)
242 newIPDict orig ip_name ty
243   = getInstLoc orig                     `thenM` \ inst_loc@(_,loc,_) ->
244     newUnique                           `thenM` \ uniq ->
245     let
246         pred = IParam ip_name ty
247         id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
248     in
249     returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
250 \end{code}
251
252
253
254 %************************************************************************
255 %*                                                                      *
256 \subsection{Building methods (calls of overloaded functions)}
257 %*                                                                      *
258 %************************************************************************
259
260
261 \begin{code}
262 tcInstCall :: InstOrigin  -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
263 tcInstCall orig fun_ty  -- fun_ty is usually a sigma-type
264   = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
265     newDicts orig theta         `thenM` \ dicts ->
266     extendLIEs dicts            `thenM_`
267     let
268         inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
269     in
270     returnM (inst_fn, tau)
271
272 tcInstDataCon :: InstOrigin -> DataCon
273               -> TcM ([TcType], -- Types to instantiate at
274                       [Inst],   -- Existential dictionaries to apply to
275                       [TcType], -- Argument types of constructor
276                       TcType,   -- Result type
277                       [TyVar])  -- Existential tyvars
278 tcInstDataCon orig data_con
279   = let 
280         (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
281              -- We generate constraints for the stupid theta even when 
282              -- pattern matching (as the Report requires)
283     in
284     tcInstTyVars VanillaTv (tvs ++ ex_tvs)      `thenM` \ (all_tvs', ty_args', tenv) ->
285     let
286         stupid_theta' = substTheta tenv stupid_theta
287         ex_theta'     = substTheta tenv ex_theta
288         arg_tys'      = map (substTy tenv) arg_tys
289
290         n_normal_tvs  = length tvs
291         ex_tvs'       = drop n_normal_tvs all_tvs'
292         result_ty     = mkTyConApp tycon (take n_normal_tvs ty_args')
293     in
294     newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
295     newDicts orig ex_theta'     `thenM` \ ex_dicts ->
296
297         -- Note that we return the stupid theta *only* in the LIE;
298         -- we don't otherwise use it at all
299     extendLIEs stupid_dicts     `thenM_`
300
301     returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
302
303
304 newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
305 newMethodFromName origin ty name
306   = tcLookupId name             `thenM` \ id ->
307         -- Use tcLookupId not tcLookupGlobalId; the method is almost
308         -- always a class op, but with -fno-implicit-prelude GHC is
309         -- meant to find whatever thing is in scope, and that may
310         -- be an ordinary function. 
311     newMethod origin id [ty]    `thenM` \ inst ->
312     returnM (instToId inst)
313
314 newMethod :: InstOrigin
315           -> TcId
316           -> [TcType]
317           -> TcM Inst
318 newMethod orig id tys
319   =     -- Get the Id type and instantiate it at the specified types
320     let
321         (tyvars, rho) = tcSplitForAllTys (idType id)
322         rho_ty        = substTyWith tyvars tys rho
323         (pred, tau)   = tcSplitMethodTy rho_ty
324     in
325     newMethodWithGivenTy orig id tys [pred] tau
326
327 newMethodWithGivenTy orig id tys theta tau
328   = getInstLoc orig                     `thenM` \ loc ->
329     newMethodWith loc id tys theta tau  `thenM` \ inst ->
330     extendLIE inst                      `thenM_`
331     returnM inst
332
333 --------------------------------------------
334 -- newMethodWith and newMethodAtLoc do *not* drop the 
335 -- Inst into the LIE; they just returns the Inst
336 -- This is important because they are used by TcSimplify
337 -- to simplify Insts
338
339 newMethodWith inst_loc@(_,loc,_) id tys theta tau
340   = newUnique           `thenM` \ new_uniq ->
341     let
342         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
343         inst    = Method meth_id id tys theta tau inst_loc
344     in
345     returnM inst
346
347 newMethodAtLoc :: InstLoc
348                -> Id -> [TcType]
349                -> TcM Inst
350 newMethodAtLoc inst_loc real_id tys
351         -- This actually builds the Inst
352   =     -- Get the Id type and instantiate it at the specified types
353     let
354         (tyvars,rho)  = tcSplitForAllTys (idType real_id)
355         rho_ty        = ASSERT( equalLength tyvars tys )
356                         substTy (mkTopTyVarSubst tyvars tys) rho
357         (theta, tau)  = tcSplitPhiTy rho_ty
358     in
359     newMethodWith inst_loc real_id tys theta tau
360 \end{code}
361
362 In newOverloadedLit we convert directly to an Int or Integer if we
363 know that's what we want.  This may save some time, by not
364 temporarily generating overloaded literals, but it won't catch all
365 cases (the rest are caught in lookupInst).
366
367 \begin{code}
368 newOverloadedLit :: InstOrigin
369                  -> HsOverLit
370                  -> TcType
371                  -> TcM TcExpr
372 newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
373   | fi /= fromIntegerName       -- Do not generate a LitInst for rebindable
374                                 -- syntax.  Reason: tcSyntaxName does unification
375                                 -- which is very inconvenient in tcSimplify
376   = tcSyntaxName orig expected_ty fromIntegerName fi    `thenM` \ (expr, _) ->
377     returnM (HsApp expr (HsLit (HsInteger i)))
378
379   | Just expr <- shortCutIntLit i expected_ty 
380   = returnM expr
381
382   | otherwise
383   = newLitInst orig lit expected_ty
384
385 newOverloadedLit orig lit@(HsFractional r fr) expected_ty
386   | fr /= fromRationalName      -- c.f. HsIntegral case
387   = tcSyntaxName orig expected_ty fromRationalName fr   `thenM` \ (expr, _) ->
388     mkRatLit r                                          `thenM` \ rat_lit ->
389     returnM (HsApp expr rat_lit)
390
391   | Just expr <- shortCutFracLit r expected_ty 
392   = returnM expr
393
394   | otherwise
395   = newLitInst orig lit expected_ty
396
397 newLitInst orig lit expected_ty
398   = getInstLoc orig             `thenM` \ loc ->
399     newUnique                   `thenM` \ new_uniq ->
400     zapToType expected_ty       `thenM_` 
401         -- The expected type might be a 'hole' type variable, 
402         -- in which case we must zap it to an ordinary type variable
403     let
404         lit_inst = LitInst lit_id lit expected_ty loc
405         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
406     in
407     extendLIE lit_inst          `thenM_`
408     returnM (HsVar (instToId lit_inst))
409
410 shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
411 shortCutIntLit i ty
412   | isIntTy ty && inIntRange i                  -- Short cut for Int
413   = Just (HsLit (HsInt i))
414   | isIntegerTy ty                              -- Short cut for Integer
415   = Just (HsLit (HsInteger i))
416   | otherwise = Nothing
417
418 shortCutFracLit :: Rational -> TcType -> Maybe TcExpr
419 shortCutFracLit f ty
420   | isFloatTy ty 
421   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
422   | isDoubleTy ty
423   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
424   | otherwise = Nothing
425
426 mkRatLit :: Rational -> TcM TcExpr
427 mkRatLit r
428   = tcLookupTyCon rationalTyConName                     `thenM` \ rat_tc ->
429     let
430         rational_ty  = mkGenTyConApp rat_tc []
431     in
432     returnM (HsLit (HsRat r rational_ty))
433 \end{code}
434
435
436 %************************************************************************
437 %*                                                                      *
438 \subsection{Zonking}
439 %*                                                                      *
440 %************************************************************************
441
442 Zonking makes sure that the instance types are fully zonked,
443 but doesn't do the same for any of the Ids in an Inst.  There's no
444 need, and it's a lot of extra work.
445
446 \begin{code}
447 zonkInst :: Inst -> TcM Inst
448 zonkInst (Dict id pred loc)
449   = zonkTcPredType pred                 `thenM` \ new_pred ->
450     returnM (Dict id new_pred loc)
451
452 zonkInst (Method m id tys theta tau loc) 
453   = zonkId id                   `thenM` \ new_id ->
454         -- Essential to zonk the id in case it's a local variable
455         -- Can't use zonkIdOcc because the id might itself be
456         -- an InstId, in which case it won't be in scope
457
458     zonkTcTypes tys             `thenM` \ new_tys ->
459     zonkTcThetaType theta       `thenM` \ new_theta ->
460     zonkTcType tau              `thenM` \ new_tau ->
461     returnM (Method m new_id new_tys new_theta new_tau loc)
462
463 zonkInst (LitInst id lit ty loc)
464   = zonkTcType ty                       `thenM` \ new_ty ->
465     returnM (LitInst id lit new_ty loc)
466
467 zonkInsts insts = mappM zonkInst insts
468 \end{code}
469
470
471 %************************************************************************
472 %*                                                                      *
473 \subsection{Printing}
474 %*                                                                      *
475 %************************************************************************
476
477 ToDo: improve these pretty-printing things.  The ``origin'' is really only
478 relevant in error messages.
479
480 \begin{code}
481 instance Outputable Inst where
482     ppr inst = pprInst inst
483
484 pprInsts :: [Inst] -> SDoc
485 pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
486
487 pprInstsInFull insts
488   = vcat (map go insts)
489   where
490     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
491
492 pprInst (LitInst u lit ty loc)
493   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
494
495 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
496
497 pprInst m@(Method u id tys theta tau loc)
498   = hsep [ppr id, ptext SLIT("at"), 
499           brackets (sep (map pprParendType tys)) {- ,
500           ptext SLIT("theta"), ppr theta,
501           ptext SLIT("tau"), ppr tau
502           show_uniq u,
503           ppr (instToId m) -}]
504
505 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
506
507 tidyInst :: TidyEnv -> Inst -> Inst
508 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
509 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
510 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
511
512 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
513 -- This function doesn't assume that the tyvars are in scope
514 -- so it works like tidyOpenType, returning a TidyEnv
515 tidyMoreInsts env insts
516   = (env', map (tidyInst env') insts)
517   where
518     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
519
520 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
521 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
522
523 showLIE :: String -> TcM ()     -- Debugging
524 showLIE str
525   = do { lie_var <- getLIEVar ;
526          lie <- readMutVar lie_var ;
527          traceTc (text str <+> pprInstsInFull (lieToList lie)) }
528 \end{code}
529
530
531 %************************************************************************
532 %*                                                                      *
533 \subsection{Looking up Insts}
534 %*                                                                      *
535 %************************************************************************
536
537 \begin{code}
538 data LookupInstResult s
539   = NoInstance
540   | SimpleInst TcExpr           -- Just a variable, type application, or literal
541   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
542
543 lookupInst :: Inst -> TcM (LookupInstResult s)
544 -- It's important that lookupInst does not put any new stuff into
545 -- the LIE.  Instead, any Insts needed by the lookup are returned in
546 -- the LookupInstResult, where they can be further processed by tcSimplify
547
548
549 -- Dictionaries
550 lookupInst dict@(Dict _ (ClassP clas tys) loc)
551   = getDOpts                    `thenM` \ dflags ->
552     tcGetInstEnv                `thenM` \ inst_env ->
553     case lookupInstEnv dflags inst_env clas tys of
554
555       FoundInst tenv dfun_id
556         ->      -- It's possible that not all the tyvars are in
557                 -- the substitution, tenv. For example:
558                 --      instance C X a => D X where ...
559                 -- (presumably there's a functional dependency in class C)
560                 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.        
561            let
562                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
563                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
564                                    Just (DoneTy ty) -> returnM ty
565                                    Nothing          -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
566                                                        returnM (mkTyVarTy tc_tv)
567            in
568            mappM mk_ty_arg tyvars       `thenM` \ ty_args ->
569            let
570                 dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
571                 (theta, _) = tcSplitPhiTy dfun_rho
572                 ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
573            in
574            if null theta then
575                 returnM (SimpleInst ty_app)
576            else
577            newDictsAtLoc loc theta      `thenM` \ dicts ->
578            let 
579                 rhs = mkHsDictApp ty_app (map instToId dicts)
580            in
581            returnM (GenInst dicts rhs)
582
583       other     -> returnM NoInstance
584
585 lookupInst (Dict _ _ _)         = returnM NoInstance
586
587 -- Methods
588
589 lookupInst inst@(Method _ id tys theta _ loc)
590   = newDictsAtLoc loc theta             `thenM` \ dicts ->
591     returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
592
593 -- Literals
594
595 -- Look for short cuts first: if the literal is *definitely* a 
596 -- int, integer, float or a double, generate the real thing here.
597 -- This is essential  (see nofib/spectral/nucleic).
598 -- [Same shortcut as in newOverloadedLit, but we
599 --  may have done some unification by now]              
600
601
602 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
603   | Just expr <- shortCutIntLit i ty
604   = returnM (GenInst [] expr)   -- GenInst, not SimpleInst, because 
605                                         -- expr may be a constructor application
606   | otherwise
607   = ASSERT( from_integer_name == fromIntegerName )      -- A LitInst invariant
608     tcLookupId fromIntegerName                  `thenM` \ from_integer ->
609     newMethodAtLoc loc from_integer [ty]        `thenM` \ method_inst ->
610     returnM (GenInst [method_inst]
611                      (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
612
613
614 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
615   | Just expr <- shortCutFracLit f ty
616   = returnM (GenInst [] expr)
617
618   | otherwise
619   = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
620     tcLookupId fromRationalName                 `thenM` \ from_rational ->
621     newMethodAtLoc loc from_rational [ty]       `thenM` \ method_inst ->
622     mkRatLit f                                  `thenM` \ rat_lit ->
623     returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
624 \end{code}
625
626 There is a second, simpler interface, when you want an instance of a
627 class at a given nullary type constructor.  It just returns the
628 appropriate dictionary if it exists.  It is used only when resolving
629 ambiguous dictionaries.
630
631 \begin{code}
632 lookupSimpleInst :: Class
633                  -> [Type]                      -- Look up (c,t)
634                  -> TcM (Maybe ThetaType)       -- Here are the needed (c,t)s
635
636 lookupSimpleInst clas tys
637   = getDOpts                    `thenM` \ dflags ->
638     tcGetInstEnv                `thenM` \ inst_env -> 
639     case lookupInstEnv dflags inst_env clas tys of
640       FoundInst tenv dfun
641         -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
642         where
643            (_, rho)  = tcSplitForAllTys (idType dfun)
644            (theta,_) = tcSplitPhiTy rho
645
646       other  -> returnM Nothing
647 \end{code}
648
649
650 %************************************************************************
651 %*                                                                      *
652                 Re-mappable syntax
653 %*                                                                      *
654 %************************************************************************
655
656
657 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
658 a do-expression.  We have to find (>>) in the current environment, which is
659 done by the rename. Then we have to check that it has the same type as
660 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
661 this:
662
663   (>>) :: HB m n mn => m a -> n b -> mn b
664
665 So the idea is to generate a local binding for (>>), thus:
666
667         let then72 :: forall a b. m a -> m b -> m b
668             then72 = ...something involving the user's (>>)...
669         in
670         ...the do-expression...
671
672 Now the do-expression can proceed using then72, which has exactly
673 the expected type.
674
675 In fact tcSyntaxName just generates the RHS for then72, because we only
676 want an actual binding in the do-expression case. For literals, we can 
677 just use the expression inline.
678
679 \begin{code}
680 tcSyntaxName :: InstOrigin
681              -> TcType                  -- Type to instantiate it at
682              -> Name -> Name            -- (Standard name, user name)
683              -> TcM (TcExpr, TcType)    -- Suitable expression with its type
684
685 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
686 -- So we do not call it from lookupInst, which is called from tcSimplify
687
688 tcSyntaxName orig ty std_nm user_nm
689   | std_nm == user_nm
690   = newMethodFromName orig ty std_nm    `thenM` \ id ->
691     returnM (HsVar id, idType id)
692
693   | otherwise
694   = tcLookupId std_nm           `thenM` \ std_id ->
695     let 
696         -- C.f. newMethodAtLoc
697         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
698         tau1            = substTy (mkTopTyVarSubst [tv] [ty]) tau
699     in
700     addErrCtxtM (syntaxNameCtxt user_nm orig tau1)      $
701     tcExpr (HsVar user_nm) tau1                         `thenM` \ user_fn ->
702     returnM (user_fn, tau1)
703
704 syntaxNameCtxt name orig ty tidy_env
705   = getInstLoc orig             `thenM` \ inst_loc ->
706     let
707         msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+> 
708                                 ptext SLIT("(needed by a syntactic construct)"),
709                     nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
710                     nest 2 (pprInstLoc inst_loc)]
711     in
712     returnM (tidy_env, msg)
713 \end{code}