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

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index e200bcf..7358cd3 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -18,7 +18,7 @@ module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred,
 
 #include "HsVersions.h"
 
-import HsSyn		( HsType(..), HsTyVarBndr(..),
+import HsSyn		( HsType(..), HsTyVarBndr(..), HsTyOp(..),
                           Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
 import RnHsSyn		( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars )
 import TcHsSyn		( TcId )
@@ -34,27 +34,28 @@ import TcMType		( newKindVar, zonkKindEnv, tcInstType,
 import TcUnify		( unifyKind, unifyOpenTypeKind )
 import TcType		( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
 			  TcTyVar, TcKind, TcThetaType, TcTauType,
-			  mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
-		 	  hoistForAllTys, zipFunTys, 
-			  mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, 
+			  mkTyVarTy, mkTyVarTys, mkFunTy, 
+		 	  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 )
 
 import Id		( mkLocalId, idName, idType )
 import Var		( TyVar, mkTyVar, tyVarKind )
 import ErrUtils		( Message )
-import TyCon		( TyCon, isSynTyCon, tyConKind )
+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}
 
 
@@ -287,17 +288,25 @@ kcHsType (HsFunTy ty1 ty2)
     kcTypeType ty2	`thenTc_`
     returnTc liftedTypeKind
 
-kcHsType (HsNumTy _)		-- The unit type for generics
-  = returnTc liftedTypeKind
+kcHsType (HsOpTy ty1 HsArrow ty2)
+  = kcTypeType ty1	`thenTc_`
+    kcTypeType ty2	`thenTc_`
+    returnTc liftedTypeKind
 
-kcHsType ty@(HsOpTy ty1 op ty2)
+kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2)
   = kcTyVar op				`thenTc` \ op_kind ->
     kcHsType ty1			`thenTc` \ ty1_kind ->
     kcHsType ty2			`thenTc` \ ty2_kind ->
     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
+
 kcHsType (HsPredTy pred)
   = kcHsPred pred		`thenTc_`
     returnTc liftedTypeKind
@@ -426,15 +435,23 @@ tc_type (HsFunTy ty1 ty2)
     tc_type ty2			`thenTc` \ tau_ty2 ->
     returnTc (mkFunTy tau_ty1 tau_ty2)
 
-tc_type (HsNumTy n)
-  = ASSERT(n== 1)
-    returnTc (mkTyConApp genUnitTyCon [])
+tc_type (HsOpTy ty1 HsArrow ty2)
+  = tc_type ty1 `thenTc` \ tau_ty1 ->
+    tc_type ty2 `thenTc` \ tau_ty2 ->
+    returnTc (mkFunTy tau_ty1 tau_ty2)
 
-tc_type (HsOpTy ty1 op ty2)
+tc_type (HsOpTy ty1 (HsTyOp op) ty2)
   = tc_type ty1 `thenTc` \ tau_ty1 ->
     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 [])
+
 tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
 
 tc_type (HsPredTy pred)
@@ -480,9 +497,7 @@ tc_fun_type name arg_tys
     case thing of
 	ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
 
-	AGlobal (ATyCon tc)
-		| isSynTyCon tc ->  returnTc (mkSynTy tc arg_tys)
-		| otherwise	->  returnTc (mkTyConApp tc arg_tys)
+	AGlobal (ATyCon tc) -> returnTc (mkGenTyConApp tc arg_tys)
 
 	other -> failWithTc (wrongThingErr "type constructor" thing name)
 \end{code}
@@ -615,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}
+
 
 %************************************************************************
 %*									*