X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=4223af4da4faa794ba4ce5812fbdd4d83c77d21e;hb=00cc4d8773d1138f7b3b3ac122f3c98a6f93e68a;hp=7b4e5ecb43a0bda8a5ecb399b81055ea0471e7b2;hpb=40f5a0759bd07308009c3ae8956dfa061c684ebd;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 7b4e5ec..4223af4 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -28,16 +28,16 @@ import HsSyn		( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
 import TcHsSyn		( zonkId )
 
 import TcRnMonad
-import Inst		( newDictsAtLoc, newIPDict, instToId )
+import Inst		( newDictBndrs, newIPDict, instToId )
 import TcEnv		( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, 
-			  pprBinders, tcLookupLocalId_maybe, tcLookupId,
+			  pprBinders, tcLookupId,
 			  tcGetGlobalTyVars )
 import TcUnify		( tcInfer, tcSubExp, unifyTheta, 
 			  bleatEscapedTvs, sigCtxt )
 import TcSimplify	( tcSimplifyInfer, tcSimplifyInferCheck, 
 			  tcSimplifyRestricted, tcSimplifyIPs )
 import TcHsType		( tcHsSigType, UserTypeCtxt(..) )
-import TcPat		( tcPat, PatCtxt(..) )
+import TcPat		( tcLetPat )
 import TcSimplify	( bindInstsOfLocalFuns )
 import TcMType		( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar,
 			  tcInstSigTyVars, tcInstSkolTyVars, tcInstType, 
@@ -48,9 +48,8 @@ import TcType		( TcType, TcTyVar, TcThetaType,
 			  mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, 
 			  mkForAllTy, isUnLiftedType, tcGetTyVar, 
 			  mkTyVarTys, tidyOpenTyVar )
-import Kind		( argTypeKind )
+import {- Kind parts of -} Type		( argTypeKind )
 import VarEnv		( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) 
-import TysWiredIn	( unitTy )
 import TysPrim		( alphaTyVar )
 import Id		( Id, mkLocalId, mkVanillaGlobal )
 import IdInfo		( vanillaIdInfo )
@@ -323,7 +322,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)
@@ -448,15 +447,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 +649,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.
@@ -776,7 +773,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 ()