[project @ 2001-10-19 10:04:37 by sewardj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcMonoType.lhs

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index d57b53b..867fa9d 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -43,7 +43,7 @@ import TcType         ( Type, Kind, SourceType(..), ThetaType,
                          mkAppTys, mkRhoTy,
                          liftedTypeKind, unliftedTypeKind, mkArrowKind,
                          mkArrowKinds, tcGetTyVar_maybe, tcGetTyVar, tcSplitFunTy_maybe,
-                         tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
+                         tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
                          tyVarsOfType, mkForAllTys
                        )
 import Inst            ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
@@ -61,7 +61,7 @@ import Name           ( Name )
 import TysWiredIn      ( mkListTy, mkTupleTy, genUnitTyCon )
 import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( SrcLoc )
-import Util            ( mapAccumL, isSingleton )
+import Util            ( isSingleton )
 import Outputable
 
 \end{code}
@@ -77,7 +77,7 @@ Generally speaking we now type-check types in three phases
 
        1.  Kind check the HsType [kcHsType]
        2.  Convert from HsType to Type, and hoist the foralls [tcHsType]
-       3.  Check the validity of the resultint type [checkValidType]
+       3.  Check the validity of the resulting type [checkValidType]
 
 Often these steps are done one after the othe (tcHsSigType).
 But in mutually recursive groups of type and class decls we do
@@ -445,12 +445,8 @@ tc_fun_type name arg_tys
        ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
 
        AGlobal (ATyCon tc)
-               | isSynTyCon tc ->  returnTc (mkAppTys (mkSynTy tc (take arity arg_tys))
-                                                      (drop arity arg_tys))
+               | isSynTyCon tc ->  returnTc (mkSynTy tc arg_tys)
                | otherwise     ->  returnTc (mkTyConApp tc arg_tys)
-               where
-                   arity = tyConArity tc
-
 
        other -> failWithTc (wrongThingErr "type constructor" thing name)
 \end{code}
@@ -696,8 +692,8 @@ checkSigTyVars sig_tyvars free_tyvars
 
         failWithTcM (env3, main_msg $$ nest 4 (vcat msgs))
       where
-       (env1, tidy_tvs) = mapAccumL tidyTyVar emptyTidyEnv sig_tyvars
-       (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
+       (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tyvars
+       (env2, tidy_tys) = tidyOpenTypes  env1         sig_tys
 
        main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
 
@@ -770,7 +766,7 @@ find_frees tv tidy_env acc (ftv:ftvs)
   = zonkTcTyVar ftv    `thenNF_Tc` \ ty ->
     if tv `elemVarSet` tyVarsOfType ty then
        let
-           (tidy_env', ftv') = tidyTyVar tidy_env ftv
+           (tidy_env', ftv') = tidyOpenTyVar tidy_env ftv
        in
        find_frees tv tidy_env' (ftv':acc) ftvs
     else
@@ -814,7 +810,7 @@ sigCtxt :: Message -> [TcTyVar] -> TcThetaType -> TcTauType
 sigCtxt when sig_tyvars sig_theta sig_tau tidy_env
   = zonkTcType sig_tau         `thenNF_Tc` \ actual_tau ->
     let
-       (env1, tidy_sig_tyvars)  = tidyTyVars tidy_env sig_tyvars
+       (env1, tidy_sig_tyvars)  = tidyOpenTyVars tidy_env sig_tyvars
        (env2, tidy_sig_rho)     = tidyOpenType env1 (mkRhoTy sig_theta sig_tau)
        (env3, tidy_actual_tau)  = tidyOpenType env2 actual_tau
        msg = vcat [ptext SLIT("Signature type:    ") <+> pprType (mkForAllTys tidy_sig_tyvars tidy_sig_rho),