[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 73916b6..71f0228 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -27,7 +27,7 @@ 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,
                          newLocalId, newLocalIds
@@ -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,14 +233,13 @@ 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 == evalClassKey]
+                     | (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
@@ -248,7 +247,7 @@ mkConstructor con_id
                  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}