+ match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
+ = from_here && clas == inst_clas &&
+ match_ty inst_ty && is_plain_instance inst_ty
+
+ match_inst_ty = case maybe_tycon of
+ Just tycon -> match_tycon tycon
+ Nothing -> match_fun
+
+ match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
+ Just (inst_tc,_,_) -> tycon == inst_tc
+ Nothing -> False
+
+ match_fun inst_ty = isFunType inst_ty
+
+
+is_plain_instance inst_ty
+ = case (maybeAppDataTyCon inst_ty) of
+ Just (_,tys,_) -> all isTyVarTemplateTy tys
+ Nothing -> case maybeUnpackFunTy inst_ty of
+ Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
+ Nothing -> error "TcInstDecls:is_plain_instance"
+-}
+\end{code}
+
+
+Checking for a decent instance type
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
+it must normally look like: @instance Foo (Tycon a b c ...) ...@
+
+The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
+flag is on, or (2)~the instance is imported (they must have been
+compiled elsewhere). In these cases, we let them go through anyway.
+
+We can also have instances for functions: @instance Foo (a -> b) ...@.
+
+\begin{code}
+scrutiniseInstanceType dfun_name clas inst_tau
+ -- TYCON CHECK
+ | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
+ = failTc (instTypeErr inst_tau)
+
+ -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
+ | not (isLocallyDefined dfun_name)
+ = returnTc (inst_tycon,arg_tys)
+
+ -- TYVARS CHECK
+ | not (opt_GlasgowExts ||
+ (all isTyVarTy arg_tys && null tyvar_dups)
+ )
+ = failTc (instTypeErr inst_tau)
+
+ -- DERIVING CHECK
+ -- It is obviously illegal to have an explicit instance
+ -- for something that we are also planning to `derive'
+ -- Though we can have an explicit instance which is more
+ -- specific than the derived instance
+ | clas `elem` (derivedClasses inst_tycon)
+ && all isTyVarTy arg_tys
+ = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
+
+ | -- CCALL CHECK
+ -- A user declaration of a CCallable/CReturnable instance
+ -- must be for a "boxed primitive" type.
+ (uniqueOf clas == cCallableClassKey && not (ccallable_type inst_tau)) ||
+ (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
+ = failTc (nonBoxedPrimCCallErr clas inst_tau)
+
+ | otherwise
+ = returnTc (inst_tycon,arg_tys)
+
+ where
+ (possible_tycon, arg_tys) = splitAppTys inst_tau
+ inst_tycon_maybe = getTyCon_maybe possible_tycon
+ inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
+ (_, tyvar_dups) = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
+
+-- These conditions come directly from what the DsCCall is capable of.
+-- Totally grotesque. Green card should solve this.
+
+ccallable_type ty = isPrimType ty || -- Allow CCallable Int# etc
+ maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
+ ty `eqTy` stringTy ||
+ byte_arr_thing
+ where
+ byte_arr_thing = case maybeAppDataTyCon ty of
+ Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
+ length data_con_arg_tys == 2 &&
+ maybeToBool maybe_arg2_tycon &&
+ (arg2_tycon == byteArrayPrimTyCon ||
+ arg2_tycon == mutableByteArrayPrimTyCon)
+ where
+ data_con_arg_tys = dataConArgTys data_con ty_args
+ (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
+ maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
+ Just (arg2_tycon,_) = maybe_arg2_tycon
+
+ other -> False
+
+creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
+ -- Or, a data type with a single nullary constructor
+ case (maybeAppDataTyCon ty) of
+ Just (tycon, tys_applied, [data_con])
+ -> isNullaryDataCon data_con
+ other -> False
+\end{code}
+
+\begin{code}
+
+instTypeErr ty sty
+ = case ty of
+ SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
+ TyVarTy tv -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
+ other -> hsep [ptext SLIT("The type"), ppr sty ty, rest_of_msg]
+ where
+ rest_of_msg = ptext SLIT("cannot be used as an instance type")
+
+instBndrErr bndr clas sty
+ = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
+
+derivingWhenInstanceExistsErr clas tycon sty
+ = hang (hsep [ptext SLIT("Deriving class"),
+ ppr sty clas,
+ ptext SLIT("type"), ppr sty tycon])
+ 4 (ptext SLIT("when an explicit instance exists"))
+
+derivingWhenInstanceImportedErr inst_mod clas tycon sty
+ = hang (hsep [ptext SLIT("Deriving class"),
+ ppr sty clas,
+ ptext SLIT("type"), ppr sty tycon])
+ 4 (hsep [ptext SLIT("when an instance declared in module"),
+ pp_mod, ptext SLIT("has been imported")])
+ where
+ pp_mod = hsep [ptext SLIT("module"), ptext inst_mod]
+
+nonBoxedPrimCCallErr clas inst_ty sty
+ = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
+ 4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
+ ppr sty inst_ty])
+
+omitDefaultMethodWarn clas_op clas_name inst_ty sty
+ = hsep [ptext SLIT("Warning: Omitted default method for"),
+ ppr sty clas_op, ptext SLIT("in instance"),
+ text clas_name, pprParendGenType sty inst_ty]
+
+instMethodNotInClassErr occ clas sty
+ = hang (ptext SLIT("Instance mentions a method not in the class"))
+ 4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
+ ppr sty occ])
+
+patMonoBindsCtxt pbind sty
+ = hang (ptext SLIT("In a pattern binding:"))
+ 4 (ppr sty pbind)
+
+methodSigCtxt name ty sty
+ = hang (hsep [ptext SLIT("When matching the definition of class method"),
+ ppr sty name, ptext SLIT("to its signature :") ])
+ 4 (ppr sty ty)
+
+bindSigCtxt sty
+ = ptext SLIT("When checking methods of an instance declaration")
+
+superClassSigCtxt sty
+ = ptext SLIT("When checking superclass constraints of an instance declaration")
projects / ghc-hetmet.git / blobdiff