[project @ 1996-04-25 17:39:44 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..71f0228 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
@@ -192,7 +192,7 @@ We're going to build a constructor that looks like:
             \d1::Data a, d2::C b ->
             \p q r -> case p of { p ->
                       case q of { q ->
-                      HsCon [a,b,c] [p,q,r]}}
+                      HsCon T1 [a,b] [p,q,r]}}
 
 Notice that
 
@@ -220,12 +220,12 @@ mkConstructor con_id
        (arg_tys, result_ty) = splitFunTy tau
        n_args = length arg_tys
     in
-    newLocalIds (take n_args (repeat SLIT("con"))) arg_tys     `thenNF_Tc` {- \ pre_zonk_args ->
-    mapNF_Tc zonkId pre_zonk_args   `thenNF_Tc` -} \ args ->
+    newLocalIds (take n_args (repeat SLIT("con"))) arg_tys
+                                       `thenNF_Tc` \ args ->
 
-       -- Check that all the types of all the strict
-       -- arguments are in Data.  This is trivially true of everything except
-       -- type variables, for which we must check the context.
+       -- Check that all the types of all the strict arguments are in Data.
+       -- This is trivially true of everything except type variables, for
+       -- which we must check the context.
     let
        strict_marks = dataConStrictMarks con_id
        strict_args  = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
@@ -233,22 +233,21 @@ mkConstructor con_id
        data_tyvars = -- The tyvars in the constructor's context that are arguments 
                      -- to the Data class
                      [getTyVar "mkConstructor" ty
-                     | (clas,ty) <- theta, 
-                       uniqueOf clas == dataClassKey]
+                     | (clas,ty) <- theta, uniqueOf clas == evalClassKey]
 
        check_data arg = case getTyVar_maybe (tcIdType arg) of
                           Nothing    -> returnTc ()    -- Not a tyvar, so OK
                           Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
     in
-    mapTc check_data strict_args                       `thenTc_`
+    mapTc check_data strict_args       `thenTc_`
 
        -- 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)
+                 HsCon con_id (mkTyVarTys tyvars) (map HsVar args)
 
        mk_pat_match []         body = body
        mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
@@ -323,7 +322,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 +381,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 +411,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}