#include "HsVersions.h"
import HsSyn ( HsDecl(..), InstDecl(..),
- HsBinds(..), MonoBinds(..),
- HsExpr(..), InPat(..), HsLit(..), Sig(..),
+ MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
-import TcHsSyn ( TcMonoBinds,
- maybeBoxedPrimType
- )
+import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, checkFromThisClass )
import TcMonad
-import RnMonad ( RnNameSupply, Fixities )
-import Inst ( Inst, InstOrigin(..),
- newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
+import RnMonad ( RnNameSupply, FixityEnv )
+import Inst ( InstOrigin(..),
+ newDicts, newClassDicts,
+ LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
- tcAddImportedIdInfo, tcInstId
+ tcAddImportedIdInfo, tcInstId, newDFunName
)
import TcInstUtil ( InstInfo(..), classDataCon )
-import TcMonoType ( tcHsTopType )
+import TcMonoType ( tcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcTyVar, zonkTcTyVarBndr )
+import TcType ( 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, dataConId )
-import Maybes ( maybeToBool, catMaybes, expectJust )
+import Class ( classBigSig )
+import Var ( idName, idType )
+import Maybes ( maybeToBool, expectJust )
import MkId ( mkDictFunId )
-import Module ( ModuleName )
-import Name ( isLocallyDefined, NamedThing(..) )
+import Module ( Module )
+import Name ( isLocallyDefined )
import NameSet ( emptyNameSet )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint )
-import SrcLoc ( SrcLoc )
-import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
-import Type ( Type, isUnLiftedType, mkTyVarTys,
- splitSigmaTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy_maybe, unUsgTy,
+import TyCon ( isSynTyCon, tyConDerivings )
+import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy,
+ splitTyConApp_maybe, splitDictTy_maybe,
splitAlgTyConApp_maybe,
- tyVarsOfTypes
+ classesToPreds, classesOfPreds,
+ unUsgTy, tyVarsOfTypes
)
-import Subst ( mkTopTyVarSubst, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
-import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
-import TysWiredIn ( stringTy )
-import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
+import TysWiredIn ( isFFIArgumentTy, isFFIResultTy )
+import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Outputable
\end{code}
\begin{code}
tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
- -> ModuleName -- module name for deriving
- -> Fixities
- -> RnNameSupply -- for renaming derivings
+ -> Module -- Module for deriving
+ -> FixityEnv -- For derivings
+ -> RnNameSupply -- For renaming derivings
-> TcM s (Bag InstInfo,
RenamedHsBinds)
-tcInstDecls1 unf_env decls mod_name fixs rn_name_supply
+tcInstDecls1 unf_env decls mod fixs rn_name_supply
= -- Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 unf_env)
+ mapNF_Tc (tcInstDecl1 mod unf_env)
[inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
let
decl_inst_info = unionManyBags inst_info_bags
-- Handle "derived" instances; note that we only do derivings
-- for things in this module; we ignore deriving decls from
-- interfaces!
- tcDeriving mod_name fixs rn_name_supply decl_inst_info
+ tcDeriving mod fixs rn_name_supply decl_inst_info
`thenTc` \ (deriv_inst_info, deriv_binds) ->
let
returnTc (full_inst_info, deriv_binds)
-tcInstDecl1 :: ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
-tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc)
+tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc emptyBag) $
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'
- (clas, inst_tys) = case splitDictTy_maybe dict_ty of
- Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
- Just pair -> pair
+ constr = classesOfPreds theta
+ (clas, inst_tys) = case splitDictTy_maybe dict_ty of
+ Just ct -> ct
+ Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
in
- -- Check for respectable instance type, and context
- -- but only do this for non-imported instance decls.
- -- Imported ones should have been checked already, and may indeed
- -- contain something illegal in normal Haskell, notably
- -- instance CCallable [Char]
- (if isLocallyDefined dfun_name then
- scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
- mapNF_Tc scrutiniseInstanceConstraint theta
- else
- returnNF_Tc []
- ) `thenNF_Tc_`
-
- -- Make the dfun id
- let
- dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
-
- -- Add info from interface file
- final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
- in
- returnTc (unitBag (InstInfo clas tyvars inst_tys theta
- final_dfun_id
- binds src_loc uprags))
+ (case maybe_dfun_name of
+ Nothing -> -- A source-file instance declaration
+
+ -- Check for respectable instance type, and context
+ -- but only do this for non-imported instance decls.
+ -- 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 constr `thenNF_Tc_`
+
+ -- Make the dfun id and return it
+ newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
+ returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys constr)
+
+ Just dfun_name -> -- An interface-file instance declaration
+ -- Make the dfun id and add info from interface file
+ let
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
+ in
+ returnNF_Tc (tcAddImportedIdInfo unf_env dfun_id)
+ ) `thenNF_Tc` \ dfun_id ->
+
+ returnTc (unitBag (InstInfo clas tyvars inst_tys constr dfun_id binds src_loc uprags))
\end{code}
| not (isLocallyDefined dfun_id)
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
-{-
- -- I deleted this "optimisation" because when importing these
- -- instance decls the renamer would look for the dfun bindings and they weren't there.
- -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
- -- even though it's never used.
-
- -- This case deals with CCallable etc, which don't need any bindings
- | isNoDictClass clas
- = returnNF_Tc (emptyLIE, EmptyBinds)
--}
-
| otherwise
= -- Prime error recovery
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc locn $
+ -- Check that all the method bindings come from this class
+ checkFromThisClass clas monobinds `thenNF_Tc_`
+
-- Instantiate the instance decl with tc-style type variables
tcInstId dfun_id `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
origin = InstanceDeclOrigin
- (class_tyvars, sc_theta, sc_sel_ids, op_items) = classBigSig clas
+ (class_tyvars, sc_theta, _, op_items) = classBigSig clas
dm_ids = [dm_id | (_, dm_id, _) <- op_items]
-- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta
+ inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta
-- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+ sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
in
-- Create dictionary Ids from the specified instance contexts.
- newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
+ newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
- newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
- newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
-
- -- Check that all the method bindings come from this class
- checkFromThisClass clas op_items monobinds `thenNF_Tc_`
+ newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
+ newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
- mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta'
- monobinds uprags True)
+ mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
+ (classesToPreds inst_decl_theta')
+ monobinds uprags True)
op_items
)) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
-- 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
-- mention the constructor, which doesn't exist for CCallable, CReturnable
-- Hardly beautiful, but only three extra lines.
HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
- (HsLitOut (HsString msg) stringTy)
+ (HsLit (HsString msg))
| otherwise -- The common case
- = foldl HsApp (TyApp (HsVar (dataConId dict_constr)) inst_tys')
- (map HsVar (sc_dict_ids ++ meth_ids))
+ = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- it means that the special cases (e.g. dictionary with only one
- -- member) are dealt with by the common MkId.mkDataConId code rather
+ -- member) are dealt with by the common MkId.mkDataConWrapId code rather
-- than needing to be repeated here.
where
| 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}
instConstraintErr clas tys
- = hang (ptext SLIT("Illegal constaint") <+>
+ = hang (ptext SLIT("Illegal constraint") <+>
quotes (pprConstraint clas tys) <+>
ptext SLIT("in instance context"))
4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
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