X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=88667f095142751d522bc5a58dfe3acdba642deb;hb=4250d64191132fd493985549eda5ca05b82a663f;hp=2fb8408a976420e4e652ec1d5259140e60dbd511;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 2fb8408..88667f0 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -11,7 +11,7 @@ module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
 import Ubiq
 
 import HsSyn		( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), 
-			  HsExpr, Match, PolyType, InPat, OutPat,
+			  HsExpr, Match, PolyType, InPat, OutPat(..),
 			  GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
 			  collectBinders )
 import RnHsSyn		( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..), 
@@ -36,14 +36,14 @@ import Kind		( mkBoxedTypeKind, mkTypeKind )
 import Id		( GenId, idType, mkUserId )
 import IdInfo		( noIdInfo )
 import Maybes		( assocMaybe, catMaybes, Maybe(..) )
-import Name		( pprNonOp )
+import Name		( pprNonSym )
 import PragmaInfo	( PragmaInfo(..) )
 import Pretty
 import RnHsSyn		( RnName )	-- instances
 import Type		( mkTyVarTy, mkTyVarTys, isTyVarTy,
 			  mkSigmaTy, splitSigmaTy,
 			  splitRhoTy, mkForAllTy, splitForAllTy )
-import Util		( panic )
+import Util		( isIn, panic )
 \end{code}
 
 %************************************************************************
@@ -251,8 +251,9 @@ data SigInfo
 
 	-- Make poly_ids for all the binders that don't have type signatures
     let
+	tys_to_gen   = mkTyVarTys tyvars_to_gen
 	dicts_to_gen = map instToId (bagToList lie_to_gen)
-	dict_tys = map tcIdType dicts_to_gen
+	dict_tys     = map tcIdType dicts_to_gen
 
 	mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo
 		       where
@@ -260,31 +261,32 @@ data SigInfo
 			       mkFunTys dict_tys $
 			       tcIdType local_id
 
-	tys_to_gen     = mkTyVarTys tyvars_to_gen
 	more_sig_infos = [ SigInfo binder (mk_poly binder local_id) 
 				   local_id tys_to_gen dicts_to_gen lie_to_gen
 			 | (binder, local_id) <- nosig_binders `zipEqual` nosig_local_ids
 			 ]
 
-	local_binds = [ (local_id, DictApp (mkHsTyApp (HsVar local_id) inst_tys) dicts)
-		      | SigInfo _ _ local_id inst_tys dicts <- more_sig_infos
-		      ]
-
 	all_sig_infos = sig_infos ++ more_sig_infos	-- Contains a "signature" for each binder
     in
 
 
 	-- Now generalise the bindings
     let
-      find_sig lid = head [ (pid, tvs, ds, lie) 
+	-- local_binds is a bunch of bindings of the form
+	--	f_mono = f_poly tyvars dicts
+	-- one for each binder, f, that lacks a type signature.
+	-- This bunch of bindings is put at the top of the RHS of every
+	-- binding in the group, so as to bind all the f_monos.
+		
+	local_binds = [ (local_id, mkHsDictApp (mkHsTyApp (HsVar local_id) tys_to_gen) dicts_to_gen)
+		      | local_id <- nosig_local_ids
+		      ]
+
+        find_sig lid = head [ (pid, tvs, ds, lie) 
 		          | SigInfo _ pid lid' tvs ds lie, 
 			    lid==lid'
 			  ]
-	-- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen:
-	-- We still need to do this simplification, because some dictionaries 
-	-- may gratuitously constrain some tyvars over which we *are* going 
-	-- to generalise. 
-	-- For example d::Eq (Foo a b), where Foo is instanced as above.
+
       gen_bind (bind, lie)
 	= tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie
 				    `thenTc` \ (lie_free, dict_binds) ->
@@ -361,7 +363,7 @@ getImplicitStuffToGen is_restricted sig_ids binds_w_lies
      returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE)
 
   where
-    sig_ids   = [sig_var | (TySigInfo sig_id _ _ _ _) <- ty_sigs]
+    sig_vars   = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs]
 
     (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2,
 							       lie1 `plusLIE` lie2))
@@ -641,8 +643,42 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 \end{code}
 
 
-Error contexts and messages
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection[TcBinds-monomorphism]{The monomorphism restriction}
+%*									*
+%************************************************************************
+
+Not exported:
+
+\begin{code}
+isUnRestrictedGroup :: [TcIdBndr s]		-- Signatures given for these
+		    -> TcBind s
+		    -> Bool
+
+isUnRestrictedGroup sigs EmptyBind              = True
+isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds
+isUnRestrictedGroup sigs (RecBind monobinds)    = isUnResMono sigs monobinds
+
+is_elem v vs = isIn "isUnResMono" v vs
+
+isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _)	= v `is_elem` sigs
+isUnResMono sigs (PatMonoBind other      _ _)		= False
+isUnResMono sigs (VarMonoBind (TcId v) _)		= v `is_elem` sigs
+isUnResMono sigs (FunMonoBind _ _ _ _)			= True
+isUnResMono sigs (AndMonoBinds mb1 mb2)			= isUnResMono sigs mb1 &&
+							  isUnResMono sigs mb2
+isUnResMono sigs EmptyMonoBinds				= True
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[TcBinds-errors]{Error contexts and messages}
+%*									*
+%************************************************************************
+
+
 \begin{code}
 patMonoBindsCtxt bind sty
   = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
@@ -675,7 +711,7 @@ specGroundnessCtxt
 
 valSpecSigCtxt v ty sty
   = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
-	 4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")),
+	 4 (ppSep [ppBeside (pprNonSym sty v) (ppPStr SLIT(" ::")),
 		  ppr sty ty])
 \end{code}