X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=012b723b590c77f64c36b9aca64b32d829204654;hb=6954d21089c19939e9632ffd5a183a2eb053b558;hp=0d54c22294dbc440bd03db7da7a689f71a9fc9a0;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 0d54c22..012b723 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,75 +9,98 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, - processInstBinds + tcMethodBind ) where -import Ubiq +IMP_Ubiq() -import HsSyn ( InstDecl(..), FixityDecl, Sig(..), - SpecInstSig(..), HsBinds(..), Bind(..), - MonoBinds(..), GRHSsAndBinds, Match, +import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl, + FixityDecl, IfaceSig, Sig(..), + SpecInstSig(..), HsBinds(..), + MonoBinds(..), GRHSsAndBinds(..), GRHS(..), Match, InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Stmt, Qual, ArithSeqInfo, Fake, - PolyType(..), MonoType ) -import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..), - RenamedInstDecl(..), RenamedFixityDecl(..), - RenamedSig(..), RenamedSpecInstSig(..), - RnName(..){-incl instance Outputable-} + Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity, + HsType(..), HsTyVar, + SYN_IE(RecFlag), recursive, nonRecursive, collectMonoBinders, + andMonoBinds ) -import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), - TcMonoBinds(..), TcExpr(..), tcIdType, +import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), + SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), SYN_IE(RenamedHsExpr), + SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl) + ) +import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), + SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType, mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) - +import TcBinds ( tcBindWithSigs, TcSigInfo(..) ) import TcMonad -import GenSpecEtc ( checkSigTyVars ) -import Inst ( Inst, InstOrigin(..), InstanceMapper(..), - newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) -import TcBinds ( tcPragmaSigs ) +import RnMonad ( SYN_IE(RnNameSupply) ) +import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper), + instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE ) +import TcBinds ( tcPragmaSigs, checkSigTyVars ) +import PragmaInfo ( PragmaInfo(..) ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId ) +import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars ) +import SpecEnv ( SpecEnv ) import TcGRHSs ( tcGRHSsAndBinds ) import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcKind ( TcKind, unifyKind ) import TcMatches ( tcMatchesFun ) -import TcMonoType ( tcContext, tcMonoTypeKind ) -import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas ) -import TcType ( TcType(..), TcTyVar(..), - tcInstSigTyVars, tcInstType, tcInstTheta +import TcMonoType ( tcTyVarScope, tcContext, tcHsTypeKind ) +import TcSimplify ( tcSimplifyAndCheck ) +import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), + tcInstSigTyVars, tcInstType, tcInstSigTcType, + tcInstTheta, tcInstTcType, tcInstSigType ) -import Unify ( unifyTauTy ) +import Unify ( unifyTauTy, unifyTauTyLists ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, - concatBag, foldBag, bagToList ) -import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude, + concatBag, foldBag, bagToList, listToBag, + Bag ) +import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals, opt_OmitDefaultInstanceMethods, - opt_SpecialiseOverloaded ) + opt_SpecialiseOverloaded + ) import Class ( GenClass, GenClassOp, - isCcallishClass, getClassBigSig, - getClassOps, getClassOpLocalType ) -import CoreUtils ( escErrorMsg ) -import Id ( GenId, idType, isDefaultMethodId_maybe ) + classBigSig, classOps, classOpLocalType, + classDefaultMethodId, SYN_IE(Class) + ) +import Id ( GenId, idType, isDefaultMethodId_maybe, + isNullaryDataCon, dataConArgTys, SYN_IE(Id) ) import ListSetOps ( minusList ) -import Maybes ( maybeToBool, expectJust ) -import Name ( getLocalName, getOrigName ) -import PrelInfo ( pAT_ERROR_ID ) +import Maybes ( maybeToBool, expectJust, seqMaybe ) +import Name ( nameOccName, getOccString, occNameString, moduleString, getOccName, + isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module), + NamedThing(..) + ) +import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID ) import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, - pprParendGenType ) + pprParendGenType + ) import PprStyle +import Outputable +import SrcLoc ( SrcLoc, noSrcLoc ) import Pretty -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) -import TyCon ( derivedFor ) -import Type ( GenType(..), ThetaType(..), mkTyVarTys, - splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeBoxedPrimType ) -import TyVar ( GenTyVar, mkTyVarSet ) +import TyCon ( isSynTyCon, derivedFor ) +import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType, + splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy, + getTyCon_maybe, maybeAppTyCon, SYN_IE(Type), + maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy + ) +import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList, + mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) ) +import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy ) -import Unique ( Unique ) -import Util ( panic ) +import Unique ( Unique, cCallableClassKey, cReturnableClassKey ) +import UniqFM ( Uniquable(..) ) +import Util ( zipEqual, panic, pprPanic, pprTrace +#if __GLASGOW_HASKELL__ < 202 + , trace +#endif + ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -154,99 +177,70 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. \end{enumerate} \begin{code} -tcInstDecls1 :: Bag RenamedInstDecl - -> [RenamedSpecInstSig] +tcInstDecls1 :: [RenamedHsDecl] -> Module -- module name for deriving - -> GlobalNameMappers -- renamer fns for deriving - -> [RenamedFixityDecl] -- fixities for deriving + -> RnNameSupply -- for renaming derivings -> TcM s (Bag InstInfo, RenamedHsBinds, - PprStyle -> Pretty) + PprStyle -> Doc) -tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities +tcInstDecls1 decls mod_name rn_name_supply = -- Do the ordinary instance declarations - mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls - `thenNF_Tc` \ inst_info_bags -> + mapNF_Tc (tcInstDecl1 mod_name) + [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags -> let - decl_inst_info = concatBag inst_info_bags + decl_inst_info = unionManyBags inst_info_bags in -- Handle "derived" instances; note that we only do derivings -- for things in this module; we ignore deriving decls from -- interfaces! We pass fixities, because they may be used -- in deriving Read and Show. - tcDeriving mod_name renamer_name_funs decl_inst_info fixities + tcDeriving mod_name rn_name_supply decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) -> let - inst_info = deriv_inst_info `unionBags` decl_inst_info - in -{- LATER - -- Handle specialise instance pragmas - tcSpecInstSigs inst_info specinst_sigs - `thenTc` \ spec_inst_info -> --} - let - spec_inst_info = emptyBag -- For now - - full_inst_info = inst_info `unionBags` spec_inst_info + full_inst_info = deriv_inst_info `unionBags` decl_inst_info in returnTc (full_inst_info, deriv_binds, ddump_deriv) -tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) +tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) -tcInstDecl1 mod_name - (InstDecl class_name - poly_ty@(HsForAllTy tyvar_names context inst_ty) - binds - from_here inst_mod uprags pragmas src_loc) +tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc) = -- Prime error recovery, set source location recoverNF_Tc (returnNF_Tc emptyBag) $ tcAddSrcLoc src_loc $ -- Look things up - tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) -> + tcLookupClass class_name `thenTc` \ (clas_kind, clas) -> - let - de_rn (RnName n) = n - in -- Typecheck the context and instance type - tcTyVarScope (map de_rn tyvar_names) (\ tyvars -> + tcTyVarScope tyvar_names (\ tyvars -> tcContext context `thenTc` \ theta -> - tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) -> + tcHsTypeKind inst_ty `thenTc` \ (tau_kind, tau) -> unifyKind clas_kind tau_kind `thenTc_` returnTc (tyvars, theta, tau) ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) -> -- Check for respectable instance type - scrutiniseInstanceType from_here clas inst_tau + scrutiniseInstanceType dfun_name clas inst_tau `thenTc` \ (inst_tycon,arg_tys) -> - -- Deal with the case where we are deriving - -- and importing the same instance - if (not from_here && (clas `derivedFor` inst_tycon) - && all isTyVarTy arg_tys) - then - if not opt_CompilingPrelude && maybeToBool inst_mod && - mod_name == expectJust "inst_mod" inst_mod - then - -- Imported instance came from this module; - -- discard and derive fresh instance - returnTc emptyBag - else - -- Imported instance declared in another module; - -- report duplicate instance error - failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon) - else - -- Make the dfun id and constant-method ids - mkInstanceRelatedIds from_here inst_mod pragmas - clas inst_tyvars inst_tau inst_theta uprags - `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + mkInstanceRelatedIds dfun_name + clas inst_tyvars inst_tau inst_theta + `thenNF_Tc` \ (dfun_id, dfun_theta) -> returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta - dfun_theta dfun_id const_meth_ids - binds from_here inst_mod src_loc uprags)) + dfun_theta dfun_id + binds src_loc uprags)) + where + (tyvar_names, context, dict_ty) = case poly_ty of + HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty) + other -> ([], [], poly_ty) + (class_name, inst_ty) = case dict_ty of + MonoDictTy cls ty -> (cls,ty) + other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty) \end{code} @@ -337,16 +331,27 @@ is the @dfun_theta@ below. First comes the easy case of a non-local instance decl. \begin{code} -tcInstDecl2 :: InstInfo - -> NF_TcM s (LIE s, TcHsBinds s) - -tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _) - = returnNF_Tc (emptyLIE, EmptyBinds) +tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcHsBinds s) tcInstDecl2 (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta - dfun_id const_meth_ids monobinds - True{-here-} inst_mod locn uprags) + dfun_id monobinds + locn uprags) + | not (isLocallyDefined dfun_id) + = returnNF_Tc (emptyLIE, EmptyBinds) + +{- + -- 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, EmptyBinds)) $ tcAddSrcLoc locn $ @@ -354,17 +359,16 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty -- Get the class signature tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) -> let + origin = InstanceDeclOrigin (class_tyvar, super_classes, sc_sel_ids, - class_ops, op_sel_ids, defm_ids) = getClassBigSig clas + class_ops, op_sel_ids, defm_ids) = classBigSig clas in tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' -> tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' -> tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' -> let - sc_theta' = super_classes `zip` (repeat inst_ty') - origin = InstanceDeclOrigin - mk_method sel_id = newMethodId sel_id inst_ty' origin locn + sc_theta' = super_classes `zip` repeat inst_ty' in -- Create dictionary Ids from the specified instance contexts. newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> @@ -372,38 +376,34 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> - -- Create method variables - mapAndUnzipNF_Tc mk_method op_sel_ids `thenNF_Tc` \ (meth_insts_s, meth_ids) -> - - -- Collect available Insts - let - avail_insts -- These insts are in scope; quite a few, eh? - = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) - - mk_method_expr - = if opt_OmitDefaultInstanceMethods then - makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod - else - makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id - in - processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds - `thenTc` \ (insts_needed, method_mbinds) -> + -- Check the method bindings let - -- Create the dict and method binds - dict_bind - = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids) - - dict_and_method_binds - = dict_bind `AndMonoBinds` method_mbinds - inst_tyvars_set' = mkTyVarSet inst_tyvars' + check_from_this_class (bndr, loc) + | nameOccName bndr `elem` sel_names = returnTc () + | otherwise = recoverTc (returnTc ()) $ + tcAddSrcLoc loc $ + failTc (instBndrErr bndr clas) + sel_names = map getOccName op_sel_ids in + mapTc check_from_this_class (bagToList (collectMonoBinders monobinds)) `thenTc_` + tcExtendGlobalTyVars inst_tyvars_set' ( + mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' monobinds) + (op_sel_ids `zip` [0..]) + ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> + -- Check the overloading constraints of the methods and superclasses + let + (meth_lies, meth_ids) = unzip meth_lies_w_ids + avail_insts -- These insts are in scope; quite a few, eh? + = this_dict `plusLIE` dfun_arg_dicts `plusLIE` unionManyBags meth_lies + in tcAddErrCtxt (bindSigCtxt meth_ids) ( tcSimplifyAndCheck inst_tyvars_set' -- Local tyvars avail_insts - (sc_dicts `unionBags` insts_needed) -- Need to get defns for all these + (sc_dicts `unionBags` + unionManyBags insts_needed_s) -- Need to get defns for all these ) `thenTc` \ (const_lie, super_binds) -> -- Check that we *could* construct the superclass dictionaries, @@ -411,7 +411,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty -- the check ensures that the caller will never have a problem building -- them. tcAddErrCtxt superClassSigCtxt ( - tcSimplifyAndCheck + tcSimplifyAndCheck inst_tyvars_set' -- Local tyvars inst_decl_dicts -- The instance dictionaries available sc_dicts -- The superclass dicationaries reqd @@ -424,147 +424,35 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ] in tcPragmaSigs spec_sigs `thenTc` \ (_, spec_binds, spec_lie) -> + + -- Create the result bindings let - -- Complete the binding group, adding any spec_binds - inst_binds - = AbsBinds + dict_bind = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids) + method_binds = andMonoBinds method_binds_s + + main_bind + = MonoBind ( + AbsBinds inst_tyvars' dfun_arg_dicts_ids - ((this_dict_id, RealId dfun_id) - : (meth_ids `zip` (map RealId const_meth_ids))) - -- const_meth_ids will often be empty - super_binds - (RecBind dict_and_method_binds) - - `ThenBinds` - spec_binds + [(inst_tyvars', RealId dfun_id, this_dict_id)] + (super_binds `AndMonoBinds` + method_binds `AndMonoBinds` + dict_bind)) + [] recursive -- Recursive to play safe in - - returnTc (const_lie `plusLIE` spec_lie, inst_binds) + returnTc (const_lie `plusLIE` spec_lie, + main_bind `ThenBinds` spec_binds) \end{code} -@mkMethodId@ manufactures an id for a local method. -It's rather turgid stuff, because there are two cases: - - (a) For methods with no local polymorphism, we can make an Inst of the - class-op selector function and a corresp InstId; - which is good because then other methods which call - this one will do so directly. - - (b) For methods with local polymorphism, we can't do this. For example, - - class Foo a where - op :: (Num b) => a -> b -> a - - Here the type of the class-op-selector is - - forall a b. (Foo a, Num b) => a -> b -> a - - The locally defined method at (say) type Float will have type - - forall b. (Num b) => Float -> b -> Float - - and the one is not an instance of the other. - - So for these we just make a local (non-Inst) id with a suitable type. - -How disgusting. - -\begin{code} -newMethodId sel_id inst_ty origin loc - = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id) - (_:meth_theta) = sel_theta -- The local theta is all except the - -- first element of the context - in - case sel_tyvars of - -- Ah! a selector for a class op with no local polymorphism - -- Build an Inst for this - [clas_tyvar] -> newMethod origin (RealId sel_id) [inst_ty] - - -- Ho! a selector for a class op with local polymorphism. - -- Just make a suitably typed local id for this - (clas_tyvar:local_tyvars) -> - tcInstType [(clas_tyvar,inst_ty)] - (mkSigmaTy local_tyvars meth_theta sel_tau) - `thenNF_Tc` \ method_ty -> - newLocalId (getLocalName sel_id) method_ty `thenNF_Tc` \ meth_id -> - returnNF_Tc (emptyLIE, meth_id) -\end{code} - -The next function makes a default method which calls the global default method, at -the appropriate instance type. +The next function looks for a method binding; if there isn't one it +manufactures one that just calls the global default method. See the notes under default decls in TcClassDcl.lhs. \begin{code} -makeInstanceDeclDefaultMethodExpr - :: InstOrigin s - -> [TcIdOcc s] - -> [Id] - -> TcType s - -> TcIdOcc s - -> Int - -> NF_TcM s (TcExpr s) - -makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag - = newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) -> - - -- def_op_id = /\ op_tyvars -> \ op_dicts -> - -- defm_id inst_ty op_tyvars this_dict op_dicts - returnNF_Tc ( - mkHsTyLam op_tyvars ( - mkHsDictLam op_dicts ( - mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) - (inst_ty : mkTyVarTys op_tyvars)) - (this_dict : op_dicts) - ))) - where - idx = tag - 1 - meth_id = meth_ids !! idx - defm_id = defm_ids !! idx - (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id) - -makeInstanceDeclNoDefaultExpr - :: InstOrigin s - -> [TcIdOcc s] - -> [Id] - -> TcType s - -> Class - -> Maybe Module - -> Int - -> NF_TcM s (TcExpr s) - -makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag - = newDicts origin op_theta `thenNF_Tc` \ (op_lie, op_dicts) -> - - -- Produce a warning if the default instance method - -- has been omitted when one exists in the class - warnTc (not err_defm_ok) - (omitDefaultMethodWarn clas_op clas_name inst_ty) - `thenNF_Tc_` - returnNF_Tc (mkHsTyLam op_tyvars ( - mkHsDictLam op_dicts ( - HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau]) - (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) - where - idx = tag - 1 - meth_id = meth_ids !! idx - clas_op = (getClassOps clas) !! idx - defm_id = defm_ids !! idx - (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id) - - Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id - - error_msg = "%E" -- => No explicit method for \" - ++ escErrorMsg error_str - - mod_str = case inst_mod of { Nothing -> SLIT("Prelude"); Just m -> m } - - error_str = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "." - ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "." - ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\"" - - (_, clas_name) = getOrigName clas +getDefmRhs :: Class -> Int -> RenamedHsExpr +getDefmRhs clas idx = HsVar (getName (classDefaultMethodId clas idx)) \end{code} @@ -574,169 +462,50 @@ makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag %* * %************************************************************************ -@processInstBinds@ returns a @MonoBinds@ which binds -all the method ids (which are passed in). It is used - - both for instance decls, - - and to compile the default-method declarations in a class decl. - -Any method ids which don't have a binding have a suitable default -binding created for them. The actual right-hand side used is -created using a function which is passed in, because the right thing to -do differs between instance and class decls. - \begin{code} -processInstBinds - :: (Int -> NF_TcM s (TcExpr s)) -- Function to make default method - -> [TcTyVar s] -- Tyvars for this instance decl - -> LIE s -- available Insts - -> [TcIdOcc s] -- Local method ids in tag order - -- (instance tyvars are free in their types) - -> RenamedMonoBinds - -> TcM s (LIE s, -- These are required - TcMonoBinds s) - -processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds - = - -- Process the explicitly-given method bindings - processInstBinds1 inst_tyvars avail_insts method_ids monobinds - `thenTc` \ (tags, insts_needed_in_methods, method_binds) -> - - -- Find the methods not handled, and make default method bindings for them. +tcMethodBind + :: (Int -> RenamedHsExpr) -- Function mapping a tag to default RHS + -> TcType s -- Instance type + -> RenamedMonoBinds -- Method binding + -> (Id, Int) -- Selector ID (and its 0-indexed tag) + -- for which binding is wanted + -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) + +tcMethodBind deflt_fn inst_ty meth_binds (sel_id, idx) + = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId meth_id) -> + tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') -> let - unmentioned_tags = [1.. length method_ids] `minusList` tags - in - mapNF_Tc mk_default_method unmentioned_tags - `thenNF_Tc` \ default_bind_list -> - - returnTc (insts_needed_in_methods, - foldr AndMonoBinds method_binds default_bind_list) - where - -- From a tag construct us the passed-in function to construct - -- the binding for the default method - mk_default_method tag = mk_default_method_rhs tag `thenNF_Tc` \ rhs -> - returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs) -\end{code} + meth_name = getName meth_id + default_bind = PatMonoBind (VarPatIn meth_name) + (GRHSsAndBindsIn [OtherwiseGRHS (deflt_fn idx) noSrcLoc] EmptyBinds) + noSrcLoc -\begin{code} -processInstBinds1 - :: [TcTyVar s] -- Tyvars for this instance decl - -> LIE s -- available Insts - -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free), - -> RenamedMonoBinds - -> TcM s ([Int], -- Class-op tags accounted for - LIE s, -- These are required - TcMonoBinds s) - -processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds - = returnTc ([], emptyLIE, EmptyMonoBinds) - -processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) - = processInstBinds1 inst_tyvars avail_insts method_ids mb1 - `thenTc` \ (op_tags1,dicts1,method_binds1) -> - processInstBinds1 inst_tyvars avail_insts method_ids mb2 - `thenTc` \ (op_tags2,dicts2,method_binds2) -> - returnTc (op_tags1 ++ op_tags2, - dicts1 `unionBags` dicts2, - AndMonoBinds method_binds1 method_binds2) -\end{code} - -\begin{code} -processInstBinds1 inst_tyvars avail_insts method_ids mbind - = - -- Find what class op is being defined here. The complication is - -- that we could have a PatMonoBind or a FunMonoBind. If the - -- former, it should only bind a single variable, or else we're in - -- trouble (I'm not sure what the static semantics of methods - -- defined in a pattern binding with multiple patterns is!) - -- Renamer has reduced us to these two cases. - let - (op,locn) = case mbind of - FunMonoBind op _ _ locn -> (op, locn) - PatMonoBind (VarPatIn op) _ locn -> (op, locn) + (op_name, op_bind) = case go (getOccName sel_id) meth_binds of + Just stuff -> stuff + Nothing -> (meth_name, default_bind) - occ = getLocalName op - origin = InstanceDeclOrigin + (theta', tau') = splitRhoTy rho_ty' + sig_info = TySigInfo op_name meth_id tyvars' theta' tau' noSrcLoc in - tcAddSrcLoc locn $ + tcBindWithSigs [op_name] op_bind [sig_info] + nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) -> - -- Make a method id for the method - let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-} - method_id = method_ids !! (tag-1) + returnTc (binds, insts, meth) + where + origin = InstanceDeclOrigin -- Poor - method_ty = tcIdType method_id - (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty - in - newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> - - case (method_tyvars, method_dict_ids) of - - ([],[]) -> -- The simple case; no local polymorphism or overloading in the method - - -- Type check the method itself - tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) -> - returnTc ([tag], lieIop, mbind') - - other -> -- It's a locally-polymorphic and/or overloaded method; UGH! - - -- Make a new id for (a) the local, non-overloaded method - -- and (b) the locally-overloaded method - -- The latter is needed just so we can return an AbsBinds wrapped - -- up inside a MonoBinds. - - newLocalId occ method_tau `thenNF_Tc` \ local_id -> - newLocalId occ method_ty `thenNF_Tc` \ copy_id -> - let - inst_method_tyvars = inst_tyvars ++ method_tyvars - in - -- Typecheck the method - tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) -> - - -- Check the overloading part of the signature. - -- Simplify everything fully, even though some - -- constraints could "really" be left to the next - -- level out. The case which forces this is - -- - -- class Foo a where { op :: Bar a => a -> a } - -- - -- Here we must simplify constraints on "a" to catch all - -- the Bar-ish things. - tcAddErrCtxt (methodSigCtxt op method_ty) ( - tcSimplifyAndCheck - (mkTyVarSet inst_method_tyvars) - (method_dicts `plusLIE` avail_insts) - lieIop - ) `thenTc` \ (f_dicts, dict_binds) -> - - returnTc ([tag], - f_dicts, - VarMonoBind method_id - (HsLet - (AbsBinds - method_tyvars - method_dict_ids - [(local_id, copy_id)] - dict_binds - (NonRecBind mbind')) - (HsVar copy_id))) -\end{code} + go occ EmptyMonoBinds = Nothing + go occ (AndMonoBinds b1 b2) = go occ b1 `seqMaybe` go occ b2 -\begin{code} -tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds - -> TcM s (TcMonoBinds s, LIE s) - -tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn) - = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) -> - returnTc (FunMonoBind meth_id inf rhs' locn, lie) - -tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn) - -- pat is sure to be a (VarPatIn op) - = tcAddErrCtxt (patMonoBindsCtxt pbind) $ - tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) -> - unifyTauTy meth_ty rhs_ty `thenTc_` - returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie) + go occ b@(FunMonoBind op_name _ _ locn) | nameOccName op_name == occ = Just (op_name, b) + | otherwise = Nothing + go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b) + | otherwise = Nothing + go occ other = panic "Urk! Bad instance method binding" \end{code} + %************************************************************************ %* * \subsection{Type-checking specialise instance pragmas} @@ -778,7 +547,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc clas = lookupCE ce class_name -- Renamer ensures this can't fail -- Make some new type variables, named as in the specialised instance type - ty_names = extractMonoTyNames (==) ty + ty_names = extractHsTyNames ???is_tyvarish_name??? ty (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names in babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty) @@ -798,7 +567,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) -> let Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta - _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst + _ _ binds _ uprag) = maybe_unspec_inst subst = case matchTy unspec_inst_ty inst_ty of Just subst -> subst @@ -809,36 +578,39 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc mk_spec_origin clas ty = InstanceSpecOrigin inst_mapper clas ty src_loc + -- I'm VERY SUSPICIOUS ABOUT THIS + -- the inst-mapper is in a knot at this point so it's no good + -- looking at it in tcSimplify... in tcSimplifyThetas mk_spec_origin subst_tv_theta `thenTc` \ simpl_tv_theta -> let simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ] - tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys + tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv in - mkInstanceRelatedIds e True{-from here-} mod NoInstancePragmas src_loc + mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag - `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) -> getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> (if sw_chkr SpecialiseTrace then pprTrace "Specialised Instance: " - (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta, - if null simpl_theta then ppNil else ppStr "=>", + (vcat [hsep [if null simpl_theta then empty else ppr PprDebug simpl_theta, + if null simpl_theta then empty else ptext SLIT("=>"), ppr PprDebug clas, pprParendGenType PprDebug inst_ty], - ppCat [ppStr " derived from:", - if null unspec_theta then ppNil else ppr PprDebug unspec_theta, - if null unspec_theta then ppNil else ppStr "=>", + hsep [ptext SLIT(" derived from:"), + if null unspec_theta then empty else ppr PprDebug unspec_theta, + if null unspec_theta then empty else ptext SLIT("=>"), ppr PprDebug clas, pprParendGenType PprDebug unspec_inst_ty]]) else id) ( returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta - dfun_theta dfun_id const_meth_ids - binds True{-from here-} mod src_loc uprag)) + dfun_theta dfun_id + binds src_loc uprag)) ))) @@ -884,18 +656,17 @@ 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 from_here clas inst_tau +scrutiniseInstanceType dfun_name clas inst_tau -- TYCON CHECK - | not (maybeToBool inst_tycon_maybe) + | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon = failTc (instTypeErr inst_tau) -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1) - | from_here + | not (isLocallyDefined dfun_name) = returnTc (inst_tycon,arg_tys) -- TYVARS CHECK | not (all isTyVarTy arg_tys || - not from_here || opt_GlasgowExts) = failTc (instTypeErr inst_tau) @@ -909,69 +680,111 @@ scrutiniseInstanceType from_here clas inst_tau = failTc (derivingWhenInstanceExistsErr clas inst_tycon) | -- CCALL CHECK - -- A user declaration of a _CCallable/_CReturnable instance + -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. - isCcallishClass clas - && not opt_CompilingPrelude -- which allows anything - && maybeToBool (maybeBoxedPrimType inst_tau) + (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) = splitAppTy inst_tau + (possible_tycon, arg_tys) = splitAppTys inst_tau inst_tycon_maybe = getTyCon_maybe possible_tycon inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe + +-- 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]) -> +-- pprTrace "cc1" (sep [ppr PprDebug tycon, ppr PprDebug data_con, +-- sep (map (ppr PprDebug) data_con_arg_tys)])( + length data_con_arg_tys == 2 && + maybeToBool maybe_arg2_tycon && +-- pprTrace "cc2" (sep [ppr PprDebug 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 _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg] - TyVarTy tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg] - other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg] + SynTy tc _ _ -> hcat [ptext SLIT("The type synonym `"), ppr sty tc, rest_of_msg] + TyVarTy tv -> hcat [ptext SLIT("The type variable `"), ppr sty tv, rest_of_msg] + other -> hcat [ptext SLIT("The type `"), ppr sty ty, rest_of_msg] where - rest_of_msg = ppStr "' cannot be used as an instance type." + 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 - = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"]) - 4 (ppStr "when an explicit instance exists") + = 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 - = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"]) - 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"]) + = 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 = case inst_mod of - Nothing -> ppPStr SLIT("the standard Prelude") - Just m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"] + pp_mod = hsep [ptext SLIT("module"), ptext inst_mod] nonBoxedPrimCCallErr clas inst_ty sty - = ppHang (ppStr "Instance isn't for a `boxed-primitive' type") - 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `", - ppr sty inst_ty, ppStr "'"]) + = 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 - = ppCat [ppStr "Warning: Omitted default method for", - ppr sty clas_op, ppStr "in instance", - ppPStr clas_name, pprParendGenType sty inst_ty] + = 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 - = ppHang (ppStr "In a pattern binding:") + = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty pbind) methodSigCtxt name ty sty - = ppHang (ppBesides [ppStr "When matching the definition of class method `", - ppr sty name, ppStr "' to its signature :" ]) + = hang (hsep [ptext SLIT("When matching the definition of class method"), + ppr sty name, ptext SLIT("to its signature :") ]) 4 (ppr sty ty) bindSigCtxt method_ids sty - = ppHang (ppStr "When checking type signatures for: ") - 4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids)) + = hang (ptext SLIT("When checking type signatures for: ")) + 4 (hsep (punctuate comma (map (ppr sty) method_ids))) superClassSigCtxt sty - = ppStr "When checking superclass constraints on instance declaration" + = ptext SLIT("When checking superclass constraints on instance declaration") \end{code}