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