\section[TcInstDecls]{Typechecking instance declarations}
\begin{code}
-module TcInstDcls (
- tcInstDecls1,
- tcInstDecls2
- ) where
+module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
#include "HsVersions.h"
import HsSyn ( HsDecl(..), InstDecl(..),
HsBinds(..), MonoBinds(..),
HsExpr(..), InPat(..), HsLit(..), Sig(..),
- collectMonoBinders, andMonoBindList
+ andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
import TcHsSyn ( TcMonoBinds,
maybeBoxedPrimType
)
-import TcBinds ( tcPragmaSigs )
-import TcClassDcl ( tcMethodBind, badMethodErr )
+import TcBinds ( tcSpecSigs )
+import TcClassDcl ( tcMethodBind, checkFromThisClass )
import TcMonad
-import RnMonad ( RnNameSupply )
+import RnMonad ( RnNameSupply, Fixities )
import Inst ( Inst, InstOrigin(..),
- newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
+ newDicts, newClassDicts,
+ LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId
import TcType ( TcTyVar, zonkTcTyVarBndr )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
- foldBag, bagToList, Bag
+ foldBag, Bag
)
import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
-import Var ( setIdInfo, idName, idType, Id, TyVar )
-import DataCon ( isNullaryDataCon, dataConArgTys, dataConId )
+import Var ( idName, idType, Id, TyVar )
+import DataCon ( isNullaryDataCon, splitProductType_maybe, dataConId )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
-import Name ( nameOccName, isLocallyDefined, Module,
- NamedThing(..)
- )
-import PrelVals ( eRROR_ID )
+import Module ( ModuleName )
+import Name ( isLocallyDefined, NamedThing(..) )
+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,
- splitAlgTyConApp_maybe,
- tyVarsOfTypes, substTopTheta
+ getClassTys_maybe, splitAlgTyConApp_maybe,
+ classesToPreds, classesOfPreds,
+ unUsgTy, tyVarsOfTypes
)
-import VarEnv ( zipVarEnv )
+import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
\begin{code}
tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
- -> Module -- module name for deriving
+ -> ModuleName -- module name for deriving
+ -> Fixities
-> RnNameSupply -- for renaming derivings
-> TcM s (Bag InstInfo,
RenamedHsBinds)
-tcInstDecls1 unf_env decls mod_name rn_name_supply
+tcInstDecls1 unf_env decls mod_name fixs rn_name_supply
= -- Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 unf_env mod_name)
+ mapNF_Tc (tcInstDecl1 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 rn_name_supply decl_inst_info
+ tcDeriving mod_name fixs rn_name_supply decl_inst_info
`thenTc` \ (deriv_inst_info, deriv_binds) ->
let
returnTc (full_inst_info, deriv_binds)
-tcInstDecl1 :: ValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
-tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
+tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc emptyBag) $
tcAddSrcLoc src_loc $
tcHsTopType 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
-- instance CCallable [Char]
(if isLocallyDefined dfun_name then
scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
- mapNF_Tc scrutiniseInstanceConstraint theta
+ mapNF_Tc scrutiniseInstanceConstraint constr
else
returnNF_Tc []
) `thenNF_Tc_`
- -- Make the dfun id and constant-method ids
+ -- Make the dfun id
let
- dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
-- Add info from interface file
final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
in
- returnTc (unitBag (InstInfo clas tyvars inst_tys theta
+ returnTc (unitBag (InstInfo clas tyvars inst_tys constr
final_dfun_id
binds src_loc uprags))
\end{code}
origin = InstanceDeclOrigin
- (class_tyvars,
- sc_theta, sc_sel_ids,
- op_sel_ids, defm_ids) = classBigSig clas
+ (class_tyvars, sc_theta, sc_sel_ids, op_items) = classBigSig clas
+
+ dm_ids = [dm_id | (_, dm_id, _) <- op_items]
-- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substTopTheta (zipVarEnv 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' = substTopTheta (zipVarEnv 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]) ->
+ newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
+ newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
-- Check that all the method bindings come from this class
- let
- check_from_this_class (bndr, loc)
- | nameOccName bndr `elem` sel_names = returnNF_Tc ()
- | otherwise = tcAddSrcLoc loc $
- addErrTc (badMethodErr bndr clas)
- sel_names = map getOccName op_sel_ids
- bndrs = bagToList (collectMonoBinders monobinds)
- in
- mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
+ checkFromThisClass clas op_items monobinds `thenNF_Tc_`
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
- tcExtendGlobalValEnv (catMaybes defm_ids) (
+ 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)
- (op_sel_ids `zip` defm_ids)
+ 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) ->
- -- Deal with SPECIALISE instance pragmas
+ -- Deal with SPECIALISE instance pragmas by making them
+ -- look like SPECIALISE pragmas for the dfun
let
- dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
+ dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
in
tcExtendGlobalValEnv [dfun_id] (
- tcPragmaSigs dfun_prags
- ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
+ tcSpecSigs dfun_prags
+ ) `thenTc` \ (prag_binds, prag_lie) ->
-- Check the overloading constraints of the methods and superclasses
-- emit an error message. This in turn means that we don't
-- mention the constructor, which doesn't exist for CCallable, CReturnable
-- Hardly beautiful, but only three extra lines.
- HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
+ HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
(HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
dict_bind = VarMonoBind this_dict_id dict_rhs
method_binds = andMonoBindList method_binds_s
- final_dfun_id = setIdInfo dfun_id (prag_info_fn (idName dfun_id))
- -- Pretty truesome
main_bind
= AbsBinds
zonked_inst_tyvars
dfun_arg_dicts_ids
- [(inst_tyvars', final_dfun_id, this_dict_id)]
+ [(inst_tyvars', dfun_id, this_dict_id)]
+ emptyNameSet -- No inlines (yet)
(lie_binds1 `AndMonoBinds`
lie_binds2 `AndMonoBinds`
method_binds `AndMonoBinds`
ty == stringTy ||
byte_arr_thing
where
- byte_arr_thing = case splitAlgTyConApp_maybe 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)
+ 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
- data_con_arg_tys = dataConArgTys data_con ty_args
- (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
- maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
- Just (arg2_tycon,_) = maybe_arg2_tycon
+ maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
+ Just (arg3_tycon,_) = maybe_arg3_tycon
other -> False
\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)"))
projects / ghc-hetmet.git / blobdiff