[project @ 2004-09-12 11:45:04 by panne]

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

diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs
index ea1444c..c7e0cba 100644 (file)
--- a/ghc/compiler/typecheck/TcHsType.lhs
+++ b/ghc/compiler/typecheck/TcHsType.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module TcHsType (
-       tcHsSigType, tcHsPred,
+       tcHsSigType, tcHsDeriv,
        UserTypeCtxt(..), 
 
                -- Kind checking
@@ -50,7 +50,7 @@ import Inst           ( Inst, InstOrigin(..), newMethod, instToId )
 import Id              ( mkLocalId, idName, idType )
 import Var             ( TyVar, mkTyVar, tyVarKind )
 import TyCon           ( TyCon, tyConKind )
-import Class           ( classTyCon )
+import Class           ( Class, classTyCon )
 import Name            ( Name )
 import NameSet
 import PrelNames       ( genUnitTyConName )
@@ -154,13 +154,27 @@ tcHsSigType ctxt hs_ty
        ; ty <- tcHsKindedType kinded_ty
        ; checkValidType ctxt ty        
        ; returnM ty }
-
--- tcHsPred is happy with a partial application, e.g. (ST s)
--- Used from TcDeriv
-tcHsPred pred 
-  = do { (kinded_pred,_) <- wrapLocFstM kc_pred pred   -- kc_pred rather than kcHsPred
-                                                       -- to avoid the partial application check
-       ; dsHsPred kinded_pred }
+-- Used for the deriving(...) items
+tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type])
+tcHsDeriv = addLocM (tc_hs_deriv [])
+
+tc_hs_deriv tv_names (HsPredTy (HsClassP cls_name hs_tys))
+  = kcHsTyVars tv_names                $ \ tv_names' ->
+    do { cls_kind <- kcClass cls_name
+       ; (tys, res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys
+       ; tcTyVarBndrs tv_names'        $ \ tyvars ->
+    do { arg_tys <- dsHsTypes tys
+       ; cls <- tcLookupClass cls_name
+       ; return (tyvars, cls, arg_tys) }}
+
+tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty))
+  =    -- Funny newtype deriving form
+       --      forall a. C [a]
+       -- where C has arity 2.  Hence can't use regular functions
+    tc_hs_deriv (tv_names1 ++ tv_names2) ty
+
+tc_hs_deriv _ other
+  = failWithTc (ptext SLIT("Illegal deriving item") <+> ppr other)
 \end{code}
 
        These functions are used during knot-tying in
@@ -186,7 +200,7 @@ tcHsKindedType hs_ty
 tcHsKindedContext :: LHsContext Name -> TcM ThetaType
 -- Used when we are expecting a ClassContext (i.e. no implicit params)
 -- Does not do validity checking, like tcHsKindedType
-tcHsKindedContext hs_theta = addLocM (mappM dsHsPred) hs_theta
+tcHsKindedContext hs_theta = addLocM (mappM dsHsLPred) hs_theta
 \end{code}
 
 
@@ -300,16 +314,14 @@ kc_hs_type (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names                $ \ tv_names' ->
     kcHsContext context                `thenM` \ ctxt' ->
     kcLiftedType ty            `thenM` \ ty' ->
-       -- The body of a forall must be a type, but in principle
+       -- The body of a forall is usually a type, but in principle
        -- there's no reason to prohibit *unlifted* types.
        -- In fact, GHC can itself construct a function with an
        -- unboxed tuple inside a for-all (via CPR analyis; see 
        -- typecheck/should_compile/tc170)
        --
        -- Still, that's only for internal interfaces, which aren't
-       -- kind-checked, and it's a bit inconvenient to use kcTypeType
-       -- here (because it doesn't return the result kind), so I'm 
-       -- leaving it as lifted types for now.
+       -- kind-checked, so we only allow liftedTypeKind here
     returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
 
 ---------------------------
@@ -336,13 +348,16 @@ kcApps fun_kind ppr_fun args
 
 ---------------------------
 kcHsContext :: LHsContext Name -> TcM (LHsContext Name)
-kcHsContext ctxt = wrapLocM (mappM kcHsPred) ctxt
+kcHsContext ctxt = wrapLocM (mappM kcHsLPred) ctxt
+
+kcHsLPred :: LHsPred Name -> TcM (LHsPred Name)
+kcHsLPred = wrapLocM kcHsPred
 
-kcHsPred (L span pred)         -- Checks that the result is of kind liftedType
-  = addSrcSpan span $
-    kc_pred pred                               `thenM` \ (pred', kind) ->
+kcHsPred :: HsPred Name -> TcM (HsPred Name)
+kcHsPred pred  -- Checks that the result is of kind liftedType
+  = kc_pred pred                               `thenM` \ (pred', kind) ->
     checkExpectedKind pred kind liftedTypeKind `thenM_` 
-    returnM (L span pred')
+    returnM pred'
     
 ---------------------------
 kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind)    
@@ -442,7 +457,7 @@ ds_type (HsPredTy pred)
 
 ds_type full_ty@(HsForAllTy exp tv_names ctxt ty)
   = tcTyVarBndrs tv_names              $ \ tyvars ->
-    mappM dsHsPred (unLoc ctxt)                `thenM` \ theta ->
+    mappM dsHsLPred (unLoc ctxt)       `thenM` \ theta ->
     dsHsType ty                                `thenM` \ tau ->
     returnM (mkSigmaTy tyvars theta tau)
 
@@ -479,15 +494,15 @@ ds_var_app name arg_tys
 Contexts
 ~~~~~~~~
 \begin{code}
-dsHsPred :: LHsPred Name -> TcM PredType
-dsHsPred pred = ds_pred (unLoc pred)
+dsHsLPred :: LHsPred Name -> TcM PredType
+dsHsLPred pred = dsHsPred (unLoc pred)
 
-ds_pred pred@(HsClassP class_name tys)
+dsHsPred pred@(HsClassP class_name tys)
   = dsHsTypes tys                      `thenM` \ arg_tys ->
     tcLookupClass class_name           `thenM` \ clas ->
     returnM (ClassP clas arg_tys)
 
-ds_pred (HsIParam name ty)
+dsHsPred (HsIParam name ty)
   = dsHsType ty                                        `thenM` \ arg_ty ->
     returnM (IParam name arg_ty)
 \end{code}