[project @ 2002-02-27 13:37:02 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 4445b91..3a03d97 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 ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, 
+module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred,
                    UserTypeCtxt(..),
 
                        -- Kind checking
@@ -28,22 +28,20 @@ import TcEnv                ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal,
                          tcInLocalScope,
                          TyThing(..), TcTyThing(..), tcExtendKindEnv
                        )
-import TcMType         ( newKindVar, tcInstSigTyVars, zonkKindEnv, 
+import TcMType         ( newKindVar, zonkKindEnv, tcInstSigType,
                          checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
                        )
 import TcUnify         ( unifyKind, unifyOpenTypeKind )
 import TcType          ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
                          TcTyVar, TcKind, TcThetaType, TcTauType,
                          mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
-                         tcSplitForAllTys, tcSplitRhoTy, 
                          hoistForAllTys, zipFunTys, 
                          mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, 
                          liftedTypeKind, unliftedTypeKind, mkArrowKind,
                          mkArrowKinds, tcSplitFunTy_maybe
                        )
-
 import Inst            ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
-import Subst           ( mkTopTyVarSubst, substTy )
+
 import Id              ( mkLocalId, idName, idType )
 import Var             ( TyVar, mkTyVar, tyVarKind )
 import ErrUtils                ( Message )
@@ -51,7 +49,7 @@ import TyCon          ( TyCon, isSynTyCon, tyConKind )
 import Class           ( classTyCon )
 import Name            ( Name )
 import NameSet
-import TysWiredIn      ( mkListTy, mkTupleTy, genUnitTyCon )
+import TysWiredIn      ( mkListTy, mkPArrTy, mkTupleTy, genUnitTyCon )
 import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( SrcLoc )
 import Util            ( lengthIs )
@@ -265,10 +263,19 @@ kcHsLiftedSigType = kcLiftedType
 kcHsType :: RenamedHsType -> TcM TcKind
 kcHsType (HsTyVar name)              = kcTyVar name
 
+kcHsType (HsKindSig ty k)
+  = kcHsType ty                        `thenTc` \ k' ->
+    unifyKind k k'             `thenTc_`
+    returnTc k
+
 kcHsType (HsListTy ty)
   = kcLiftedType ty            `thenTc` \ tau_ty ->
     returnTc liftedTypeKind
 
+kcHsType (HsPArrTy ty)
+  = kcLiftedType ty            `thenTc` \ tau_ty ->
+    returnTc liftedTypeKind
+
 kcHsType (HsTupleTy (HsTupCon _ boxity _) tys)
   = mapTc kcTypeType tys       `thenTc_`
     returnTc (case boxity of
@@ -321,18 +328,27 @@ kcAppKind fun_kind arg_kind
 
 
 ---------------------------
-kcHsContext ctxt = mapTc_ kcHsPred ctxt
+kc_pred :: RenamedHsPred -> TcM TcKind -- Does *not* check for a saturated
+                                       -- application (reason: used from TcDeriv)
+kc_pred pred@(HsIParam name ty)
+  = kcHsType ty
+
+kc_pred pred@(HsClassP cls tys)
+  = kcClass cls                                `thenTc` \ kind ->
+    mapTc kcHsType tys                 `thenTc` \ arg_kinds ->
+    newKindVar                                 `thenNF_Tc` \ kv -> 
+    unifyKind kind (mkArrowKinds arg_kinds kv) `thenTc_` 
+    returnTc kv
 
-kcHsPred :: RenamedHsPred -> TcM ()
-kcHsPred pred@(HsIParam name ty)
-  = tcAddErrCtxt (appKindCtxt (ppr pred))      $
-    kcLiftedType ty
+---------------------------
+kcHsContext ctxt = mapTc_ kcHsPred ctxt
 
-kcHsPred pred@(HsClassP cls tys)
+kcHsPred pred          -- Checks that the result is of kind liftedType
   = tcAddErrCtxt (appKindCtxt (ppr pred))      $
-    kcClass cls                                        `thenTc` \ kind ->
-    mapTc kcHsType tys                         `thenTc` \ arg_kinds ->
-    unifyKind kind (mkArrowKinds arg_kinds liftedTypeKind)
+    kc_pred pred                               `thenTc` \ kind ->
+    unifyKind liftedTypeKind kind              `thenTc_`
+    returnTc ()
+    
 
  ---------------------------
 kcTyVar name   -- Could be a tyvar or a tycon
@@ -389,10 +405,17 @@ tc_type :: RenamedHsType -> TcM Type
 tc_type ty@(HsTyVar name)
   = tc_app ty []
 
+tc_type (HsKindSig ty k)
+  = tc_type ty -- Kind checking done already
+
 tc_type (HsListTy ty)
   = tc_type ty `thenTc` \ tau_ty ->
     returnTc (mkListTy tau_ty)
 
+tc_type (HsPArrTy ty)
+  = tc_type ty `thenTc` \ tau_ty ->
+    returnTc (mkPArrTy tau_ty)
+
 tc_type (HsTupleTy (HsTupCon _ boxity arity) tys)
   = ASSERT( tys `lengthIs` arity )
     tc_types tys       `thenTc` \ tau_tys ->
@@ -468,6 +491,10 @@ tc_fun_type name arg_tys
 Contexts
 ~~~~~~~~
 \begin{code}
+tcHsPred pred = kc_pred pred `thenTc_`  tc_pred pred
+       -- Is happy with a partial application, e.g. (ST s)
+       -- Used from TcDeriv
+
 tc_pred assn@(HsClassP class_name tys)
   = tcAddErrCtxt (appKindCtxt (ppr assn))      $
     tc_types tys                       `thenTc` \ arg_tys ->
@@ -571,30 +598,16 @@ mkTcSig poly_id src_loc
        -- the tyvars *do* get unified with something, we want to carry on
        -- typechecking the rest of the program with the function bound
        -- to a pristine type, namely sigma_tc_ty
-   let
-       (tyvars, rho) = tcSplitForAllTys (idType poly_id)
-   in
-   tcInstSigTyVars SigTv tyvars                        `thenNF_Tc` \ tyvars' ->
-       -- Make *signature* type variables
-
-   let
-     tyvar_tys' = mkTyVarTys tyvars'
-     rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho
-       -- mkTopTyVarSubst because the tyvars' are fresh
-
-     (theta', tau') = tcSplitRhoTy rho'
-       -- This splitRhoTy tries hard to make sure that tau' is a type synonym
-       -- wherever possible, which can improve interface files.
-   in
+   tcInstSigType SigTv (idType poly_id)                `thenNF_Tc` \ (tyvars', theta', tau') ->
+
    newMethodWithGivenTy SignatureOrigin 
-               poly_id
-               tyvar_tys'
-               theta' tau'                     `thenNF_Tc` \ inst ->
+                       poly_id
+                       (mkTyVarTys tyvars')
+                       theta' tau'             `thenNF_Tc` \ inst ->
        -- We make a Method even if it's not overloaded; no harm
        
-   returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToId inst) [inst] src_loc)
-  where
-    name = idName poly_id
+   returnNF_Tc (TySigInfo (idName poly_id) poly_id tyvars' theta' tau' 
+                         (instToId inst) [inst] src_loc)
 \end{code}