X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=b5d2cb74770412effb48c8bcfd4579a1aa910a9a;hb=dbaa3bb30eaf9d806357e41435dab32695c47842;hp=27365bd8708486d210fc29ad6f7990203a1840d7;hpb=3c58c25b1b99143c0ac03510423a95bc3bd41aa2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 27365bd..b5d2cb7 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -8,12 +8,12 @@ module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where #include "HsVersions.h" -import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcExpr, tcMonoExpr ) +import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), - Match(..), HsMatchContext(..), mkMonoBind, + Match(..), mkMonoBind, collectMonoBinders, andMonoBinds, collectSigTysFromMonoBinds ) @@ -23,7 +23,7 @@ import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) import TcRnMonad import Inst ( InstOrigin(..), newDicts, newIPDict, instToId ) import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) -import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) +import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), @@ -31,9 +31,7 @@ import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), ) import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newTyVar, newTyVarTy, newHoleTyVarTy, - zonkTcTyVarToTyVar, readHoleResult - ) +import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar ) import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, mkPredTy, mkForAllTy, isUnLiftedType, unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind @@ -88,6 +86,9 @@ dictionaries, which we resolve at the module level. \begin{code} tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, TcLclEnv) + -- Note: returning the TcLclEnv is more than we really + -- want. The bit we care about is the local bindings + -- and the free type variables thereof tcTopBinds binds = tc_binds_and_then TopLevel glue binds $ getLclEnv `thenM` \ env -> @@ -138,7 +139,7 @@ tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next = newTyVarTy openTypeKind `thenM` \ ty -> getSrcLocM `thenM` \ loc -> newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) -> - tcMonoExpr expr ty `thenM` \ expr' -> + tcCheckRho expr ty `thenM` \ expr' -> returnM (ip_inst, (ip', expr')) tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next @@ -151,32 +152,24 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - getLIE ( - -- Extend the environment to bind the new polymorphic Ids - tcExtendLocalValEnv poly_ids $ - - -- Build bindings and IdInfos corresponding to user pragmas - tcSpecSigs sigs `thenM` \ prag_binds -> - - -- Now do whatever happens next, in the augmented envt - do_next `thenM` \ thing -> - - returnM (prag_binds, thing) - ) `thenM` \ ((prag_binds, thing), lie) -> - case top_lvl of - - -- For the top level don't bother will all this bindInstsOfLocalFuns stuff - -- All the top level things are rec'd together anyway, so it's fine to - -- leave them to the tcSimplifyTop, and quite a bit faster too - TopLevel - -> extendLIEs lie `thenM_` + TopLevel -- For the top level don't bother will all this + -- bindInstsOfLocalFuns stuff. All the top level + -- things are rec'd together anyway, so it's fine to + -- leave them to the tcSimplifyTop, and quite a bit faster too + -- + -- Subtle (and ugly) point: furthermore at top level we + -- return the TcLclEnv, which contains the LIE var; we + -- don't want to return the wrong one! + -> tc_body poly_ids `thenM` \ (prag_binds, thing) -> returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds)) thing) - NotTopLevel - -> bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> + NotTopLevel -- For nested bindings we must do teh bindInstsOfLocalFuns thing + -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> + -- Create specialisations of functions bound here + bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> -- We want to keep non-recursive things non-recursive -- so that we desugar unlifted bindings correctly @@ -196,6 +189,18 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next -- aren't guaranteed in dependency order (though we could change -- that); hence the Recursive marker. thing) + where + tc_body poly_ids -- Type check the pragmas and "thing inside" + = -- Extend the environment to bind the new polymorphic Ids + tcExtendLocalValEnv poly_ids $ + + -- Build bindings and IdInfos corresponding to user pragmas + tcSpecSigs sigs `thenM` \ prag_binds -> + + -- Now do whatever happens next, in the augmented envt + do_next `thenM` \ thing -> + + returnM (prag_binds, thing) \end{code} @@ -243,12 +248,14 @@ tcBindWithSigs top_lvl mbind sigs is_rec Just sig -> tcSigPolyId sig -- Signature Nothing -> mkLocalId name forall_a_a -- No signature in + traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_` returnM (EmptyMonoBinds, poly_ids) ) $ -- TYPECHECK THE BINDINGS - getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', binder_names, mono_ids), lie_req) -> + getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) -> let + (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids) tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids in @@ -612,91 +619,86 @@ The signatures have been dealt with already. \begin{code} tcMonoBinds :: RenamedMonoBinds - -> [TcSigInfo] - -> RecFlag + -> [TcSigInfo] -> RecFlag -> TcM (TcMonoBinds, - [Name], -- Bound names - [TcId]) -- Corresponding monomorphic bound things + Bag (Name, -- Bound names + TcId)) -- Corresponding monomorphic bound things tcMonoBinds mbinds tc_ty_sigs is_rec - = tc_mb_pats mbinds `thenM` \ (complete_it, tvs, ids, lie_avail) -> - let - id_list = bagToList ids - (names, mono_ids) = unzip id_list - - -- This last defn is the key one: - -- extend the val envt with bindings for the - -- things bound in this group, overriding the monomorphic - -- ids with the polymorphic ones from the pattern - extra_val_env = case is_rec of - Recursive -> map mk_bind id_list - NonRecursive -> [] - in - -- Don't know how to deal with pattern-bound existentials yet - checkTc (isEmptyBag tvs && null lie_avail) - (existentialExplode mbinds) `thenM_` - - -- *Before* checking the RHSs, but *after* checking *all* the patterns, - -- extend the envt with bindings for all the bound ids; - -- and *then* override with the polymorphic Ids from the signatures - -- That is the whole point of the "complete_it" stuff. - -- - -- There's a further wrinkle: we have to delay extending the environment - -- until after we've dealt with any pattern-bound signature type variables - -- Consider f (x::a) = ...f... - -- We're going to check that a isn't unified with anything in the envt, - -- so f itself had better not be! So we pass the envt binding f into - -- complete_it, which extends the actual envt in TcMatches.tcMatch, after - -- dealing with the signature tyvars - - complete_it extra_val_env `thenM` \ mbinds' -> - - returnM (mbinds', names, mono_ids) + -- Three stages: + -- 1. Check the patterns, building up an environment binding + -- the variables in this group (in the recursive case) + -- 2. Extend the environment + -- 3. Check the RHSs + = tc_mb_pats mbinds `thenM` \ (complete_it, xve) -> + tcExtendLocalValEnv2 (bagToList xve) complete_it where - - mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of - Nothing -> (name, mono_id) - Just sig -> (idName poly_id, poly_id) - where - poly_id = tcSigPolyId sig - - tc_mb_pats EmptyMonoBinds - = returnM (\ xve -> returnM EmptyMonoBinds, emptyBag, emptyBag, []) + tc_mb_pats EmptyMonoBinds + = returnM (returnM (EmptyMonoBinds, emptyBag), emptyBag) tc_mb_pats (AndMonoBinds mb1 mb2) - = tc_mb_pats mb1 `thenM` \ (complete_it1, tvs1, ids1, lie_avail1) -> - tc_mb_pats mb2 `thenM` \ (complete_it2, tvs2, ids2, lie_avail2) -> + = tc_mb_pats mb1 `thenM` \ (complete_it1, xve1) -> + tc_mb_pats mb2 `thenM` \ (complete_it2, xve2) -> let - complete_it xve = complete_it1 xve `thenM` \ mb1' -> - complete_it2 xve `thenM` \ mb2' -> - returnM (AndMonoBinds mb1' mb2') + complete_it = complete_it1 `thenM` \ (mb1', bs1) -> + complete_it2 `thenM` \ (mb2', bs2) -> + returnM (AndMonoBinds mb1' mb2', bs1 `unionBags` bs2) in - returnM (complete_it, - tvs1 `unionBags` tvs2, - ids1 `unionBags` ids2, - lie_avail1 ++ lie_avail2) + returnM (complete_it, xve1 `unionBags` xve2) tc_mb_pats (FunMonoBind name inf matches locn) - = (case maybeSig tc_ty_sigs name of - Just sig -> returnM (tcSigMonoId sig) - Nothing -> newLocalName name `thenM` \ bndr_name -> - newTyVarTy openTypeKind `thenM` \ bndr_ty -> - -- NB: not a 'hole' tyvar; since there is no type - -- signature, we revert to ordinary H-M typechecking - -- which means the variable gets an inferred tau-type - returnM (mkLocalId bndr_name bndr_ty) - ) `thenM` \ bndr_id -> + -- Three cases: + -- a) Type sig supplied + -- b) No type sig and recursive + -- c) No type sig and non-recursive + + | Just sig <- maybeSig tc_ty_sigs name + = let -- (a) There is a type signature + -- Use it for the environment extension, and check + -- the RHS has the appropriate type (with outer for-alls stripped off) + mono_id = tcSigMonoId sig + mono_ty = idType mono_id + complete_it = addSrcLoc locn $ + tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> + returnM (FunMonoBind mono_id inf matches' locn, + unitBag (name, mono_id)) + in + returnM (complete_it, if isRec is_rec then unitBag (name,tcSigPolyId sig) + else emptyBag) + + | isRec is_rec + = -- (b) No type signature, and recursive + -- So we must use an ordinary H-M type variable + -- which means the variable gets an inferred tau-type + newLocalName name `thenM` \ mono_name -> + newTyVarTy openTypeKind `thenM` \ mono_ty -> let - bndr_ty = idType bndr_id - complete_it xve = addSrcLoc locn $ - tcMatchesFun xve name bndr_ty matches `thenM` \ matches' -> - returnM (FunMonoBind bndr_id inf matches' locn) + mono_id = mkLocalId mono_name mono_ty + complete_it = addSrcLoc locn $ + tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> + returnM (FunMonoBind mono_id inf matches' locn, + unitBag (name, mono_id)) in - returnM (complete_it, emptyBag, unitBag (name, bndr_id), []) - + returnM (complete_it, unitBag (name, mono_id)) + + | otherwise -- (c) No type signature, and non-recursive + = let -- So we can use a 'hole' type to infer a higher-rank type + complete_it + = addSrcLoc locn $ + newHole `thenM` \ hole -> + tcMatchesFun name matches (Infer hole) `thenM` \ matches' -> + readMutVar hole `thenM` \ fun_ty -> + newLocalName name `thenM` \ mono_name -> + let + mono_id = mkLocalId mono_name fun_ty + in + returnM (FunMonoBind mono_id inf matches' locn, + unitBag (name, mono_id)) + in + returnM (complete_it, emptyBag) + tc_mb_pats bind@(PatMonoBind pat grhss locn) = addSrcLoc locn $ - newHoleTyVarTy `thenM` \ pat_ty -> -- Now typecheck the pattern -- We do now support binding fresh (not-already-in-scope) scoped @@ -706,16 +708,21 @@ tcMonoBinds mbinds tc_ty_sigs is_rec -- The type variables are brought into scope in tc_binds_and_then, -- so we don't have to do anything here. - tcPat tc_pat_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> - readHoleResult pat_ty `thenM` \ pat_ty' -> + newHole `thenM` \ hole -> + tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) -> + readMutVar hole `thenM` \ pat_ty -> + + -- Don't know how to deal with pattern-bound existentials yet + checkTc (isEmptyBag tvs && null lie_avail) + (existentialExplode bind) `thenM_` + let - complete_it xve = addSrcLoc locn $ - addErrCtxt (patMonoBindsCtxt bind) $ - tcExtendLocalValEnv2 xve $ - tcGRHSs PatBindRhs grhss pat_ty' `thenM` \ grhss' -> - returnM (PatMonoBind pat' grhss' locn) + complete_it = addSrcLoc locn $ + addErrCtxt (patMonoBindsCtxt bind) $ + tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' -> + returnM (PatMonoBind pat' grhss' locn, ids) in - returnM (complete_it, tvs, ids, lie_avail) + returnM (complete_it, if isRec is_rec then ids else emptyBag) -- tc_pat_bndr is used when dealing with a LHS binder in a pattern. -- If there was a type sig for that Id, we want to make it much @@ -727,9 +734,8 @@ tcMonoBinds mbinds tc_ty_sigs is_rec tc_pat_bndr name pat_ty = case maybeSig tc_ty_sigs name of - Nothing - -> newLocalName name `thenM` \ bndr_name -> - tcMonoPatBndr bndr_name pat_ty + Nothing -> newLocalName name `thenM` \ bndr_name -> + tcMonoPatBndr bndr_name pat_ty Just sig -> addSrcLoc (getSrcLoc name) $ tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn -> @@ -792,7 +798,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) -- Check that f has a more general type, and build a RHS for -- the spec-pragma-id at the same time - getLIE (tcExpr (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) -> + getLIE (tcCheckSigma (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) -> -- Squeeze out any Methods (see comments with tcSimplifyToDicts) tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->