[commit: ghc] master: Some minor refactoring in TcHsType (d058bc9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d058bc9ce04e8397c8fd0a32a8654b83f3ef4af1/ghc

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

commit d058bc9ce04e8397c8fd0a32a8654b83f3ef4af1
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Mar 3 21:54:58 2015 +0000

    Some minor refactoring in TcHsType


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

d058bc9ce04e8397c8fd0a32a8654b83f3ef4af1
 compiler/typecheck/TcHsType.hs | 37 ++++++++++++++++++++-----------------
 1 file changed, 20 insertions(+), 17 deletions(-)

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 0cb128e..fbd21b2 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -8,7 +8,7 @@
 {-# LANGUAGE CPP #-}
 
 module TcHsType (
-        tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst,
+        tcHsSigType, tcHsDeriv, tcHsVectInst,
         tcHsInstHead,
         UserTypeCtxt(..),
 
@@ -21,7 +21,7 @@ module TcHsType (
                 -- No kind generalisation, no checkValidType
         kcHsTyVarBndrs, tcHsTyVarBndrs,
         tcHsLiftedType, tcHsOpenType,
-        tcLHsType, tcCheckLHsType,
+        tcLHsType, tcCheckLHsType, tcCheckLHsTypeAndGen,
         tcHsContext, tcInferApps, tcHsArgTys,
 
         kindGeneralize, checkKind,
@@ -155,17 +155,13 @@ the TyCon being defined.
 ************************************************************************
 -}
 
-tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type
+tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type
   -- NB: it's important that the foralls that come from the top-level
   --     HsForAllTy in hs_ty occur *first* in the returned type.
   --     See Note [Scoped] with TcSigInfo
-tcHsSigType ctxt hs_ty
-  = addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $
-    tcHsSigTypeNC ctxt hs_ty
-
-tcHsSigTypeNC ctxt (L loc hs_ty)
-  = setSrcSpan loc $    -- The "In the type..." context
-                        -- comes from the caller; hence "NC"
+tcHsSigType ctxt (L loc hs_ty)
+  = setSrcSpan loc $
+    addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $
     do  { kind <- case expectedKindInCtxt ctxt of
                     Nothing -> newMetaKindVar
                     Just k  -> return k
@@ -182,7 +178,7 @@ tcHsSigTypeNC ctxt (L loc hs_ty)
 
 -----------------
 tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type])
--- Like tcHsSigTypeNC, but for an instance head.
+-- Like tcHsSigType, but for an instance head.
 tcHsInstHead user_ctxt lhs_ty@(L loc hs_ty)
   = setSrcSpan loc $    -- The "In the type..." context comes from the caller
     do { inst_ty <- tc_inst_head hs_ty
@@ -203,7 +199,7 @@ tc_inst_head hs_ty
 
 -----------------
 tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type], Kind)
--- Like tcHsSigTypeNC, but for the ...deriving( C t1 ty2 ) clause
+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
 -- Returns the C, [ty1, ty2, and the kind of C's *next* argument
 -- E.g.    class C (a::*) (b::k->k)
 --         data T a b = ... deriving( C Int )
@@ -247,9 +243,8 @@ tcHsVectInst ty
 -}
 
 tcClassSigType :: LHsType Name -> TcM Type
-tcClassSigType lhs_ty@(L _ hs_ty)
-  = addTypeCtxt lhs_ty $
-    do { ty <- tcCheckHsTypeAndGen hs_ty liftedTypeKind
+tcClassSigType lhs_ty
+  = do { ty <- tcCheckLHsTypeAndGen lhs_ty liftedTypeKind
        ; zonkSigType ty }
 
 tcHsConArgType :: NewOrData ->  LHsType Name -> TcM Type
@@ -294,10 +289,18 @@ tcLHsType :: LHsType Name -> TcM (TcType, TcKind)
 tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty)
 
 ---------------------------
-tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type
--- Input type is HsType, not LhsType; the caller adds the context
+tcCheckLHsTypeAndGen :: LHsType Name -> Kind -> TcM Type
 -- Typecheck a type signature, and kind-generalise it
 -- The result is not necessarily zonked, and has not been checked for validity
+tcCheckLHsTypeAndGen lhs_ty kind
+  = do { ty  <- tcCheckLHsType lhs_ty kind
+       ; kvs <- zonkTcTypeAndFV ty
+       ; kvs <- kindGeneralize kvs
+       ; return (mkForAllTys kvs ty) }
+
+tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type
+-- Input type is HsType, not LHsType; the caller adds the context
+-- Otherwise same as tcCheckLHsTypeAndGen
 tcCheckHsTypeAndGen hs_ty kind
   = do { ty  <- tc_hs_type hs_ty (EK kind expectedKindMsg)
        ; traceTc "tcCheckHsTypeAndGen" (ppr hs_ty)