+tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc)
+ = -- Prime error recovery, set source location
+ recoverNF_Tc (returnNF_Tc Nothing) $
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (instDeclCtxt poly_ty) $
+
+ -- Typecheck the instance type itself. We can't use
+ -- tcHsSigType, because it's not a valid user type.
+ kcHsSigType poly_ty `thenTc_`
+ tcHsType poly_ty `thenTc` \ poly_ty' ->
+ let
+ (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+ in
+ checkValidTheta InstThetaCtxt theta `thenTc_`
+ checkValidInstHead tau `thenTc` \ (clas,inst_tys) ->
+ checkTc (checkInstFDs theta clas inst_tys)
+ (instTypeErr (pprClassPred clas inst_tys) msg) `thenTc_`
+ newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
+ returnTc (Just (InstInfo { iDFunId = mkDictFunId dfun_name clas tyvars inst_tys theta,
+ iBinds = binds, iPrags = uprags }))
+ where
+ msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
+\end{code}
+
+
+%************************************************************************
+%* *
+\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