2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcClassDcl]{Typechecking class declarations}
7 module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
12 InPat(..), HsBinds(..), GRHSsAndBinds(..), GRHS(..),
13 HsExpr(..), HsLit(..),
14 unguardedRHS, andMonoBinds, getTyVarName
16 import HsPragmas ( ClassPragmas(..) )
17 import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
18 import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
19 RenamedClassOpSig(..), RenamedMonoBinds,
20 RenamedContext(..), RenamedHsDecl, RenamedSig
22 import TcHsSyn ( TcMonoBinds )
24 import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
25 import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcAddImportedIdInfo,
26 tcLookupClass, tcLookupTyVar,
27 tcExtendGlobalTyVars, tcExtendLocalValEnv
29 import TcBinds ( tcBindWithSigs, bindInstsOfLocalFuns,
30 checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..)
32 import TcKind ( unifyKinds, TcKind )
34 import TcMonoType ( tcHsType, tcContext )
35 import TcSimplify ( tcSimplifyAndCheck )
36 import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
37 zonkSigTyVar, tcInstSigTcType
39 import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
40 import FieldLabel ( firstFieldLabelTag )
41 import Bag ( unionManyBags )
42 import Class ( mkClass, classBigSig, Class )
43 import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
44 import MkId ( mkDataCon, mkSuperDictSelId,
45 mkMethodSelId, mkDefaultMethodId
47 import Id ( Id, StrictnessMark(..),
48 getIdUnfolding, idType, idName
50 import CoreUnfold ( getUnfoldingTemplate )
52 import Name ( Name, isLocallyDefined, OccName, nameOccName,
55 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
56 mkSigmaTy, mkForAllTys, Type, ThetaType
58 import TyVar ( mkTyVarSet, tyVarKind, TyVar )
59 import TyCon ( mkDataTyCon )
60 import Kind ( mkBoxedTypeKind, mkArrowKind )
61 import Unique ( Unique, Uniquable(..) )
63 import Maybes ( assocMaybe, maybeToBool, seqMaybe )
66 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
67 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
68 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
76 Every class implicitly declares a new data type, corresponding to dictionaries
77 of that class. So, for example:
79 class (D a) => C a where
81 op2 :: forall b. Ord b => a -> b -> b
83 would implicitly declare
85 data CDict a = CDict (D a)
87 (forall b. Ord b => a -> b -> b)
89 (We could use a record decl, but that means changing more of the existing apparatus.
92 For classes with just one superclass+method, we use a newtype decl instead:
95 op :: forallb. a -> b -> b
99 newtype CDict a = CDict (forall b. a -> b -> b)
101 Now DictTy in Type is just a form of type synomym:
102 DictTy c t = TyConTy CDict `AppTy` t
104 Death to "ExpandingDicts".
108 tcClassDecl1 rec_env rec_inst_mapper
109 (ClassDecl context class_name
110 tyvar_names class_sigs def_methods pragmas
111 tycon_name datacon_name src_loc)
112 = tcAddSrcLoc src_loc $
113 tcAddErrCtxt (classDeclCtxt class_name) $
115 -- CHECK ARITY 1 FOR HASKELL 1.4
116 checkTc (opt_GlasgowExts || length tyvar_names == 1)
117 (classArityErr class_name) `thenTc_`
119 -- LOOK THINGS UP IN THE ENVIRONMENT
120 tcLookupClass class_name `thenTc` \ (class_kinds, rec_class) ->
121 mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_names
122 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
124 -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
125 unifyKinds class_kinds tyvar_kinds `thenTc_`
128 tcClassContext rec_class rec_tyvars context pragmas
129 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
131 -- CHECK THE CLASS SIGNATURES,
132 mapTc (tcClassSig rec_env rec_class rec_tyvars) class_sigs
133 `thenTc` \ sig_stuff ->
135 -- MAKE THE CLASS OBJECT ITSELF
137 (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
138 rec_class_inst_env = rec_inst_mapper rec_class
139 clas = mkClass (getName class_name) rec_tyvars
140 sc_theta sc_sel_ids op_sel_ids defm_ids
144 dict_component_tys = sc_tys ++ op_tys
145 new_or_data = case dict_component_tys of
149 dict_con_id = mkDataCon datacon_name
150 [NotMarkedStrict | _ <- dict_component_tys]
151 [{- No labelled fields -}]
154 [{-No existential tyvars-}] [{-Or context-}]
158 tycon = mkDataTyCon tycon_name
159 (foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars)
162 [dict_con_id] -- Constructors
164 (Just clas) -- Yes! It's a dictionary
173 tcClassContext :: Class -> [TyVar]
174 -> RenamedContext -- class context
175 -> RenamedClassPragmas -- pragmas for superclasses
176 -> TcM s (ThetaType, -- the superclass context
177 [Type], -- types of the superclass dictionaries
178 [Id]) -- superclass selector Ids
180 tcClassContext rec_class rec_tyvars context pragmas
181 = -- Check the context.
182 -- The renamer has already checked that the context mentions
183 -- only the type variable of the class decl.
184 tcContext context `thenTc` \ sc_theta ->
186 sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
189 -- Make super-class selector ids
190 -- We number them off, 1, 2, 3 etc so that we can construct
191 -- names for the selectors. Thus
192 -- class (C a, C b) => D a b where ...
193 -- gives superclass selectors
195 -- (We used to call them D_C, but now we can have two different
196 -- superclasses both called C!)
197 mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids ->
200 returnTc (sc_theta, sc_tys, sc_sel_ids)
203 rec_tyvar_tys = mkTyVarTys rec_tyvars
205 mk_super_id ((super_class, tys), index)
206 = tcGetUnique `thenNF_Tc` \ uniq ->
208 ty = mkForAllTys rec_tyvars $
209 mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
211 returnTc (mkSuperDictSelId uniq rec_class index ty)
214 tcClassSig :: GlobalValueEnv -- Knot tying only!
215 -> Class -- ...ditto...
216 -> [TyVar] -- The class type variable, used for error check only
218 -> TcM s (Type, -- Type of the method
220 Maybe Id) -- default-method ids
222 tcClassSig rec_env rec_clas rec_clas_tyvars
223 (ClassOpSig op_name maybe_dm_name
226 = tcAddSrcLoc src_loc $
228 -- Check the type signature. NB that the envt *already has*
229 -- bindings for the type variables; see comments in TcTyAndClassDcls.
231 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
232 -- and that it is not constrained by theta
233 tcHsType op_ty `thenTc` \ local_ty ->
235 global_ty = mkSigmaTy rec_clas_tyvars
236 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
240 -- Build the selector id and default method id
242 sel_id = mkMethodSelId op_name rec_clas global_ty
243 maybe_dm_id = case maybe_dm_name of
246 dm_id = mkDefaultMethodId dm_name rec_clas global_ty
248 Just (tcAddImportedIdInfo rec_env dm_id)
250 returnTc (local_ty, sel_id, maybe_dm_id)
254 %************************************************************************
256 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
258 %************************************************************************
260 The purpose of pass 2 is
263 to beat on the explicitly-provided default-method decls (if any),
264 using them to produce a complete set of default-method decls.
265 (Omitted ones elicit an error message.)
267 to produce a definition for the selector function for each method
268 and superclass dictionary.
271 Pass~2 only applies to locally-defined class declarations.
273 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
274 each local class decl.
277 tcClassDecls2 :: [RenamedHsDecl]
278 -> NF_TcM s (LIE s, TcMonoBinds s)
282 (returnNF_Tc (emptyLIE, EmptyMonoBinds))
283 [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
285 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
286 tc2 `thenNF_Tc` \ (lie2, binds2) ->
287 returnNF_Tc (lie1 `plusLIE` lie2,
288 binds1 `AndMonoBinds` binds2)
291 @tcClassDecl2@ is the business end of things.
294 tcClassDecl2 :: RenamedClassDecl -- The class declaration
295 -> NF_TcM s (LIE s, TcMonoBinds s)
297 tcClassDecl2 (ClassDecl context class_name
298 tyvar_names class_sigs default_binds pragmas _ _ src_loc)
300 | not (isLocallyDefined class_name)
301 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
303 | otherwise -- It is locally defined
304 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
305 tcAddSrcLoc src_loc $
307 -- Get the relevant class
308 tcLookupClass class_name `thenTc` \ (_, clas) ->
310 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
312 -- The selector binds are already in the selector Id's unfoldings
313 sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
314 | sel_id <- sc_sel_ids ++ op_sel_ids,
315 isLocallyDefined sel_id
318 final_sel_binds = andMonoBinds sel_binds
320 -- Generate bindings for the default methods
321 tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
323 returnTc (const_insts,
324 final_sel_binds `AndMonoBinds` meth_binds)
327 %************************************************************************
329 \subsection[Default methods]{Default methods}
331 %************************************************************************
333 The default methods for a class are each passed a dictionary for the
334 class, so that they get access to the other methods at the same type.
335 So, given the class decl
339 op2 :: Ord b => a -> b -> b -> b
342 op2 x y z = if (op1 x) && (y < z) then y else z
344 we get the default methods:
346 defm.Foo.op1 :: forall a. Foo a => a -> Bool
347 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
349 ====================== OLD ==================
351 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
352 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
353 if (op1 a dfoo x) && (< b dord y z) then y else z
355 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
356 ====================== END OF OLD ===================
360 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
361 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
362 if (op1 a dfoo x) && (< b dord y z) then y else z
366 When we come across an instance decl, we may need to use the default
369 instance Foo Int where {}
373 const.Foo.Int.op1 :: Int -> Bool
374 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
376 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
377 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
379 dfun.Foo.Int :: Foo Int
380 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
382 Notice that, as with method selectors above, we assume that dictionary
383 application is curried, so there's no need to mention the Ord dictionary
384 in const.Foo.Int.op2 (or the type variable).
387 instance Foo a => Foo [a] where {}
389 dfun.Foo.List :: forall a. Foo a -> Foo [a]
391 = /\ a -> \ dfoo_a ->
393 op1 = defm.Foo.op1 [a] dfoo_list
394 op2 = defm.Foo.op2 [a] dfoo_list
395 dfoo_list = (op1, op2)
404 -> TcM s (LIE s, TcMonoBinds s)
406 tcDefaultMethodBinds clas default_binds
407 = -- Construct suitable signatures
408 tcInstSigTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
410 -- Typecheck the default bindings
412 tc_dm sel_id_w_dm@(_, Just dm_id)
413 = tcMethodBind clas origin inst_tys clas_tyvars
414 default_binds [{-no prags-}] False
415 sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) ->
416 returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
418 mapAndUnzip3Tc tc_dm sel_ids_w_dms `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
421 newDicts origin [(clas,inst_tys)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
423 avail_insts = this_dict
425 tcAddErrCtxt (classDeclCtxt clas) $
426 mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
428 (ptext SLIT("class") <+> ppr clas)
429 (mkTyVarSet clas_tyvars')
431 (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
434 full_binds = AbsBinds
438 (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
440 returnTc (const_lie, full_binds)
443 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
445 sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
446 -- Just the ones for which there is an explicit
447 -- user default declaration
449 origin = ClassDeclOrigin
452 @tcMethodBind@ is used to type-check both default-method and
453 instance-decl method declarations. We must type-check methods one at a
454 time, because their signatures may have different contexts and
461 -> [TcType s] -- Instance types
462 -> [TcTyVar s] -- Free variables of those instance types
463 -- they'll be signature tyvars, and we
464 -- want to check that they don't bound
465 -> RenamedMonoBinds -- Method binding (pick the right one from in here)
466 -> [RenamedSig] -- Pramgas (just for this one)
467 -> Bool -- True <=> supply default decl if no explicit decl
468 -- This is true for instance decls,
469 -- false for class decls
470 -> (Id, Maybe Id) -- The method selector and default-method Id
471 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
473 tcMethodBind clas origin inst_tys inst_tyvars
474 meth_binds prags supply_default_bind
475 (sel_id, maybe_dm_id)
476 | no_user_bind && not supply_default_bind
477 = pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
480 = tcGetSrcLoc `thenNF_Tc` \ loc ->
482 -- Warn if no method binding, only if -fwarn-missing-methods
483 warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
484 (omittedMethodWarn sel_id clas) `thenNF_Tc_`
486 newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId meth_id) ->
487 tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
489 (theta', tau') = splitRhoTy rho_ty'
491 meth_name = idName meth_id
492 sig_info = TySigInfo meth_name meth_id tyvars' theta' tau' loc
493 meth_bind = mk_meth_bind meth_name loc
494 meth_prags = find_prags meth_name prags
496 tcExtendLocalValEnv [meth_name] [meth_id] (
497 tcPragmaSigs meth_prags
498 ) `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
500 -- Check that the signatures match
501 tcExtendGlobalTyVars inst_tyvars (
502 tcAddErrCtxt (methodCtxt sel_id) $
503 tcBindWithSigs NotTopLevel [meth_name] meth_bind [sig_info]
504 NonRecursive prag_info_fn
505 ) `thenTc` \ (binds, insts, _) ->
507 -- The prag_lie for a SPECIALISE pragma will mention the function
508 -- itself, so we have to simplify them away right now lest they float
510 bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) ->
512 -- Now check that the instance type variables
513 -- (or, in the case of a class decl, the class tyvars)
514 -- have not been unified with anything in the environment
515 tcAddErrCtxt (monoCtxt sel_id) (
516 tcAddErrCtxt (sigCtxt sel_id) $
517 checkSigTyVars inst_tyvars (idType meth_id)
520 returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
521 insts `plusLIE` prag_lie',
524 sel_name = idName sel_id
526 maybe_user_bind = find meth_binds
528 no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False}
529 no_user_default = case maybe_dm_id of {Nothing -> True; other -> False}
531 find EmptyMonoBinds = Nothing
532 find (AndMonoBinds b1 b2) = find b1 `seqMaybe` find b2
533 find b@(FunMonoBind op_name _ _ _) = if op_name == sel_name then Just b else Nothing
534 find b@(PatMonoBind (VarPatIn op_name) _ _) = if op_name == sel_name then Just b else Nothing
535 find other = panic "Urk! Bad instance method binding"
537 -- The renamer just puts the selector ID as the binder in the method binding
538 -- but we must use the method name; so we substitute it here. Crude but simple.
539 mk_meth_bind meth_name loc
540 = case maybe_user_bind of
541 Just (FunMonoBind _ fix matches loc) -> FunMonoBind meth_name fix matches loc
542 Just (PatMonoBind (VarPatIn _) rhs loc) -> PatMonoBind (VarPatIn meth_name) rhs loc
543 Nothing -> mk_default_bind meth_name loc
545 -- Find the prags for this method, and replace the
546 -- selector name with the method name
547 find_prags meth_name [] = []
548 find_prags meth_name (SpecSig name ty spec loc : prags)
549 | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
550 find_prags meth_name (InlineSig name loc : prags)
551 | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
552 find_prags meth_name (prag:prags) = find_prags meth_name prags
554 mk_default_bind local_meth_name loc
555 = PatMonoBind (VarPatIn local_meth_name)
556 (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
560 = case maybe_dm_id of
561 Just dm_id -> HsVar (getName dm_id) -- There's a default method
562 Nothing -> error_expr loc -- No default method
564 error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
565 (HsLit (HsString (_PK_ (error_msg loc))))
567 error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
573 classArityErr class_name
574 = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
576 classDeclCtxt class_name
577 = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
580 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
583 = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
584 nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
587 badMethodErr bndr clas
588 = hsep [ptext SLIT("Class"), quotes (ppr clas),
589 ptext SLIT("does not have a method"), quotes (ppr bndr)]
591 omittedMethodWarn sel_id clas
592 = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
593 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]