[project @ 1996-04-25 16:31:20 by partain]

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

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index e8595fd..38e25c9 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -23,13 +23,13 @@ import HsSyn                ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
 import RnHsSyn         ( RenamedTyDecl(..), RenamedConDecl(..),
                          RnName{-instance Outputable-}
                        )
-import TcHsSyn         ( mkHsTyLam, tcIdType, zonkId, TcHsBinds(..), TcIdOcc(..) )
-
+import TcHsSyn         ( mkHsTyLam, mkHsDictLam, tcIdType, zonkId,
+                         TcHsBinds(..), TcIdOcc(..)
+                       )
 import Inst            ( newDicts, InstOrigin(..), Inst )
-import TcMonoType      ( tcMonoTypeKind, tcMonoType, tcContext )
+import TcMonoType      ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
 import TcType          ( tcInstTyVars, tcInstType, tcInstId )
 import TcEnv           ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
-                         tcLookupClassByKey,
                          newLocalId, newLocalIds
                        )
 import TcMonad
@@ -50,12 +50,12 @@ import Name         ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
 import Pretty
 import TyCon           ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon, 
                          tyConDataCons )
-import Type            ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy,
+import Type            ( typeKind, getTyVar, tyVarsOfTypes, eqTy,
                          applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
                          splitFunTy, mkTyVarTy, getTyVar_maybe
                        )
-import TyVar           ( getTyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
-import Unique          ( Unique {- instance Eq -}, dataClassKey )
+import TyVar           ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
+import Unique          ( Unique {- instance Eq -}, evalClassKey )
 import UniqSet         ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
 import Util            ( equivClasses, zipEqual, panic, assertPanic )
 \end{code}
@@ -90,8 +90,8 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
        -- but the simplest thing to do seems to be to get the Kind by (lazily)
        -- looking at the tyvars and rhs_ty.
        result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
-       result_kind      = getTypeKind rhs_ty
-       final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
+       result_kind      = typeKind rhs_ty
+       final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
 
        -- Construct the tycon
        tycon = mkSynTyCon (getName tycon_name)
@@ -137,7 +137,7 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra
     let
        -- Construct the tycon
        final_tycon_kind :: Kind                -- NB not TcKind!
-       final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
+       final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
 
        tycon = mkDataTyCon (getName tycon_name)
                            final_tycon_kind
@@ -169,7 +169,7 @@ mkDataBinds tycon
     returnTc (con_ids ++ sel_ids, 
              SingleBind $ NonRecBind $
              foldr AndMonoBinds 
-                   (foldr AndMonoBinds EmptyMonoBinds con_binds)
+                   (foldr AndMonoBinds EmptyMonoBinds sel_binds)
                    con_binds
     )
   where
@@ -234,7 +234,7 @@ mkConstructor con_id
                      -- to the Data class
                      [getTyVar "mkConstructor" ty
                      | (clas,ty) <- theta, 
-                       uniqueOf clas == dataClassKey]
+                       uniqueOf clas == evalClassKey]
 
        check_data arg = case getTyVar_maybe (tcIdType arg) of
                           Nothing    -> returnTc ()    -- Not a tyvar, so OK
@@ -245,7 +245,7 @@ mkConstructor con_id
        -- Build the data constructor
     let
        con_rhs = mkHsTyLam tyvars $
-                 DictLam dicts $
+                 mkHsDictLam dicts $
                  mk_pat_match args $
                  mk_case strict_args $
                  HsCon con_id arg_tys (map HsVar args)
@@ -323,7 +323,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
       selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
 
       mk_match (con_id, field_label) 
-       = PatMatch (RecPat con_id data_ty' [(RealId selector_id, VarPat field_id, False)]) $
+       = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
          SimpleMatch $
          HsVar field_id
     in
@@ -382,16 +382,16 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
     returnTc data_con
 
 tcField (field_label_names, bty)
-  = tcMonoType (get_ty bty)    `thenTc` \ field_ty ->
+  = tcPolyType (get_pty bty)   `thenTc` \ field_ty ->
     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 
 tcDataCon tycon tyvars ctxt name btys src_loc
   = tcAddSrcLoc src_loc        $
     let
        stricts = map get_strictness btys
-       tys     = map get_ty btys
+       tys     = map get_pty btys
     in
-    mapTc tcMonoType tys `thenTc` \ arg_tys ->
+    mapTc tcPolyType tys `thenTc` \ arg_tys ->
     let
       data_con = mkDataCon (getName name)
                           stricts
@@ -412,11 +412,11 @@ thinContext arg_tys ctxt
       arg_tyvars = tyVarsOfTypes arg_tys
       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
   
-get_strictness (Banged ty)   = MarkedStrict
-get_strictness (Unbanged ty) = NotMarkedStrict
+get_strictness (Banged   _) = MarkedStrict
+get_strictness (Unbanged _) = NotMarkedStrict
 
-get_ty (Banged ty)   = ty
-get_ty (Unbanged ty) = ty
+get_pty (Banged ty)   = ty
+get_pty (Unbanged ty) = ty
 \end{code}