X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=d03f6f51460e309a124ff7e3287550b820a8d8ee;hb=d6684fe7e4e40e54dd6237aab6b488307af8e17f;hp=09c069ec2760fec997318853cb6a1c6ae4288f2e;hpb=1c3601593186639f1086bc402582ff56fd3fe9f8;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 09c069e..d03f6f5 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -43,16 +43,16 @@ module TcType (
 
 -- friends:
 import TypeRep		( Type(..), Kind, TyNote(..) )  -- friend
-import Type		( ThetaType, PredType(..),
-			  getTyVar, mkAppTy, mkTyConApp, mkPredTy,
-			  splitPredTy_maybe, splitForAllTys, isNotUsgTy,
+import Type		( PredType(..),
+			  getTyVar, mkAppTy, mkUTy,
+			  splitPredTy_maybe, splitForAllTys, 
 			  isTyVarTy, mkTyVarTy, mkTyVarTys, 
 			  openTypeKind, boxedTypeKind, 
 			  superKind, superBoxity, 
 			  defaultKind, boxedBoxity
 			)
 import Subst		( Subst, mkTopTyVarSubst, substTy )
-import TyCon		( tyConKind, mkPrimTyCon )
+import TyCon		( mkPrimTyCon )
 import PrimRep		( PrimRep(VoidRep) )
 import Var		( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
 
@@ -61,9 +61,10 @@ import TcMonad          -- TcType, amongst others
 import TysWiredIn	( voidTy )
 
 import Name		( Name, NamedThing(..), setNameUnique, mkSysLocalName,
-			  mkDerivedName, mkDerivedTyConOcc
+			  mkLocalName, mkDerivedTyConOcc
 			)
-import Unique		( Unique, Uniquable(..) )
+import Unique		( Uniquable(..) )
+import SrcLoc		( noSrcLoc )
 import Util		( nOfThem )
 import Outputable
 \end{code}
@@ -92,6 +93,7 @@ tcSplitRhoTy t
 				  case maybe_ty of
 				    Just ty | not (isTyVarTy ty) -> go syn_t ty ts
 				    other			 -> returnNF_Tc (reverse ts, syn_t)
+    go syn_t (UsageTy _ t)   ts = go syn_t t ts
     go syn_t t		     ts = returnNF_Tc (reverse ts, syn_t)
 \end{code}
 
@@ -206,7 +208,8 @@ tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType)
 Putting is easy:
 
 \begin{code}
-tcPutTyVar tyvar ty = tcWriteMutTyVar tyvar (Just ty)	`thenNF_Tc_`
+tcPutTyVar tyvar ty = UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty )
+                      tcWriteMutTyVar tyvar (Just ty)	`thenNF_Tc_`
 		      returnNF_Tc ty
 \end{code}
 
@@ -337,9 +340,12 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
     mk_void_tycon tv kind	-- Make a new TyCon with the same kind as the 
 				-- type variable tv.  Same name too, apart from
 				-- making it start with a colon (sigh)
-	= mkPrimTyCon tc_name kind 0 [] VoidRep
+		-- I dread to think what will happen if this gets out into an 
+		-- interface file.  Catastrophe likely.  Major sigh.
+	= pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $
+	  mkPrimTyCon tc_name kind 0 [] VoidRep
 	where
-	  tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv)
+	  tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
 
 -- zonkTcTyVarToTyVar is applied to the *binding* occurrence 
 -- of a type variable, at the *end* of type checking.  It changes
@@ -401,12 +407,6 @@ zonkType unbound_var_fn ty
 
     go (NoteTy (FTVNote _) ty2)   = go ty2	-- Discard free-tyvar annotations
 
-    go (NoteTy (UsgNote usg) ty2) = go ty2		`thenNF_Tc` \ ty2' ->
-				    returnNF_Tc (NoteTy (UsgNote usg) ty2')
-
-    go (NoteTy (UsgForAll uv) ty2)= go ty2		`thenNF_Tc` \ ty2' ->
-				    returnNF_Tc (NoteTy (UsgForAll uv) ty2')
-
     go (PredTy p)		  = go_pred p		`thenNF_Tc` \ p' ->
 				    returnNF_Tc (PredTy p')
 
@@ -418,6 +418,10 @@ zonkType unbound_var_fn ty
 				    go arg		`thenNF_Tc` \ arg' ->
 				    returnNF_Tc (mkAppTy fun' arg')
 
+    go (UsageTy u ty)             = go u                `thenNF_Tc` \ u'  ->
+                                    go ty               `thenNF_Tc` \ ty' ->
+                                    returnNF_Tc (mkUTy u' ty')
+
 	-- The two interesting cases!
     go (TyVarTy tyvar)     = zonkTyVar unbound_var_fn tyvar
 
@@ -443,7 +447,6 @@ zonkTyVar unbound_var_fn tyvar
   =  tcGetTyVar tyvar	`thenNF_Tc` \ maybe_ty ->
      case maybe_ty of
 	  Nothing	-> unbound_var_fn tyvar			-- Mutable and unbound
-	  Just other_ty	-> ASSERT( isNotUsgTy other_ty )
-                           zonkType unbound_var_fn other_ty	-- Bound
+	  Just other_ty	-> zonkType unbound_var_fn other_ty	-- Bound
 \end{code}