X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=0ec1c66657c97a2354bc9ff2c7e3b4975bd35afa;hb=311b1cdfc9b1c311cc53482c461c18cba8885b2a;hp=7b4e5ecb43a0bda8a5ecb399b81055ea0471e7b2;hpb=40f5a0759bd07308009c3ae8956dfa061c684ebd;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 7b4e5ec..0ec1c66 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcBinds]{TcBinds} @@ -15,58 +16,36 @@ module TcBinds ( tcLocalBinds, tcTopBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import DynFlags ( dopt, DynFlags, - DynFlag(Opt_MonomorphismRestriction, Opt_MonoPatBinds, Opt_GlasgowExts) ) -import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), - HsLocalBinds(..), HsValBinds(..), HsIPBinds(..), - LSig, Match(..), IPBind(..), Prag(..), - HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, - isVanillaLSig, sigName, placeHolderNames, isPragLSig, - LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, - collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind - ) -import TcHsSyn ( zonkId ) +import DynFlags +import HsSyn +import TcHsSyn import TcRnMonad -import Inst ( newDictsAtLoc, newIPDict, instToId ) -import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, - pprBinders, tcLookupLocalId_maybe, tcLookupId, - tcGetGlobalTyVars ) -import TcUnify ( tcInfer, tcSubExp, unifyTheta, - bleatEscapedTvs, sigCtxt ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, - tcSimplifyRestricted, tcSimplifyIPs ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcPat ( tcPat, PatCtxt(..) ) -import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar, - tcInstSigTyVars, tcInstSkolTyVars, tcInstType, - zonkTcType, zonkTcTypes, zonkTcTyVar ) -import TcType ( TcType, TcTyVar, TcThetaType, - SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt), - TcTauType, TcSigmaType, isUnboxedTupleType, - mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, - mkForAllTy, isUnLiftedType, tcGetTyVar, - mkTyVarTys, tidyOpenTyVar ) -import Kind ( argTypeKind ) -import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) -import TysWiredIn ( unitTy ) -import TysPrim ( alphaTyVar ) -import Id ( Id, mkLocalId, mkVanillaGlobal ) -import IdInfo ( vanillaIdInfo ) -import Var ( TyVar, idType, idName ) -import Name ( Name ) +import Inst +import TcEnv +import TcUnify +import TcSimplify +import TcHsType +import TcPat +import TcMType +import TcType +import {- Kind parts of -} Type +import VarEnv +import TysPrim +import Id +import IdInfo +import Var ( TyVar ) +import Name import NameSet import NameEnv import VarSet -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc import Bag -import ErrUtils ( Message ) -import Digraph ( SCC(..), stronglyConnComp ) -import Maybes ( expectJust, isJust, isNothing, orElse ) -import Util ( singleton ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, - RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) +import ErrUtils +import Digraph +import Maybes +import Util +import BasicTypes import Outputable \end{code} @@ -323,7 +302,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds in -- SET UP THE MAIN RECOVERY; take advantage of any type sigs setSrcSpan loc $ - recoverM (recoveryCode binder_names) $ do + recoverM (recoveryCode binder_names sig_fn) $ do { traceTc (ptext SLIT("------------------------------------------------")) ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) @@ -440,7 +419,7 @@ tcSpecPrag poly_id hs_ty inl ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) ; extendLIEs lie ; let const_dicts = map instToId lie - ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) } + ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) } -- Most of the work of specialisation is done by -- the desugarer, guided by the SpecPrag @@ -448,15 +427,14 @@ tcSpecPrag poly_id hs_ty inl -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode binder_names +recoveryCode binder_names sig_fn = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) ; poly_ids <- mapM mk_dummy binder_names ; return ([], poly_ids) } where - mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name - ; case mb_id of - Just id -> return id -- Had signature, was in envt - Nothing -> return (mkLocalId name forall_a_a) } -- No signature + mk_dummy name + | isJust (sig_fn name) = tcLookupId name -- Had signature; look it up + | otherwise = return (mkLocalId name forall_a_a) -- No signature forall_a_a :: TcType forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) @@ -651,9 +629,8 @@ tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) | (name, Just sig) <- nm_sig_prs] sig_tau_fn = lookupNameEnv tau_sig_env - tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ -> + tc_pat exp_ty = tcLetPat sig_tau_fn pat exp_ty $ mapM lookup_info nm_sig_prs - -- The unitTy is a bit bogus; it's the "result type" for lookup_info. -- After typechecking the pattern, look up the binder -- names, which the pattern has brought into scope. @@ -757,7 +734,8 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_loc = loc }) mono_id - = Method mono_id poly_id (mkTyVarTys tvs) theta loc + = Method {tci_id = mono_id, tci_oid = poly_id, tci_tys = mkTyVarTys tvs, + tci_theta = theta, tci_loc = loc} \end{code} unifyCtxts checks that all the signature contexts are the same @@ -776,7 +754,7 @@ might not otherwise be related. This is a rather subtle issue. unifyCtxts :: [TcSigInfo] -> TcM [Inst] unifyCtxts (sig1 : sigs) -- Argument is always non-empty = do { mapM unify_ctxt sigs - ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) } + ; newDictBndrs (sig_loc sig1) (sig_theta sig1) } where theta1 = sig_theta sig1 unify_ctxt :: TcSigInfo -> TcM () @@ -976,13 +954,12 @@ mkTcSigFun :: [LSig Name] -> TcSigFun -- Precondition: no duplicates mkTcSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(name, scoped_tyvars hs_ty) - | L span (TypeSig (L _ name) (L _ hs_ty)) <- sigs] - scoped_tyvars (HsForAllTy Explicit tvs _ _) = hsLTyVarNames tvs - scoped_tyvars other = [] + env = mkNameEnv [(name, hsExplicitTvs lhs_ty) + | L span (TypeSig (L _ name) lhs_ty) <- sigs] -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) + -- See Note [Only scoped tyvars are in the TyVarEnv] --------------- data TcSigInfo @@ -1001,6 +978,19 @@ data TcSigInfo sig_loc :: InstLoc -- The location of the signature } + +-- Note [Only scoped tyvars are in the TyVarEnv] +-- We are careful to keep only the *lexically scoped* type variables in +-- the type environment. Why? After all, the renamer has ensured +-- that only legal occurrences occur, so we could put all type variables +-- into the type env. +-- +-- But we want to check that two distinct lexically scoped type variables +-- do not map to the same internal type variable. So we need to know which +-- the lexically-scoped ones are... and at the moment we do that by putting +-- only the lexically scoped ones into the environment. + + -- Note [Scoped] -- There may be more instantiated type variables than scoped -- ones. For example: @@ -1013,7 +1003,7 @@ data TcSigInfo -- and remember the names from the original HsForAllTy in sig_scoped -- Note [Instantiate sig] --- It's vital to instantiate a type signature with fresh variable. +-- It's vital to instantiate a type signature with fresh variables. -- For example: -- type S = forall a. a->a -- f,g :: S @@ -1049,7 +1039,7 @@ tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo -- Instantiate the signature, with either skolems or meta-type variables -- depending on the use_skols boolean. This variable is set True -- when we are typechecking a single function binding; and False for --- pattern bindigs and a group of several function bindings. +-- pattern bindings and a group of several function bindings. -- Reason: in the latter cases, the "skolems" can be unified together, -- so they aren't properly rigid in the type-refinement sense. -- NB: unless we are doing H98, each function with a sig will be done