andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
-import TcHsSyn ( TcMonoBinds, mkHsConApp,
- maybeBoxedPrimType
- )
+import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, checkFromThisClass )
import TcMonad
-import RnMonad ( RnNameSupply, Fixities )
+import RnMonad ( RnNameSupply, FixityEnv )
import Inst ( Inst, InstOrigin(..),
newDicts, newClassDicts,
LIE, emptyLIE, plusLIE, plusLIEs )
tcAddImportedIdInfo, tcInstId
)
import TcInstUtil ( InstInfo(..), classDataCon )
-import TcMonoType ( tcHsTopType )
+import TcMonoType ( tcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcTyVar, zonkTcTyVarBndr )
+import TcType ( TcTyVar, zonkTcSigTyVars )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
foldBag, Bag
import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
import Var ( idName, idType, Id, TyVar )
-import DataCon ( isNullaryDataCon, splitProductType_maybe )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
import Module ( ModuleName )
import NameSet ( emptyNameSet )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint )
-import SrcLoc ( SrcLoc )
import TyCon ( isSynTyCon, tyConDerivings )
import Type ( Type, isUnLiftedType, mkTyVarTys,
splitSigmaTy, isTyVarTy,
)
import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
-import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
-import TysWiredIn ( stringTy )
-import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
+import TysWiredIn ( stringTy, isFFIArgumentTy, isFFIResultTy )
+import Unique ( Unique, cCallableClassKey, cReturnableClassKey, hasKey, Uniquable(..) )
import Outputable
\end{code}
tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
-> ModuleName -- module name for deriving
- -> Fixities
+ -> FixityEnv
-> RnNameSupply -- for renaming derivings
-> TcM s (Bag InstInfo,
RenamedHsBinds)
tcAddSrcLoc src_loc $
-- Type-check all the stuff before the "where"
- tcHsTopType poly_ty `thenTc` \ poly_ty' ->
+ tcHsSigType poly_ty `thenTc` \ poly_ty' ->
let
(tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
constr = classesOfPreds theta
-- tcMethodBind has checked that the class_tyvars havn't
-- been unified with each other or another type, but we must
- -- still zonk them
- mapNF_Tc zonkTcTyVarBndr inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
+ -- still zonk them before passing them to tcSimplifyAndCheck
+ zonkTcSigTyVars inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
let
inst_tyvars_set = mkVarSet zonked_inst_tyvars
| otherwise = addErrTc (instConstraintErr clas tys)
scrutiniseInstanceHead clas inst_taus
- | -- CCALL CHECK (a).... urgh!
- -- To verify that a user declaration of a CCallable/CReturnable
- -- instance is OK, we must be able to see the constructor(s)
- -- of the instance type (see next guard.)
- --
- -- We flag this separately to give a more precise error msg.
- --
- (getUnique clas == cCallableClassKey || getUnique clas == cReturnableClassKey)
- && is_alg_tycon_app && not constructors_visible
- = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
-
- | -- CCALL CHECK (b)
+ | -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
- (getUnique clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
- (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
+ (clas `hasKey` cCallableClassKey && not (ccallable_type first_inst_tau)) ||
+ (clas `hasKey` cReturnableClassKey && not (creturnable_type first_inst_tau))
= addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
-- DERIVING CHECK
Just (tycon, arg_tys) = maybe_tycon_app
-- Stuff for an *algebraic* data type
- alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
- -- The "Alg" part looks through synonyms
- is_alg_tycon_app = maybeToBool alg_tycon_app_maybe
- Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
-
- constructors_visible = not (null data_cons)
+ alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
+ -- The "Alg" part looks through synonyms
+ Just (alg_tycon, _, _) = alg_tycon_app_maybe
-
--- These conditions come directly from what the DsCCall is capable of.
--- Totally grotesque. Green card should solve this.
-
-ccallable_type ty = isUnLiftedType ty || -- Allow CCallable Int# etc
- maybeToBool (maybeBoxedPrimType ty) || -- Ditto Int etc
- ty == stringTy ||
- byte_arr_thing
- where
- byte_arr_thing = case splitProductType_maybe ty of
- Just (tycon, ty_args, data_con, [data_con_arg_ty1, data_con_arg_ty2, data_con_arg_ty3]) ->
- maybeToBool maybe_arg3_tycon &&
- (arg3_tycon == byteArrayPrimTyCon ||
- arg3_tycon == mutableByteArrayPrimTyCon)
- where
- maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
- Just (arg3_tycon,_) = maybe_arg3_tycon
-
- other -> False
-
-creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
- -- Or, a data type with a single nullary constructor
- case (splitAlgTyConApp_maybe ty) of
- Just (tycon, tys_applied, [data_con])
- -> isNullaryDataCon data_con
- other -> False
+ccallable_type ty = isFFIArgumentTy False {- Not safe call -} ty
+creturnable_type ty = isFFIResultTy ty
\end{code}
\begin{code}
4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
ppr inst_ty])
-{-
- Declaring CCallable & CReturnable instances in a module different
- from where the type was defined. Caused by importing data type
- abstractly (either programmatically or by the renamer being over-eager
- in its pruning.)
--}
-invisibleDataConPrimCCallErr clas inst_ty
- = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
- ptext SLIT("not visible when checking"),
- quotes (ppr clas), ptext SLIT("instance")])
- 4 (hsep [text "(Try either importing", ppr inst_ty,
- text "non-abstractly or compile using -fno-prune-tydecls ..)"])
-
methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
\end{code}
projects / ghc-hetmet.git / blobdiff