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(..),
13 andMonoBinds, collectMonoBinders,
16 import HsPragmas ( ClassPragmas(..) )
17 import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
18 import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
19 RenamedClassOpSig(..), RenamedMonoBinds,
20 RenamedGenPragmas(..), RenamedContext(..), RenamedHsDecl
22 import TcHsSyn ( TcHsBinds, TcMonoBinds, TcExpr,
23 mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
25 import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
26 import TcEnv ( TcIdOcc(..), newLocalIds, tcAddImportedIdInfo,
27 tcLookupClass, tcLookupTyVar,
28 tcExtendGlobalTyVars )
29 import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, sigThetaCtxt, TcSigInfo(..) )
30 import TcKind ( unifyKinds, TcKind )
32 import TcMonoType ( tcHsType, tcContext )
33 import TcSimplify ( tcSimplifyAndCheck )
34 import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
35 zonkSigTyVar, tcInstSigTcType
37 import PragmaInfo ( PragmaInfo(..) )
39 import Bag ( bagToList, unionManyBags )
40 import Class ( mkClass, classBigSig, Class )
41 import CmdLineOpts ( opt_PprUserLength, opt_GlasgowExts )
42 import Id ( Id, StrictnessMark(..),
43 mkSuperDictSelId, mkMethodSelId,
44 mkDefaultMethodId, getIdUnfolding, mkDataCon,
47 import CoreUnfold ( getUnfoldingTemplate )
49 import Name ( Name, isLocallyDefined, moduleString, getSrcLoc,
51 nameString, NamedThing(..) )
53 import SrcLoc ( mkGeneratedSrcLoc )
54 import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
55 mkForAllTy, mkSigmaTy, splitSigmaTy, mkForAllTys, Type, ThetaType
57 import TysWiredIn ( stringTy )
58 import TyVar ( unitTyVarSet, tyVarSetToList, mkTyVarSet, tyVarKind, TyVar )
59 import TyCon ( mkDataTyCon )
60 import Kind ( mkBoxedTypeKind, mkArrowKind )
61 import Unique ( Unique, Uniquable(..) )
63 import Maybes ( assocMaybe, maybeToBool )
66 -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
67 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
68 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec,
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 mapTc mk_super_id sc_theta `thenTc` \ sc_sel_ids ->
193 returnTc (sc_theta, sc_tys, sc_sel_ids)
196 rec_tyvar_tys = mkTyVarTys rec_tyvars
198 mk_super_id (super_class, tys)
199 = tcGetUnique `thenNF_Tc` \ uniq ->
201 ty = mkForAllTys rec_tyvars $
202 mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
204 returnTc (mkSuperDictSelId uniq rec_class super_class ty)
207 tcClassSig :: TcEnv s -- Knot tying only!
208 -> Class -- ...ditto...
209 -> [TyVar] -- The class type variable, used for error check only
211 -> TcM s (Type, -- Type of the method
213 Maybe Id) -- default-method ids
215 tcClassSig rec_env rec_clas rec_clas_tyvars
216 (ClassOpSig op_name maybe_dm_name
219 = tcAddSrcLoc src_loc $
221 -- Check the type signature. NB that the envt *already has*
222 -- bindings for the type variables; see comments in TcTyAndClassDcls.
224 -- NB: Renamer checks that the class type variable is mentioned in local_ty,
225 -- and that it is not constrained by theta
226 tcHsType op_ty `thenTc` \ local_ty ->
228 global_ty = mkSigmaTy rec_clas_tyvars
229 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
233 -- Build the selector id and default method id
235 sel_id = mkMethodSelId op_name rec_clas global_ty
236 maybe_dm_id = case maybe_dm_name of
239 dm_id = mkDefaultMethodId dm_name rec_clas global_ty
241 Just (tcAddImportedIdInfo rec_env dm_id)
243 returnTc (local_ty, sel_id, maybe_dm_id)
247 %************************************************************************
249 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
251 %************************************************************************
253 The purpose of pass 2 is
256 to beat on the explicitly-provided default-method decls (if any),
257 using them to produce a complete set of default-method decls.
258 (Omitted ones elicit an error message.)
260 to produce a definition for the selector function for each method
261 and superclass dictionary.
264 Pass~2 only applies to locally-defined class declarations.
266 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
267 each local class decl.
270 tcClassDecls2 :: [RenamedHsDecl]
271 -> NF_TcM s (LIE s, TcMonoBinds s)
275 (returnNF_Tc (emptyLIE, EmptyMonoBinds))
276 [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
278 combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
279 tc2 `thenNF_Tc` \ (lie2, binds2) ->
280 returnNF_Tc (lie1 `plusLIE` lie2,
281 binds1 `AndMonoBinds` binds2)
284 @tcClassDecl2@ is the business end of things.
287 tcClassDecl2 :: RenamedClassDecl -- The class declaration
288 -> NF_TcM s (LIE s, TcMonoBinds s)
290 tcClassDecl2 (ClassDecl context class_name
291 tyvar_names class_sigs default_binds pragmas _ _ src_loc)
293 | not (isLocallyDefined class_name)
294 = returnNF_Tc (emptyLIE, EmptyMonoBinds)
296 | otherwise -- It is locally defined
297 = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
298 tcAddSrcLoc src_loc $
300 -- Get the relevant class
301 tcLookupClass class_name `thenTc` \ (_, clas) ->
303 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
305 -- The selector binds are already in the selector Id's unfoldings
306 sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
307 | sel_id <- sc_sel_ids ++ op_sel_ids,
308 isLocallyDefined sel_id
311 final_sel_binds = andMonoBinds sel_binds
313 -- Generate bindings for the default methods
314 tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
316 returnTc (const_insts,
317 final_sel_binds `AndMonoBinds` meth_binds)
320 %************************************************************************
322 \subsection[Default methods]{Default methods}
324 %************************************************************************
326 The default methods for a class are each passed a dictionary for the
327 class, so that they get access to the other methods at the same type.
328 So, given the class decl
332 op2 :: Ord b => a -> b -> b -> b
335 op2 x y z = if (op1 x) && (y < z) then y else z
337 we get the default methods:
339 defm.Foo.op1 :: forall a. Foo a => a -> Bool
340 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
342 ====================== OLD ==================
344 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
345 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
346 if (op1 a dfoo x) && (< b dord y z) then y else z
348 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
349 ====================== END OF OLD ===================
353 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
354 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
355 if (op1 a dfoo x) && (< b dord y z) then y else z
359 When we come across an instance decl, we may need to use the default
362 instance Foo Int where {}
366 const.Foo.Int.op1 :: Int -> Bool
367 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
369 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
370 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
372 dfun.Foo.Int :: Foo Int
373 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
375 Notice that, as with method selectors above, we assume that dictionary
376 application is curried, so there's no need to mention the Ord dictionary
377 in const.Foo.Int.op2 (or the type variable).
380 instance Foo a => Foo [a] where {}
382 dfun.Foo.List :: forall a. Foo a -> Foo [a]
384 = /\ a -> \ dfoo_a ->
386 op1 = defm.Foo.op1 [a] dfoo_list
387 op2 = defm.Foo.op2 [a] dfoo_list
388 dfoo_list = (op1, op2)
397 -> TcM s (LIE s, TcMonoBinds s)
399 tcDefaultMethodBinds clas default_binds
400 = -- Construct suitable signatures
401 tcInstSigTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
403 -- Typecheck the default bindings
406 | not (maybeToBool maybe_stuff)
407 = -- Binding for something that isn't in the class signature
408 failWithTc (badMethodErr bndr_name clas)
412 tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind
413 `thenTc` \ (bind, insts, (_, local_dm_id)) ->
414 returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
416 bndr_name = case meth_bind of
417 FunMonoBind name _ _ _ -> name
418 PatMonoBind (VarPatIn name) _ _ -> name
420 maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
421 assoc_list = [ (getOccName sel_id, pair)
422 | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
424 Just (sel_id, Just dm_id) = maybe_stuff
425 -- We're looking at a default-method binding, so the dm_id
426 -- is sure to be there! Hence the inner "Just".
429 (flatten default_binds []) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
432 newDicts origin [(clas,inst_tys)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
434 avail_insts = this_dict
436 tcAddErrCtxt (classDeclCtxt clas) $
437 tcAddErrCtxtM (sigThetaCtxt avail_insts) $
438 mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
439 tcSimplifyAndCheck (text "classDecl")
440 (mkTyVarSet clas_tyvars')
442 (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
445 full_binds = AbsBinds
449 (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
451 returnTc (const_lie, full_binds)
454 (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
455 origin = ClassDeclOrigin
457 flatten EmptyMonoBinds rest = rest
458 flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
459 flatten a_bind rest = a_bind : rest
462 @tcMethodBind@ is used to type-check both default-method and
463 instance-decl method declarations. We must type-check methods one at a
464 time, because their signatures may have different contexts and
471 -> [TcType s] -- Instance types
472 -> [TcTyVar s] -- Free variables of those instance types
473 -- they'll be signature tyvars, and we
474 -- want to check that they don't bound
475 -> Id -- The method selector
476 -> RenamedMonoBinds -- Method binding (just one)
477 -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
479 tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind
480 = tcAddSrcLoc src_loc $
481 newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
482 tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
484 (theta', tau') = splitRhoTy rho_ty'
485 sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
487 tcExtendGlobalTyVars inst_tyvars (
488 tcAddErrCtxt (methodCtxt sel_id) $
489 tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
490 NonRecursive (\_ -> NoPragmaInfo)
491 ) `thenTc` \ (binds, insts, _) ->
493 -- Now check that the instance type variables
494 -- (or, in the case of a class decl, the class tyvars)
495 -- have not been unified with anything in the environment
496 tcAddErrCtxt (monoCtxt sel_id) (
497 tcAddErrCtxt (sigCtxt sel_id) $
498 checkSigTyVars inst_tyvars (idType local_meth_id)
501 returnTc (binds, insts, meth)
503 (bndr_name, src_loc) = case meth_bind of
504 FunMonoBind name _ _ loc -> (name, loc)
505 PatMonoBind (VarPatIn name) _ loc -> (name, loc)
511 classArityErr class_name
512 = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
514 classDeclCtxt class_name
515 = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
518 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
521 = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
522 nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
525 badMethodErr bndr clas
526 = hsep [ptext SLIT("Class"), quotes (ppr clas),
527 ptext SLIT("does not have a method"), quotes (ppr bndr)]