-\subsection{Extracting generic instance declaration from class declarations}
-%* *
-%************************************************************************
-
-@getGenericInstances@ extracts the generic instance declarations from a class
-declaration. For exmaple
-
- class C a where
- op :: a -> a
-
- op{ x+y } (Inl v) = ...
- op{ x+y } (Inr v) = ...
- op{ x*y } (v :*: w) = ...
- op{ 1 } Unit = ...
-
-gives rise to the instance declarations
-
- instance C (x+y) where
- op (Inl v) = ...
- op (Inr v) = ...
-
- instance C (x*y) where
- op (v :*: w) = ...
-
- instance C 1 where
- op Unit = ...
-
-
-\begin{code}
-getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo]
-getGenericInstances class_decls
- = mapTc get_generics class_decls `thenTc` \ gen_inst_infos ->
- let
- gen_inst_info = concat gen_inst_infos
- in
- if null gen_inst_info then
- returnTc []
- else
- getDOptsTc `thenNF_Tc` \ dflags ->
- ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
- (vcat (map pprInstInfo gen_inst_info)))
- `thenNF_Tc_`
- returnTc gen_inst_info
-
-get_generics decl@(ClassDecl {tcdMeths = Nothing})
- = returnTc [] -- Imported class decls
-
-get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc})
- | null groups
- = returnTc [] -- The comon case: no generic default methods
-
- | otherwise -- A source class decl with generic default methods
- = recoverNF_Tc (returnNF_Tc []) $
- tcAddDeclCtxt decl $
- tcLookupClass class_name `thenTc` \ clas ->
-
- -- Make an InstInfo out of each group
- mapTc (mkGenericInstance clas loc) groups `thenTc` \ inst_infos ->
-
- -- Check that there is only one InstInfo for each type constructor
- -- The main way this can fail is if you write
- -- f {| a+b |} ... = ...
- -- f {| x+y |} ... = ...
- -- Then at this point we'll have an InstInfo for each
- let
- tc_inst_infos :: [(TyCon, InstInfo)]
- tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
-
- bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
- group `lengthExceeds` 1]
- get_uniq (tc,_) = getUnique tc
- in
- mapTc (addErrTc . dupGenericInsts) bad_groups `thenTc_`
-
- -- Check that there is an InstInfo for each generic type constructor
- let
- missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]
- in
- checkTc (null missing) (missingGenericInstances missing) `thenTc_`
-
- returnTc inst_infos
-
- where
- -- Group the declarations by type pattern
- groups :: [(RenamedHsType, RenamedMonoBinds)]
- groups = assocElts (getGenericBinds def_methods)
-
-
----------------------------------
-getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds
- -- Takes a group of method bindings, finds the generic ones, and returns
- -- them in finite map indexed by the type parameter in the definition.
-
-getGenericBinds EmptyMonoBinds = emptyAssoc
-getGenericBinds (AndMonoBinds m1 m2)
- = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
-
-getGenericBinds (FunMonoBind id infixop matches loc)
- = mapAssoc wrap (foldl add emptyAssoc matches)
- -- Using foldl not foldr is vital, else
- -- we reverse the order of the bindings!
- where
- add env match = case maybeGenericMatch match of
- Nothing -> env
- Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
-
- wrap ms = FunMonoBind id infixop ms loc
-
----------------------------------
-mkGenericInstance :: Class -> SrcLoc
- -> (RenamedHsType, RenamedMonoBinds)
- -> TcM InstInfo
-
-mkGenericInstance clas loc (hs_ty, binds)
- -- Make a generic instance declaration
- -- For example: instance (C a, C b) => C (a+b) where { binds }
-
- = -- Extract the universally quantified type variables
- let
- sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
- in
- tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars ->
-
- -- Type-check the instance type, and check its form
- tcHsSigType GenPatCtxt hs_ty `thenTc` \ inst_ty ->
- checkTc (validGenericInstanceType inst_ty)
- (badGenericInstanceType binds) `thenTc_`
-
- -- Make the dictionary function.
- newDFunName clas [inst_ty] loc `thenNF_Tc` \ dfun_name ->
- let
- inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
- dfun_id = mkDictFunId dfun_name clas tyvars [inst_ty] inst_theta
- in
-
- returnTc (InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = [] })
-\end{code}
-
-
-%************************************************************************
-%* *