[project @ 2001-05-24 13:59:09 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index b755fe0..9fa3806 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -13,7 +13,7 @@ module TcTyClsDecls (
 import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
 import HsSyn           ( TyClDecl(..),  
                          ConDecl(..),   Sig(..), HsPred(..), 
-                         tyClDeclName, hsTyVarNames, 
+                         tyClDeclName, hsTyVarNames, tyClDeclTyVars,
                          isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
                        )
 import RnHsSyn         ( RenamedTyClDecl, tyClDeclFVs )
@@ -30,11 +30,11 @@ import TcType               ( TcKind, newKindVar, zonkKindEnv )
 
 import TcUnify         ( unifyKind )
 import TcInstDcls      ( tcAddDeclCtxt )
-import Type            ( Kind, mkArrowKind, zipFunTys )
+import Type            ( Kind, mkArrowKind, liftedTypeKind, zipFunTys )
 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
 import TyCon           ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), 
-                         mkSynTyCon, mkAlgTyCon, mkClassTyCon )
+                         mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon )
 import DataCon         ( isNullaryDataCon )
 import Var             ( varName )
 import FiniteMap
@@ -134,6 +134,7 @@ tcGroup unf_env scc
     zonkKindEnv initial_kinds                  `thenNF_Tc` \ final_kinds ->
 
        -- Tie the knot
+    traceTc (text "starting" <+> ppr final_kinds)              `thenTc_`
     fixTc ( \ ~(rec_details_list, _, _) ->
                -- Step 4 
        let
@@ -164,6 +165,8 @@ tcGroup unf_env scc
 
     tcSetEnv env                               $
 
+    traceTc (text "ready for pass 2" <+> ppr (isRec is_rec))                   `thenTc_`
+
        -- Step 6
        -- For a recursive group, check all the types again,
        -- this time with the wimp flag off
@@ -173,6 +176,8 @@ tcGroup unf_env scc
        returnTc ()
     )                                          `thenTc_`
 
+    traceTc (text "done")                      `thenTc_`
+
        -- Step 7
        -- Extend the environment with the final TyCons/Classes 
        -- and their implicit Ids
@@ -202,8 +207,8 @@ tcTyClDecl1 is_rec unf_env decl
 \begin{code}
 getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
 getInitialKind decl
- = kcHsTyVars (tcdTyVars decl) `thenNF_Tc` \ arg_kinds ->
-   newKindVar                  `thenNF_Tc` \ result_kind  ->
+ = kcHsTyVars (tyClDeclTyVars decl)    `thenNF_Tc` \ arg_kinds ->
+   newKindVar                          `thenNF_Tc` \ result_kind  ->
    returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
 
 mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
@@ -237,6 +242,8 @@ kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
     kcHsType rhs               `thenTc` \ rhs_kind ->
     unifyKind result_kind rhs_kind
 
+kcTyClDecl (ForeignType {}) = returnTc ()
+
 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 
@@ -268,7 +275,7 @@ kcTyClDeclBody decl thing_inside
                  AThing kind         -> kind
                -- For some odd reason, a class doesn't include its kind
 
-       (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tcdTyVars decl)) kind
+       (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind
     in
     tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 \end{code}
@@ -322,6 +329,10 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                                 | otherwise                      -> DataTyCon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
+                  (ForeignType {tcdName = tycon_name})
+  = ATyCon (mkForeignTyCon tycon_name liftedTypeKind 0 [])
+
+buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
                   (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
                              tcdFDs = fundeps, tcdSysNames = name_list} )
   = AClass clas
@@ -412,7 +423,7 @@ tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
 
 mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
 
-mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsPClass c _ <- ctxt])
+mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
 mkClassEdges other_decl                                               = Nothing
 
 mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])