[commit: ghc] master: Very small tweaks to pave the way for solving kind constraints in the simplifier. (221f409)

[dimitris at microsoft.com]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/221f409db51f210d5395ec13ef4bf0c0883ad939

>---------------------------------------------------------------

commit 221f409db51f210d5395ec13ef4bf0c0883ad939
Author: Dimitrios Vytiniotis <dimitris at microsoft.com>
Date:   Thu Dec 22 11:36:09 2011 +0000

    Very small tweaks to pave the way for solving kind constraints in the simplifier.

>---------------------------------------------------------------

 compiler/typecheck/TcRnMonad.lhs |   11 +++++++++--
 compiler/typecheck/TcRnTypes.lhs |    5 +++++
 compiler/types/TypeRep.lhs       |    2 +-
 3 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 381d535..08125d7 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -23,6 +23,8 @@ import Module
 import RdrName
 import Name
 import Type
+import Kind ( isSuperKind )
+
 import TcType
 import InstEnv
 import FamInstEnv
@@ -1042,8 +1044,13 @@ captureUntouchables thing_inside
        ; return (res, TouchableRange low_meta high_meta) }
 
 isUntouchable :: TcTyVar -> TcM Bool
-isUntouchable tv = do { env <- getLclEnv
-                      ; return (varUnique tv < tcl_untch env) }
+isUntouchable tv
+    -- Kind variables are always touchable
+  | isSuperKind (tyVarKind tv) 
+  = return False
+  | otherwise 
+  = do { env <- getLclEnv
+       ; return (varUnique tv < tcl_untch env) }
 
 getLclTypeEnv :: TcM TcTypeEnv
 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index ab26fa1..b85a892 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -67,6 +67,7 @@ module TcRnTypes(
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
 	CtOrigin(..), EqOrigin(..), 
         WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
+        pushErrCtxtSameOrigin,
 
 	SkolemInfo(..),
 
@@ -1296,6 +1297,10 @@ setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
 pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig
 pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs)
 
+pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc orig -> CtLoc orig
+-- Just add information w/o updating the origin!
+pushErrCtxtSameOrigin err (CtLoc o s errs) = CtLoc o s (err:errs)
+
 pprArising :: CtOrigin -> SDoc
 -- Used for the main, top-level error message
 -- We've done special processing for TypeEq and FunDep origins
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 3458b63..26526ab 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -274,7 +274,7 @@ isLiftedTypeKind _                = False
 \begin{code}  
 tyVarsOfType :: Type -> VarSet
 -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
--- tyVarsOfType returns only the free *type* variables of a type
+-- tyVarsOfType returns only the free variables of a type
 -- For example, tyVarsOfType (a::k) returns {a}, not including the
 -- kind variable {k}
 tyVarsOfType (TyVarTy v)         = unitVarSet v