4e45d11091cee930887cb86e8ccbe593546aac4a
[ghc.git] / compiler / typecheck / TcClassDcl.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 Typechecking class declarations
7
8 \begin{code}
9 {-# LANGUAGE CPP #-}
10
11 module TcClassDcl ( tcClassSigs, tcClassDecl2,
12                     findMethodBind, instantiateMethod, tcInstanceMethodBody,
13                     tcClassMinimalDef,
14                     HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
15                     tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
16                   ) where
17
18 #include "HsVersions.h"
19
20 import HsSyn
21 import TcEnv
22 import TcPat( addInlinePrags )
23 import TcEvidence( idHsWrapper )
24 import TcBinds
25 import TcUnify
26 import TcHsType
27 import TcMType
28 import Type     ( getClassPredTys_maybe )
29 import TcType
30 import TcRnMonad
31 import BuildTyCl( TcMethInfo )
32 import Class
33 import Id
34 import Name
35 import NameEnv
36 import NameSet
37 import Var
38 import Outputable
39 import SrcLoc
40 import Maybes
41 import BasicTypes
42 import Bag
43 import FastString
44 import BooleanFormula
45 import Util
46
47 import Control.Monad
48 \end{code}
49
50
51 Dictionary handling
52 ~~~~~~~~~~~~~~~~~~~
53 Every class implicitly declares a new data type, corresponding to dictionaries
54 of that class. So, for example:
55
56         class (D a) => C a where
57           op1 :: a -> a
58           op2 :: forall b. Ord b => a -> b -> b
59
60 would implicitly declare
61
62         data CDict a = CDict (D a)
63                              (a -> a)
64                              (forall b. Ord b => a -> b -> b)
65
66 (We could use a record decl, but that means changing more of the existing apparatus.
67 One step at at time!)
68
69 For classes with just one superclass+method, we use a newtype decl instead:
70
71         class C a where
72           op :: forallb. a -> b -> b
73
74 generates
75
76         newtype CDict a = CDict (forall b. a -> b -> b)
77
78 Now DictTy in Type is just a form of type synomym:
79         DictTy c t = TyConTy CDict `AppTy` t
80
81 Death to "ExpandingDicts".
82
83
84 %************************************************************************
85 %*                                                                      *
86                 Type-checking the class op signatures
87 %*                                                                      *
88 %************************************************************************
89
90 \begin{code}
91 tcClassSigs :: Name                  -- Name of the class
92             -> [LSig Name]
93             -> LHsBinds Name
94             -> TcM ([TcMethInfo],    -- Exactly one for each method
95                     NameEnv Type)    -- Types of the generic-default methods
96 tcClassSigs clas sigs def_methods
97   = do { traceTc "tcClassSigs 1" (ppr clas)
98
99        ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
100        ; let gen_dm_env = mkNameEnv gen_dm_prs
101
102        ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
103
104        ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
105        ; sequence_ [ failWithTc (badMethodErr clas n)
106                    | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
107                    -- Value binding for non class-method (ie no TypeSig)
108
109        ; sequence_ [ failWithTc (badGenericMethod clas n)
110                    | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
111                    -- Generic signature without value binding
112
113        ; traceTc "tcClassSigs 2" (ppr clas)
114        ; return (op_info, gen_dm_env) }
115   where
116     vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig    nm ty) <- sigs]
117     gen_sigs     = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
118     dm_bind_names :: [Name]     -- These ones have a value binding in the class decl
119     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
120
121     tc_sig genop_env (op_names, op_hs_ty)
122       = do { traceTc "ClsSig 1" (ppr op_names)
123            ; op_ty <- tcClassSigType op_hs_ty   -- Class tyvars already in scope
124            ; traceTc "ClsSig 2" (ppr op_names)
125            ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
126            where
127              f nm | nm `elemNameEnv` genop_env = GenericDM
128                   | nm `elem` dm_bind_names    = VanillaDM
129                   | otherwise                  = NoDM
130
131     tc_gen_sig (op_names, gen_hs_ty)
132       = do { gen_op_ty <- tcClassSigType gen_hs_ty
133            ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
134 \end{code}
135
136
137 %************************************************************************
138 %*                                                                      *
139                 Class Declarations
140 %*                                                                      *
141 %************************************************************************
142
143 \begin{code}
144 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
145              -> TcM (LHsBinds Id)
146
147 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
148                                 tcdMeths = default_binds}))
149   = recoverM (return emptyLHsBinds)     $
150     setSrcSpan loc                      $
151     do  { clas <- tcLookupLocatedClass class_name
152
153         -- We make a separate binding for each default method.
154         -- At one time I used a single AbsBinds for all of them, thus
155         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
156         -- But that desugars into
157         --      ds = \d -> (..., ..., ...)
158         --      dm1 = \d -> case ds d of (a,b,c) -> a
159         -- And since ds is big, it doesn't get inlined, so we don't get good
160         -- default methods.  Better to make separate AbsBinds for each
161         ; let
162               (tyvars, _, _, op_items) = classBigSig clas
163               prag_fn     = mkPragFun sigs default_binds
164               sig_fn      = mkHsSigFun sigs
165               clas_tyvars = snd (tcSuperSkolTyVars tyvars)
166               pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
167         ; this_dict <- newEvVar pred
168
169         ; traceTc "TIM2" (ppr sigs)
170         ; let tc_dm = tcDefMeth clas clas_tyvars
171                                 this_dict default_binds
172                                 sig_fn prag_fn
173
174         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
175                       mapM tc_dm op_items
176
177         ; return (unionManyBags dm_binds) }
178
179 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
180
181 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
182           -> HsSigFun -> PragFun -> ClassOpItem
183           -> TcM (LHsBinds TcId)
184 -- Generate code for polymorphic default methods only (hence DefMeth)
185 -- (Generic default methods have turned into instance decls by now.)
186 -- This is incompatible with Hugs, which expects a polymorphic
187 -- default method for every class op, regardless of whether or not
188 -- the programmer supplied an explicit default decl for the class.
189 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
190 tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
191   = case dm_info of
192       NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
193                                ; return emptyBag }
194       DefMeth dm_name    -> tc_dm dm_name
195       GenDefMeth dm_name -> tc_dm dm_name
196   where
197     sel_name           = idName sel_id
198     prags              = prag_fn sel_name
199     (dm_bind,bndr_loc) = findMethodBind sel_name binds_in
200                          `orElse` pprPanic "tcDefMeth" (ppr sel_id)
201
202     -- Eg.   class C a where
203     --          op :: forall b. Eq b => a -> [b] -> a
204     --          gen_op :: a -> a
205     --          generic gen_op :: D a => a -> a
206     -- The "local_dm_ty" is precisely the type in the above
207     -- type signatures, ie with no "forall a. C a =>" prefix
208
209     tc_dm dm_name
210       = do { dm_id <- tcLookupId dm_name
211            ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
212              -- Base the local_dm_name on the selector name, because
213              -- type errors from tcInstanceMethodBody come from here
214
215            ; dm_id_w_inline <- addInlinePrags dm_id prags
216            ; spec_prags     <- tcSpecPrags dm_id prags
217
218            ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
219                  hs_ty       = lookupHsSig hs_sig_fn sel_name
220                                `orElse` pprPanic "tc_dm" (ppr sel_name)
221
222            ; local_dm_sig <- instTcTySig hs_ty local_dm_ty local_dm_name
223            ; warnTc (not (null spec_prags))
224                     (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
225                      <+> quotes (ppr sel_name))
226
227            ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
228                                              dm_id_w_inline local_dm_sig
229                                              IsDefaultMethod dm_bind
230
231            ; return (unitBag tc_bind) }
232
233 ---------------
234 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
235                      -> Id -> TcSigInfo
236                      -> TcSpecPrags -> LHsBind Name
237                      -> TcM (LHsBind Id)
238 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
239                      meth_id local_meth_sig
240                      specs (L loc bind)
241   = do  { let local_meth_id = case local_meth_sig of
242                   TcSigInfo{ sig_id = meth_id } -> meth_id
243                   _ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig)
244               lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
245                              -- Substitute the local_meth_name for the binder
246                              -- NB: the binding is always a FunBind
247         ; (ev_binds, (tc_bind, _, _))
248                <- checkConstraints skol_info tyvars dfun_ev_vars $
249                   tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind
250
251         ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
252                            , abe_mono = local_meth_id, abe_prags = specs }
253               full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
254                                    , abs_exports = [export]
255                                    , abs_ev_binds = ev_binds
256                                    , abs_binds = tc_bind }
257
258         ; return (L loc full_bind) }
259   where
260     no_prag_fn  _ = []          -- No pragmas for local_meth_id;
261                                 -- they are all for meth_id
262
263 ---------------
264 tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
265 tcClassMinimalDef _clas sigs op_info
266   = case findMinimalDef sigs of
267       Nothing -> return defMindef
268       Just mindef -> do
269         -- Warn if the given mindef does not imply the default one
270         -- That is, the given mindef should at least ensure that the
271         -- class ops without default methods are required, since we
272         -- have no way to fill them in otherwise
273         whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
274                    (\bf -> addWarnTc (warningMinimalDefIncomplete bf))
275         return mindef
276   where
277     -- By default require all methods without a default
278     -- implementation whose names don't start with '_'
279     defMindef :: ClassMinimalDef
280     defMindef = mkAnd [ mkVar name
281                       | (name, NoDM, _) <- op_info
282                       , not (startsWithUnderscore (getOccName name)) ]
283 \end{code}
284
285 \begin{code}
286 instantiateMethod :: Class -> Id -> [TcType] -> TcType
287 -- Take a class operation, say
288 --      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
289 -- Instantiate it at [ty1,ty2]
290 -- Return the "local method type":
291 --      forall c. Ix x => (ty2,c) -> ty1
292 instantiateMethod clas sel_id inst_tys
293   = ASSERT( ok_first_pred ) local_meth_ty
294   where
295     (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
296     rho_ty = ASSERT( length sel_tyvars == length inst_tys )
297              substTyWith sel_tyvars inst_tys sel_rho
298
299     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
300                 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
301
302     ok_first_pred = case getClassPredTys_maybe first_pred of
303                       Just (clas1, _tys) -> clas == clas1
304                       Nothing -> False
305               -- The first predicate should be of form (C a b)
306               -- where C is the class in question
307
308
309 ---------------------------
310 type HsSigFun = NameEnv (LHsType Name)
311
312 emptyHsSigs :: HsSigFun
313 emptyHsSigs = emptyNameEnv
314
315 mkHsSigFun :: [LSig Name] -> HsSigFun
316 mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
317                             | L _ (TypeSig ns hs_ty) <- sigs
318                             , L _ n <- ns ]
319
320 lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
321 lookupHsSig = lookupNameEnv
322
323 ---------------------------
324 findMethodBind  :: Name                 -- Selector name
325                 -> LHsBinds Name        -- A group of bindings
326                 -> Maybe (LHsBind Name, SrcSpan)
327                 -- Returns the binding, and the binding
328                 -- site of the method binder
329 findMethodBind sel_name binds
330   = foldlBag mplus Nothing (mapBag f binds)
331   where
332     f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
333       | op_name == sel_name
334              = Just (bind, bndr_loc)
335     f _other = Nothing
336
337 ---------------------------
338 findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
339 findMinimalDef = firstJusts . map toMinimalDef
340   where
341     toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
342     toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf)
343     toMinimalDef _                     = Nothing
344 \end{code}
345
346 Note [Polymorphic methods]
347 ~~~~~~~~~~~~~~~~~~~~~~~~~~
348 Consider
349     class Foo a where
350         op :: forall b. Ord b => a -> b -> b -> b
351     instance Foo c => Foo [c] where
352         op = e
353
354 When typechecking the binding 'op = e', we'll have a meth_id for op
355 whose type is
356       op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
357
358 So tcPolyBinds must be capable of dealing with nested polytypes;
359 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
360
361 Note [Silly default-method bind]
362 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 When we pass the default method binding to the type checker, it must
364 look like    op2 = e
365 not          $dmop2 = e
366 otherwise the "$dm" stuff comes out error messages.  But we want the
367 "$dm" to come out in the interface file.  So we typecheck the former,
368 and wrap it in a let, thus
369           $dmop2 = let op2 = e in op2
370 This makes the error messages right.
371
372
373 %************************************************************************
374 %*                                                                      *
375                 Error messages
376 %*                                                                      *
377 %************************************************************************
378
379 \begin{code}
380 tcMkDeclCtxt :: TyClDecl Name -> SDoc
381 tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
382                       ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
383
384 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
385 tcAddDeclCtxt decl thing_inside
386   = addErrCtxt (tcMkDeclCtxt decl) thing_inside
387
388 badMethodErr :: Outputable a => a -> Name -> SDoc
389 badMethodErr clas op
390   = hsep [ptext (sLit "Class"), quotes (ppr clas),
391           ptext (sLit "does not have a method"), quotes (ppr op)]
392
393 badGenericMethod :: Outputable a => a -> Name -> SDoc
394 badGenericMethod clas op
395   = hsep [ptext (sLit "Class"), quotes (ppr clas),
396           ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
397
398 {-
399 badGenericInstanceType :: LHsBinds Name -> SDoc
400 badGenericInstanceType binds
401   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
402           nest 2 (ppr binds)]
403
404 missingGenericInstances :: [Name] -> SDoc
405 missingGenericInstances missing
406   = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
407
408 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
409 dupGenericInsts tc_inst_infos
410   = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
411           nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
412           ptext (sLit "All the type patterns for a generic type constructor must be identical")
413     ]
414   where
415     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
416 -}
417 badDmPrag :: Id -> Sig Name -> TcM ()
418 badDmPrag sel_id prag
419   = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
420               <+> quotes (ppr sel_id)
421               <+> ptext (sLit "lacks an accompanying binding"))
422
423 warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
424 warningMinimalDefIncomplete mindef
425   = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
426          , nest 2 (pprBooleanFormulaNice mindef)
427          , ptext (sLit "but there is no default implementation.") ]
428 \end{code}