X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonoType.lhs;h=7358cd34c22d81545203d0b3ab75c3cfba206b36;hb=4bca2e7f766e3a265e77cbce4884f889d6d28299;hp=cd1ba2b7fa2fc2682145fc6cfab9ef8e08153eab;hpb=ef2b170c6298b4826d3b56465a3c1438b5be7307;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index cd1ba2b..7358cd3 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -35,10 +35,10 @@ import TcUnify		( unifyKind, unifyOpenTypeKind )
 import TcType		( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
 			  TcTyVar, TcKind, TcThetaType, TcTauType,
 			  mkTyVarTy, mkTyVarTys, mkFunTy, 
-		 	  hoistForAllTys, zipFunTys, 
+		 	  zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy,
 			  mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
 			  liftedTypeKind, unliftedTypeKind, mkArrowKind,
-			  mkArrowKinds, tcSplitFunTy_maybe
+			  mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
 			)
 import Inst		( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
 
@@ -49,12 +49,13 @@ import TyCon		( TyCon, tyConKind )
 import Class		( classTyCon )
 import Name		( Name )
 import NameSet
+import Subst		( deShadowTy )
 import TysWiredIn	( mkListTy, mkPArrTy, mkTupleTy, genUnitTyCon )
 import BasicTypes	( Boxity(..) )
 import SrcLoc		( SrcLoc )
 import Util		( lengthIs )
 import Outputable
-
+import List		( nubBy )
 \end{code}
 
 
@@ -299,6 +300,9 @@ kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2)
     tcAddErrCtxt (appKindCtxt (ppr ty))	$
     kcAppKind op_kind  ty1_kind		`thenTc` \ op_kind' ->
     kcAppKind op_kind' ty2_kind
+
+kcHsType (HsParTy ty)		-- Skip parentheses markers
+  = kcHsType ty
    
 kcHsType (HsNumTy _)		-- The unit type for generics
   = returnTc liftedTypeKind
@@ -441,6 +445,9 @@ tc_type (HsOpTy ty1 (HsTyOp op) ty2)
     tc_type ty2 `thenTc` \ tau_ty2 ->
     tc_fun_type op [tau_ty1,tau_ty2]
 
+tc_type (HsParTy ty)		-- Remove the parentheses markers
+  = tc_type ty
+
 tc_type (HsNumTy n)
   = ASSERT(n== 1)
     returnTc (mkTyConApp genUnitTyCon [])
@@ -623,6 +630,62 @@ mkTcSig poly_id src_loc
 \end{code}
 
 
+%************************************************************************
+%*									*
+\subsection{Errors and contexts}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+hoistForAllTys :: Type -> Type
+-- Used for user-written type signatures only
+-- Move all the foralls and constraints to the top
+-- e.g.  T -> forall a. a        ==>   forall a. T -> a
+--	 T -> (?x::Int) -> Int   ==>   (?x::Int) -> T -> Int
+--
+-- We want to 'look through' type synonyms when doing this
+-- so it's better done on the Type than the HsType
+
+hoistForAllTys ty
+  = let
+	no_shadow_ty = deShadowTy ty
+	-- Running over ty with an empty substitution gives it the
+	-- no-shadowing property.  This is important.  For example:
+	--	type Foo r = forall a. a -> r
+	--	foo :: Foo (Foo ())
+	-- Here the hoisting should give
+	--	foo :: forall a a1. a -> a1 -> ()
+	--
+	-- What about type vars that are lexically in scope in the envt?
+	-- We simply rely on them having a different unique to any
+	-- binder in 'ty'.  Otherwise we'd have to slurp the in-scope-tyvars
+	-- out of the envt, which is boring and (I think) not necessary.
+    in
+    case hoist no_shadow_ty of 
+	(tvs, theta, body) -> mkForAllTys tvs (mkFunTys (nubBy tcEqType theta) body)
+		-- The 'nubBy' eliminates duplicate constraints
+  where
+    hoist ty
+	| (tvs1, body_ty) <- tcSplitForAllTys ty,
+	  not (null tvs1)
+	= case hoist body_ty of
+		(tvs2,theta,tau) -> (tvs1 ++ tvs2, theta, tau)
+
+	| Just (arg, res) <- tcSplitFunTy_maybe ty
+	= let
+	      arg' = hoistForAllTys arg	-- Don't forget to apply hoist recursively
+	  in				-- to the argument type
+	  if (isPredTy arg') then
+	    case hoist res of
+		(tvs,theta,tau) -> (tvs, arg':theta, tau)
+	  else
+	     case hoist res of
+		(tvs,theta,tau) -> (tvs, theta, mkFunTy arg' tau)
+
+	| otherwise = ([], [], ty)
+\end{code}
+
 
 %************************************************************************
 %*									*