[project @ 2000-03-24 17:49:29 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index ce5d681..af02410 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -4,8 +4,8 @@
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
 
 \begin{code}
-module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
-                   tcContext, tcHsTyVar, kcHsTyVar,
+module TcMonoType ( tcHsType, tcHsSigType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
+                   tcContext, tcHsTyVar, kcHsTyVar, kcHsType,
                    tcExtendTyVarScope, tcExtendTopTyVarScope,
                    TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
                    checkSigTyVars, sigCtxt, sigPatCtxt
@@ -32,8 +32,9 @@ import Inst           ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
 import TcUnify         ( unifyKind, unifyKinds, unifyTypeKind )
 import Type            ( Type, PredType(..), ThetaType, UsageAnn(..),
                          mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
-                          mkUsForAllTy, zipFunTys,
-                         mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy,
+                          mkUsForAllTy, zipFunTys, hoistForAllTys,
+                         mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp,
+                         mkAppTys, splitForAllTys, splitRhoTy,
                          boxedTypeKind, unboxedTypeKind, tyVarsOfType,
                          mkArrowKinds, getTyVar_maybe, getTyVar,
                          tidyOpenType, tidyOpenTypes, tidyTyVar,
@@ -71,6 +72,18 @@ tcHsType and tcHsTypeKind
 tcHsType checks that the type really is of kind Type!
 
 \begin{code}
+kcHsType :: RenamedHsType -> TcM c ()
+  -- Kind-check the type
+kcHsType ty = tc_type ty       `thenTc_`
+             returnTc ()
+
+tcHsSigType :: RenamedHsType -> TcM s TcType
+  -- Used for type sigs written by the programmer
+  -- Hoist any inner for-alls to the top
+tcHsSigType ty
+  = tcHsType ty                `thenTc` \ ty' ->
+    returnTc (hoistForAllTys ty')
+
 tcHsType :: RenamedHsType -> TcM s TcType
 tcHsType ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
@@ -99,20 +112,22 @@ tcHsTopType :: RenamedHsType -> TcM s Type
 tcHsTopType ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
     tc_type ty                         `thenTc` \ ty' ->
-    forkNF_Tc (zonkTcTypeToType ty')
+    forkNF_Tc (zonkTcTypeToType ty')   `thenTc` \ ty'' ->
+    returnTc (hoistForAllTys ty'')
+
+tcHsTopBoxedType :: RenamedHsType -> TcM s Type
+tcHsTopBoxedType ty
+  = -- tcAddErrCtxt (typeCtxt ty)              $
+    tc_boxed_type ty                   `thenTc` \ ty' ->
+    forkNF_Tc (zonkTcTypeToType ty')   `thenTc` \ ty'' ->
+    returnTc (hoistForAllTys ty'')
 
 tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type)
 tcHsTopTypeKind ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
     tc_type_kind ty                            `thenTc` \ (kind, ty') ->
     forkNF_Tc (zonkTcTypeToType ty')           `thenTc` \ zonked_ty ->
-    returnNF_Tc (kind, zonked_ty)
-
-tcHsTopBoxedType :: RenamedHsType -> TcM s Type
-tcHsTopBoxedType ty
-  = -- tcAddErrCtxt (typeCtxt ty)              $
-    tc_boxed_type ty                   `thenTc` \ ty' ->
-    forkNF_Tc (zonkTcTypeToType ty')
+    returnNF_Tc (kind, hoistForAllTys zonked_ty)
 \end{code}
 
 
@@ -140,7 +155,7 @@ tc_type ty
 tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type)
 tc_type_kind ty@(MonoTyVar name)
   = tc_app ty []
-    
+
 tc_type_kind (MonoListTy ty)
   = tc_boxed_type ty           `thenTc` \ tau_ty ->
     returnTc (boxedTypeKind, mkListTy tau_ty)
@@ -161,6 +176,10 @@ tc_type_kind (MonoFunTy ty1 ty2)
 tc_type_kind (MonoTyApp ty1 ty2)
   = tc_app ty1 [ty2]
 
+tc_type_kind (MonoIParamTy n ty)
+  = tc_type ty `thenTc` \ tau ->
+    returnTc (boxedTypeKind, mkPredTy (IParam n tau))
+
 tc_type_kind (MonoDictTy class_name tys)
   = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) ->
     returnTc (boxedTypeKind, mkDictTy clas arg_tys)
@@ -392,6 +411,9 @@ data TcSigInfo
 
        SrcLoc                  -- Of the signature
 
+instance Outputable TcSigInfo where
+    ppr (TySigInfo nm id tyvars theta tau _ inst loc) =
+       ppr nm <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
 
 maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
        -- Search for a particular signature
@@ -407,7 +429,7 @@ tcTySig :: RenamedSig -> TcM s TcSigInfo
 
 tcTySig (Sig v ty src_loc)
  = tcAddSrcLoc src_loc $
-   tcHsType ty                                 `thenTc` \ sigma_tc_ty ->
+   tcHsSigType ty                              `thenTc` \ sigma_tc_ty ->
    mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> 
    returnTc sig