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 )
)
import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
-import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
+import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Name ( Name )
import SrcLoc ( SrcLoc )
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
\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 $
-- Imported ones should have been checked already, and may indeed
-- contain something illegal in normal Haskell, notably
-- instance CCallable [Char]
- scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
- mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
+
+ getDOptsTc `thenTc` \ dflags ->
+ scrutiniseInstanceHead dflags clas inst_tys `thenNF_Tc_`
+ mapNF_Tc (scrutiniseInstanceConstraint dflags) 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]
We can also have instances for functions: @instance Foo (a -> b) ...@.
\begin{code}
-scrutiniseInstanceConstraint pred
- = getDOptsTc `thenTc` \ dflags -> case () of
- ()
- | dopt Opt_AllowUndecidableInstances dflags
- -> returnNF_Tc ()
-
- | Just (clas,tys) <- getClassTys_maybe pred,
- all isTyVarTy tys
- -> returnNF_Tc ()
-
- | otherwise
- -> addErrTc (instConstraintErr pred)
-
-scrutiniseInstanceHead clas inst_taus
- = getDOptsTc `thenTc` \ dflags -> case () of
- ()
- | -- CCALL CHECK
+scrutiniseInstanceConstraint dflags pred
+ | dopt Opt_AllowUndecidableInstances dflags
+ = returnNF_Tc ()
+
+ | Just (clas,tys) <- getClassTys_maybe pred,
+ all isTyVarTy tys
+ = returnNF_Tc ()
+
+ | otherwise
+ = addErrTc (instConstraintErr pred)
+
+scrutiniseInstanceHead dflags clas inst_taus
+ | -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
(clas `hasKey` cCallableClassKey
||
(clas `hasKey` cReturnableClassKey
&& not (creturnable_type first_inst_tau))
- -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
+ = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
-- Allow anything for AllowUndecidableInstances
- | dopt Opt_AllowUndecidableInstances dflags
- -> returnNF_Tc ()
+ | dopt Opt_AllowUndecidableInstances dflags
+ = returnNF_Tc ()
-- If GlasgowExts then check at least one isn't a type variable
- | dopt Opt_GlasgowExts dflags
- -> if all isTyVarTy inst_taus
- then addErrTc (instTypeErr clas inst_taus
+ | dopt Opt_GlasgowExts dflags
+ = if all isTyVarTy inst_taus
+ then addErrTc (instTypeErr clas inst_taus
(text "There must be at least one non-type-variable in the instance head"))
- else returnNF_Tc ()
+ else returnNF_Tc ()
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
- | not (length inst_taus == 1 &&
- maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
- not (isSynTyCon tycon) && -- ...but not a synonym
- all isTyVarTy arg_tys && -- Applied to type variables
- length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
- -- This last condition checks that all the type variables are distinct
- )
- -> addErrTc (instTypeErr clas inst_taus
- (text "the instance type must be of form (T a b c)" $$
- text "where T is not a synonym, and a,b,c are distinct type variables")
+ | not (length inst_taus == 1 &&
+ maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
+ not (isSynTyCon tycon) && -- ...but not a synonym
+ all isTyVarTy arg_tys && -- Applied to type variables
+ length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
+ -- This last condition checks that all the type variables are distinct
+ )
+ = addErrTc (instTypeErr clas inst_taus
+ (text "the instance type must be of form (T a b c)" $$
+ text "where T is not a synonym, and a,b,c are distinct type variables")
)
- | otherwise
- -> returnNF_Tc ()
+ | otherwise
+ = returnNF_Tc ()
where
(first_inst_tau : _) = inst_taus
Just (tycon, arg_tys) = maybe_tycon_app
ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
- creturnable_type ty = isFFIResultTy ty
+ creturnable_type ty = isFFIImportResultTy dflags ty
\end{code}
\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