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