import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
-import TcType ( tcInstType )
+import TcMType ( tcInstType, tcInstTyVars )
+import TcType ( tcSplitDFunTy, tcIsTyVarTy, tcSplitTyConApp_maybe,
+ tyVarsOfTypes, mkClassPred, mkTyVarTy,
+ isTyVarClassPred, inheritablePred
+ )
import Inst ( InstOrigin(..),
newDicts, instToId,
LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcLookupClass,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
- simpleInstInfoTy, newDFunName, tcExtendTyVarEnv,
+ simpleInstInfoTy, newDFunName,
isLocalThing,
)
import InstEnv ( InstEnv, extendInstEnv )
ModDetails(..), PackageInstEnv, PersistentRenamerState
)
+import Subst ( substTy, substTheta )
import DataCon ( classDataCon )
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
-import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
+import NameSet ( unitNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
import PprType ( pprClassPred, pprPred )
import TyCon ( TyCon, isSynTyCon )
-import Type ( splitDFunTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy,
- splitForAllTys,
- tyVarsOfTypes, mkClassPred, mkTyVarTy,
- isTyVarClassPred, inheritablePred
- )
import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
+import ForeignCall ( Safety(..) )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Name ( Name )
import SrcLoc ( SrcLoc )
imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId)
imported_inst_info
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
- in
+ in
+
+-- pprTrace "tcInstDecls" (vcat [ppr imported_dfuns, ppr hst_dfuns]) $
+
addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 ->
addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
-addInstDFuns dfuns infos
+addInstDFuns inst_env dfuns
= getDOptsTc `thenTc` \ dflags ->
let
- (inst_env', errs) = extendInstEnv dflags dfuns infos
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
in
addErrsTc errs `thenNF_Tc_`
+ traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) `thenTc_`
returnTc inst_env'
+ where
+ pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
\end{code}
\begin{code}
tcAddSrcLoc src_loc $
-- Type-check all the stuff before the "where"
+ traceTc (text "Starting inst" <+> ppr poly_ty) `thenTc_`
tcAddErrCtxt (instDeclCtxt poly_ty) (
tcHsSigType poly_ty
) `thenTc` \ poly_ty' ->
let
- (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
+ (tyvars, theta, clas, inst_tys) = tcSplitDFunTy poly_ty'
in
+ traceTc (text "Check validity") `thenTc_`
(case maybe_dfun_name of
Nothing -> -- A source-file instance declaration
checkInstValidity dflags theta clas inst_tys `thenTc_`
-- Make the dfun id and return it
+ traceTc (text "new name") `thenTc_`
newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
returnNF_Tc (True, dfun_name)
returnNF_Tc (False, dfun_name)
) `thenNF_Tc` \ (is_local, dfun_name) ->
+ traceTc (text "Name" <+> ppr dfun_name) `thenTc_`
let
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
in
tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $
-- Instantiate the instance decl with tc-style type variables
- tcInstType (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
- (clas, inst_tys') = splitDictTy dict_ty'
- origin = InstanceDeclOrigin
+ (inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
+ in
+ tcInstTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
+ let
+ inst_tys' = map (substTy tenv) inst_tys
+ dfun_theta' = substTheta tenv dfun_theta
+ origin = InstanceDeclOrigin
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
-- Find any definitions in monobinds that aren't from the class
bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
-
- -- The type variable from the dict fun actually scope
- -- over the bindings. They were gotten from
- -- the original instance declaration
- (inst_tyvars, _) = splitForAllTys (idType dfun_id)
in
-- Check that all the method bindings come from this class
mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
+ -- The type variable from the dict fun actually scope
+ -- over the bindings. They were gotten from
+ -- the original instance declaration
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
-- 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
+ 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
+ all tcIsTyVarTy 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
)
(first_inst_tau : _) = inst_taus
-- Stuff for algebraic or -> type
- maybe_tycon_app = splitTyConApp_maybe first_inst_tau
+ maybe_tycon_app = tcSplitTyConApp_maybe first_inst_tau
Just (tycon, arg_tys) = maybe_tycon_app
- ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
+ ccallable_type dflags ty = isFFIArgumentTy dflags PlayRisky ty
creturnable_type ty = isFFIImportResultTy dflags ty
check_tyvars dflags clas inst_taus
-- Check that at least one isn't a type variable
-- unless -fallow-undecideable-instances
| dopt Opt_AllowUndecidableInstances dflags = []
- | not (all isTyVarTy inst_taus) = []
+ | not (all tcIsTyVarTy inst_taus) = []
| otherwise = [the_err]
where
the_err = instTypeErr clas inst_taus msg
projects / ghc-hetmet.git / blobdiff