X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=48d58fe7584238b60c65c0d964214455665c07d0;hb=d133b73a4d4717892ced072d05e039a54ede0ceb;hp=651c76e049e1d95c603c7d4ca43814146eb28b8c;hpb=89300e499da98bf95bcc18d895ac4369e761819a;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 651c76e..48d58fe 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -26,6 +26,7 @@ module TcType (
   tcSplitRhoTy,
 
   tcInstTyVars,
+  tcInstSigVar,
   tcInstTcType,
 
   typeToTcType,
@@ -53,7 +54,7 @@ module TcType (
 import PprType		( pprType )
 import Type		( Type(..), Kind, ThetaType, TyNote(..), 
 			  mkAppTy, mkTyConApp,
-			  splitDictTy_maybe, splitForAllTys,
+			  splitDictTy_maybe, splitForAllTys, isNotUsgTy,
 			  isTyVarTy, mkTyVarTy, mkTyVarTys, 
 			  fullSubstTy, substTopTy, 
 			  typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
@@ -172,16 +173,15 @@ tcInstTyVars :: [TyVar]
 	     -> NF_TcM s ([TcTyVar], [TcType], TyVarEnv TcType)
 
 tcInstTyVars tyvars
-  = mapNF_Tc inst_tyvar tyvars	`thenNF_Tc` \ tc_tyvars ->
+  = mapNF_Tc tcInstTyVar tyvars	`thenNF_Tc` \ tc_tyvars ->
     let
 	tys = mkTyVarTys tc_tyvars
     in
     returnNF_Tc (tc_tyvars, tys, zipVarEnv tyvars tys)
 
-inst_tyvar tyvar	-- Could use the name from the tyvar?
+tcInstTyVar tyvar
   = tcGetUnique 		`thenNF_Tc` \ uniq ->
     let
-	kind = tyVarKind tyvar
 	name = setNameUnique (tyVarName tyvar) uniq
 	-- Note that we don't change the print-name
 	-- This won't confuse the type checker but there's a chance
@@ -189,8 +189,35 @@ inst_tyvar tyvar	-- Could use the name from the tyvar?
 	-- in an error message.  -dppr-debug will show up the difference
 	-- Better watch out for this.  If worst comes to worst, just
 	-- use mkSysLocalName.
+
+	kind = tyVarKind tyvar
+    in
+
+	-- Hack alert!  Certain system functions (like error) are quantified
+	-- over type variables with an 'open' kind (a :: ?).  When we instantiate
+	-- these tyvars we want to make a type variable whose kind is (Type bv)
+	-- where bv is a boxity variable.  This makes sure it's a type, but 
+	-- is open about its boxity.  We *don't* want to give the thing the
+	-- kind '?' (= Type AnyBox).  
+	--
+	-- This is all a hack to avoid giving error it's "proper" type:
+	--	 error :: forall bv. forall a::Type bv. String -> a
+
+    (if kind == openTypeKind then
+	newOpenTypeKind	
+     else
+	returnNF_Tc kind)	`thenNF_Tc` \ kind' ->
+
+    tcNewMutTyVar name kind'
+
+tcInstSigVar tyvar	-- Very similar to tcInstTyVar
+  = tcGetUnique 	`thenNF_Tc` \ uniq ->
+    let 
+	name = setNameUnique (tyVarName tyvar) uniq
+	kind = tyVarKind tyvar
     in
-    tcNewMutTyVar name kind
+    ASSERT( not (kind == openTypeKind) )	-- Shouldn't happen
+    tcNewSigTyVar name kind
 \end{code}
 
 @tcInstTcType@ instantiates the outer-level for-alls of a TcType with
@@ -344,7 +371,7 @@ 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
+	= mkPrimTyCon tc_name kind 0 [] VoidRep
 	where
 	  tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv)
 
@@ -406,6 +433,9 @@ 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 (FunTy arg res)      	  = go arg		`thenNF_Tc` \ arg' ->
 				    go res		`thenNF_Tc` \ res' ->
 				    returnNF_Tc (FunTy arg' res')
@@ -436,7 +466,8 @@ 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	-> zonkType unbound_var_fn other_ty	-- Bound
+	  Just other_ty	-> ASSERT( isNotUsgTy other_ty )
+                           zonkType unbound_var_fn other_ty	-- Bound
 \end{code}
 
 %************************************************************************