X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=b4e89b092ef80a3a441cd39218d6fc9dd0832834;hb=3a99fa889bdff0c86df20cb18c71d30e30a79b43;hp=4633f49a9dc01806fa948d4102d5cdc2efc16de6;hpb=335bc125303a226a78b20be8a7b8fec5b6c59d2b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 4633f49..b4e89b0 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -47,7 +47,8 @@ module TcMType (
   --------------------------------
   -- Zonking
   zonkType, zonkTcPredType, 
-  zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkQuantifiedTyVar,
+  zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, 
+  zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
   zonkTcKindToKind, zonkTcKind, zonkTopTyVar,
 
@@ -61,7 +62,6 @@ module TcMType (
 import TypeRep
 import TcType
 import Type
-import Type
 import Coercion
 import Class
 import TyCon
@@ -78,6 +78,7 @@ import Util
 import Maybes
 import ListSetOps
 import UniqSupply
+import SrcLoc
 import Outputable
 
 import Control.Monad	( when )
@@ -160,19 +161,30 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
 tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
 			      | tv <- tyvars ]
 
-tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
--- Instantiate a type with fresh skolem constants
-tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
-
-tcInstSkolTyVar :: SkolemInfo -> TyVar -> TcM TcTyVar
-tcInstSkolTyVar info tyvar
+tcInstSkolTyVar :: SkolemInfo -> Maybe SrcLoc -> TyVar -> TcM TcTyVar
+-- Instantiate the tyvar, using 
+--	* the occ-name and kind of the supplied tyvar, 
+--	* the unique from the monad,
+--	* the location either from the tyvar (mb_loc = Nothing)
+--	  or from mb_loc (Just loc)
+tcInstSkolTyVar info mb_loc tyvar
   = do	{ uniq <- newUnique
-	; let name = setNameUnique (tyVarName tyvar) uniq
-	      kind = tyVarKind tyvar
-	; return (mkSkolTyVar name kind info) }
+	; let old_name = tyVarName tyvar
+	      kind     = tyVarKind tyvar
+	      loc      = mb_loc `orElse` getSrcLoc old_name
+	      new_name = mkInternalName uniq (nameOccName old_name) loc
+	; return (mkSkolTyVar new_name kind info) }
 
 tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
-tcInstSkolTyVars info tyvars = mapM (tcInstSkolTyVar info) tyvars
+-- Get the location from the monad
+tcInstSkolTyVars info tyvars 
+  = do 	{ span <- getSrcSpanM
+	; mapM (tcInstSkolTyVar info (Just (srcSpanStart span))) tyvars }
+
+tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
+-- Instantiate a type with fresh skolem constants
+-- Binding location comes from the monad
+tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
 \end{code}
 
 
@@ -275,9 +287,14 @@ tcInstTyVars tyvars
 %************************************************************************
 
 \begin{code}
-tcInstSigTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
--- Instantiate with meta SigTvs
-tcInstSigTyVars skol_info tyvars 
+tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar]
+-- Instantiate with skolems or meta SigTvs; depending on use_skols
+-- Always take location info from the supplied tyvars
+tcInstSigTyVars use_skols skol_info tyvars 
+  | use_skols
+  = mapM (tcInstSkolTyVar skol_info Nothing) tyvars
+
+  | otherwise
   = mapM (instMetaTyVar (SigTv skol_info)) tyvars
 
 zonkSigTyVar :: TcTyVar -> TcM TcTyVar
@@ -342,7 +359,7 @@ data LookupTyVarResult	-- The result of a lookupTcTyVar call
 
 lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
 lookupTcTyVar tyvar 
-  = ASSERT( isTcTyVar tyvar )
+  = ASSERT2( isTcTyVar tyvar, ppr tyvar )
     case details of
       SkolemTv _   -> return (DoneTv details)
       MetaTv _ ref -> do { meta_details <- readMutVar ref
@@ -467,17 +484,24 @@ zonkTopTyVar tv
     k = tyVarKind tv
     default_k = defaultKind k
 
+zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TyVar]
+zonkQuantifiedTyVars = mappM zonkQuantifiedTyVar
+
 zonkQuantifiedTyVar :: TcTyVar -> TcM TyVar
 -- zonkQuantifiedTyVar is applied to the a TcTyVar when quantifying over it.
--- It might be a meta TyVar, in which case we freeze it into an ordinary TyVar.
--- When we do this, we also default the kind -- see notes with Kind.defaultKind
+--
+-- The quantified type variables often include meta type variables
+-- we want to freeze them into ordinary type variables, and
+-- default their kind (e.g. from OpenTypeKind to TypeKind)
+-- 			-- see notes with Kind.defaultKind
 -- The meta tyvar is updated to point to the new regular TyVar.  Now any 
 -- bound occurences of the original type variable will get zonked to 
 -- the immutable version.
 --
 -- We leave skolem TyVars alone; they are immutable.
 zonkQuantifiedTyVar tv
-  | isSkolemTyVar tv = return tv
+  | ASSERT( isTcTyVar tv ) 
+    isSkolemTyVar tv = return tv
 	-- It might be a skolem type variable, 
 	-- for example from a user type signature
 
@@ -686,7 +710,6 @@ checkValidType ctxt ty
 		 ConArgCtxt _   -> Rank 1	-- We are given the type of the entire
 						-- constructor, hence rank 1
 		 ForSigCtxt _	-> Rank 1
-		 RuleSigCtxt _	-> Rank 1
 		 SpecInstCtxt   -> Rank 1
 
 	actual_kind = typeKind ty
@@ -1012,7 +1035,9 @@ even in a scope where b is in scope.
 
 \begin{code}
 checkFreeness forall_tyvars theta
-  = mappM_ complain (filter is_free theta)
+  = do	{ gla_exts <- doptM Opt_GlasgowExts
+	; if gla_exts then return ()	-- New!  Oct06
+	  else mappM_ complain (filter is_free theta) }
   where    
     is_free pred     =  not (isIPPred pred)
 		     && not (any bound_var (varSetElems (tyVarsOfPred pred)))