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