[project @ 2001-02-20 15:35:28 by simonpj]

Use tcIfaceType

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index a606b16..e0fdf71 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -10,11 +10,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
 
 import HsSyn           ( TyClDecl(..), HsTupCon(..) )
 import TcMonad
-import TcMonoType      ( tcHsType )
-                               -- NB: all the tyars in interface files are kinded,
-                               -- so tcHsType will do the Right Thing without
-                               -- having to mess about with zonking
-
+import TcMonoType      ( tcIfaceType )
 import TcEnv           ( TcEnv, RecTcEnv, tcExtendTyVarEnv, 
                          tcExtendGlobalValEnv, tcSetEnv,
                          tcLookupGlobal_maybe, tcLookupRecId_maybe
@@ -66,7 +62,7 @@ tcInterfaceSigs unf_env decls
     do_one name ty id_infos src_loc
       = tcAddSrcLoc src_loc                            $       
        tcAddErrCtxt (ifaceSigCtxt name)                $
-       tcHsType ty                                     `thenTc` \ sigma_ty ->
+       tcIfaceType ty                                  `thenTc` \ sigma_ty ->
        tcIdInfo unf_env in_scope_vars name 
                 sigma_ty id_infos                      `thenTc` \ id_info ->
        returnTc (mkId name sigma_ty id_info)
@@ -184,7 +180,7 @@ UfCore expressions.
 tcCoreExpr :: UfExpr Name -> TcM CoreExpr
 
 tcCoreExpr (UfType ty)
-  = tcHsType ty                `thenTc` \ ty' ->
+  = tcIfaceType ty             `thenTc` \ ty' ->
        -- It might not be of kind type
     returnTc (Type ty')
 
@@ -198,11 +194,11 @@ tcCoreExpr (UfLit lit)
 -- The dreaded lit-lits are also similar, except here the type
 -- is read in explicitly rather than being implicit
 tcCoreExpr (UfLitLit lit ty)
-  = tcHsType ty                `thenTc` \ ty' ->
+  = tcIfaceType ty             `thenTc` \ ty' ->
     returnTc (Lit (MachLitLit lit ty'))
 
 tcCoreExpr (UfCCall cc ty)
-  = tcHsType ty        `thenTc` \ ty' ->
+  = tcIfaceType ty     `thenTc` \ ty' ->
     tcGetUnique                `thenNF_Tc` \ u ->
     returnTc (Var (mkCCallOpId u cc ty'))
 
@@ -254,7 +250,7 @@ tcCoreExpr (UfLet (UfRec pairs) body)
 tcCoreExpr (UfNote note expr) 
   = tcCoreExpr expr            `thenTc` \ expr' ->
     case note of
-       UfCoerce to_ty -> tcHsType to_ty        `thenTc` \ to_ty' ->
+       UfCoerce to_ty -> tcIfaceType to_ty     `thenTc` \ to_ty' ->
                          returnTc (Note (Coerce to_ty'
                                                  (exprType expr')) expr')
        UfInlineCall   -> returnTc (Note InlineCall expr')
@@ -264,7 +260,7 @@ tcCoreExpr (UfNote note expr)
 
 \begin{code}
 tcCoreLamBndr (UfValBinder name ty) thing_inside
-  = tcHsType ty                        `thenTc` \ ty' ->
+  = tcIfaceType ty             `thenTc` \ ty' ->
     let
        id = mkVanillaId name ty'
     in
@@ -284,7 +280,7 @@ tcCoreLamBndrs (b:bs) thing_inside
     thing_inside (b':bs')
 
 tcCoreValBndr (UfValBinder name ty) thing_inside
-  = tcHsType ty                        `thenTc` \ ty' ->
+  = tcIfaceType ty                     `thenTc` \ ty' ->
     let
        id = mkVanillaId name ty'
     in
@@ -292,7 +288,7 @@ tcCoreValBndr (UfValBinder name ty) thing_inside
     thing_inside id
     
 tcCoreValBndrs bndrs thing_inside              -- Expect them all to be ValBinders
-  = mapTc tcHsType tys                 `thenTc` \ tys' ->
+  = mapTc tcIfaceType tys              `thenTc` \ tys' ->
     let
        ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
     in
@@ -317,7 +313,7 @@ tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
   = ASSERT( null names )
     tcCoreExpr rhs             `thenTc` \ rhs' ->
-    tcHsType ty                        `thenTc` \ ty' ->
+    tcIfaceType ty             `thenTc` \ ty' ->
     returnTc (LitAlt (MachLitLit str ty'), [], rhs')
 
 -- A case alternative is made quite a bit more complicated

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 52aec0e..71bfb5b 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -4,7 +4,7 @@
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
 
 \begin{code}
-module TcMonoType ( tcHsType, tcHsRecType, 
+module TcMonoType ( tcHsType, tcHsRecType, tcIfaceType,
                    tcHsSigType, tcHsLiftedSigType, 
                    tcRecClassContext, checkAmbiguity,
 
@@ -290,14 +290,25 @@ tcHsSigType and tcHsLiftedSigType are used for type signatures written by the pr
 \begin{code}
 tcHsSigType, tcHsLiftedSigType :: RenamedHsType -> TcM Type
   -- Do kind checking, and hoist for-alls to the top
-tcHsSigType      ty = kcTypeType ty  `thenTc_`  tcHsType ty    
-tcHsLiftedSigType ty = kcLiftedType ty `thenTc_`  tcHsType ty
+tcHsSigType       ty = kcTypeType   ty `thenTc_` tcHsType ty   
+tcHsLiftedSigType ty = kcLiftedType ty `thenTc_` tcHsType ty
 
 tcHsType    ::            RenamedHsType -> TcM Type
 tcHsRecType :: RecFlag -> RenamedHsType -> TcM Type
   -- Don't do kind checking, but do hoist for-alls to the top
+  -- These are used in type and class decls, where kinding is
+  -- done in advance
 tcHsType             ty = tc_type NonRecursive ty  `thenTc` \ ty' ->  returnTc (hoistForAllTys ty')
 tcHsRecType wimp_out ty = tc_type wimp_out     ty  `thenTc` \ ty' ->  returnTc (hoistForAllTys ty')
+
+-- In interface files the type is already kinded,
+-- and we definitely don't want to hoist for-alls.
+-- Otherwise we'll change
+--     dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a
+-- into 
+--     dmfail :: forall m:(*->*) a:* Monad m => String -> m a
+-- which definitely isn't right!
+tcIfaceType ty = tc_type NonRecursive ty
 \end{code}