InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
newDFunName, tcExtendTyVarEnv
)
-import InstEnv ( InstEnv, extendInstEnv, pprInstEnv )
+import InstEnv ( InstEnv, extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
clas_decls = filter isClassDecl tycl_decls
in
-- (1) Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls `thenNF_Tc` \ inst_infos ->
+ mapNF_Tc (tcInstDecl1 unf_env) inst_decls `thenNF_Tc` \ inst_infos ->
-- (2) Instances from generic class declarations
- getGenericInstances mod clas_decls `thenTc` \ generic_inst_info ->
+ getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
-- Next, construct the instance environment so far, consisting of
-- a) cached non-home-package InstEnv (gotten from pcs) pcs_insts pcs
imported_inst_info
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
in
- traceTc (text "inst env before" <+> pprInstEnv inst_env0) `thenNF_Tc_`
- traceTc (vcat [text "imp" <+> ppr imported_dfuns,
- text "hst" <+> ppr hst_dfuns,
- text "local" <+> hsep (map pprInstInfo local_inst_info),
- text "gen" <+> hsep (map pprInstInfo generic_inst_info)]) `thenNF_Tc_`
addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 ->
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
- traceTc (vcat [text "deriv" <+> hsep (map pprInstInfo deriv_inst_info)]) `thenNF_Tc_`
addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
- traceTc (text "inst env after" <+> pprInstEnv final_inst_env) `thenNF_Tc_`
returnTc (inst_env1,
final_inst_env,
generic_inst_info ++ deriv_inst_info ++ local_inst_info,
let
(inst_env', errs) = extendInstEnv dflags dfuns infos
in
- traceTc (text "addInstDFuns" <+> vcat errs) `thenNF_Tc_`
addErrsTc errs `thenNF_Tc_`
returnTc inst_env'
\end{code}
\begin{code}
-tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
+tcInstDecl1 :: TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
-- Deal with a single instance declaration
-tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
+tcInstDecl1 unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
-- Make the dfun id and return it
- newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
+ newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
returnNF_Tc (True, dfun_name)
Just dfun_name -> -- An interface-file instance declaration
\begin{code}
-getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo]
-getGenericInstances mod class_decls
- = mapTc (get_generics mod) class_decls `thenTc` \ gen_inst_infos ->
+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
`thenNF_Tc_`
returnTc gen_inst_info
-get_generics mod decl@(ClassDecl context class_name tyvar_names
- fundeps class_sigs def_methods
- name_list loc)
+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, or
- -- its an imported class decl (=> has no methods at all)
+ = returnTc [] -- The comon case: no generic default methods
| otherwise -- A local class decl with generic default methods
= recoverNF_Tc (returnNF_Tc []) $
tcLookupClass class_name `thenTc` \ clas ->
-- Make an InstInfo out of each group
- mapTc (mkGenericInstance mod clas loc) groups `thenTc` \ inst_infos ->
+ 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
wrap ms = FunMonoBind id infixop ms loc
---------------------------------
-mkGenericInstance :: Module -> Class -> SrcLoc
+mkGenericInstance :: Class -> SrcLoc
-> (RenamedHsType, RenamedMonoBinds)
-> TcM InstInfo
-mkGenericInstance mod clas loc (hs_ty, binds)
+mkGenericInstance clas loc (hs_ty, binds)
-- Make a generic instance declaration
-- For example: instance (C a, C b) => C (a+b) where { binds }
(badGenericInstanceType binds) `thenTc_`
-- Make the dictionary function.
- newDFunName mod clas [inst_ty] loc `thenNF_Tc` \ dfun_name ->
+ newDFunName clas [inst_ty] loc `thenNF_Tc` \ dfun_name ->
let
inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
inst_tys = [inst_ty]
\begin{code}
tcAddDeclCtxt decl thing_inside
- = tcAddSrcLoc loc $
+ = tcAddSrcLoc (tcdLoc decl) $
tcAddErrCtxt ctxt $
thing_inside
where
- (name, loc, thing)
- = case decl of
- (ClassDecl _ name _ _ _ _ _ loc) -> (name, loc, "class")
- (TySynonym name _ _ loc) -> (name, loc, "type synonym")
- (TyData NewType _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
- (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
+ thing = case decl of
+ ClassDecl {} -> "class"
+ TySynonym {} -> "type synonym"
+ TyData {tcdND = NewType} -> "newtype"
+ TyData {tcdND = DataType} -> "data type"
ctxt = hsep [ptext SLIT("In the"), text thing,
- ptext SLIT("declaration for"), quotes (ppr name)]
+ ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff