Moved argument position info of ATs into tycon rhs info

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4d0030e..6788eee 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -615,7 +615,7 @@ tcTyClDecl1 _calc_isrec
        -- Check that we don't use families without -findexed-types
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
-  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
+  ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing)]
   }
 
   -- "newtype family" or "data family" declaration
@@ -634,8 +634,8 @@ tcTyClDecl1 _calc_isrec
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
               (case new_or_data of
-                 DataType -> OpenDataTyCon
-                 NewType  -> OpenNewTyCon)
+                 DataType -> mkOpenDataTyConRhs
+                 NewType  -> mkOpenNewTyConRhs)
               Recursive False True Nothing
   ; return [ATyCon tycon]
   }
@@ -748,19 +748,22 @@ tcConDecl :: Bool                 -- True <=> -funbox-strict_fields
          -> TcM DataCon
 
 tcConDecl unbox_strict NewType tycon tc_tvs    -- Newtypes
-         (ConDecl name _ ex_tvs ex_ctxt details ResTyH98 _)
-  = do { let tc_datacon field_lbls arg_ty
+         (ConDecl name _ tvs ex_ctxt details res_ty _)
+  = tcTyVarBndrs tvs           $ \ tvs' -> do 
+    do { (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty
+
+               -- Check that a newtype has no existential stuff
+       ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
+
+       ; let tc_datacon field_lbls arg_ty
                = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
                     ; buildDataCon (unLoc name) False {- Prefix -} 
                                    [NotMarkedStrict]
                                    (map unLoc field_lbls)
-                                   tc_tvs []  -- No existentials
-                                   [] []      -- No equalities, predicates
+                                   univ_tvs []  -- No existentials
+                                   [] []        -- No equalities, predicates
                                    [arg_ty']
-                                   tycon }
-
-               -- Check that a newtype has no existential stuff
-       ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
+                                   data_tc }
 
        ; case details of
            PrefixCon [arg_ty]           -> tc_datacon [] arg_ty
@@ -942,8 +945,8 @@ checkValidTyCon :: TyCon -> TcM ()
 checkValidTyCon tc 
   | isSynTyCon tc 
   = case synTyConRhs tc of
-      OpenSynTyCon _  -> return ()
-      SynonymTyCon ty -> checkValidType syn_ctxt ty
+      OpenSynTyCon _ _ -> return ()
+      SynonymTyCon ty  -> checkValidType syn_ctxt ty
   | otherwise
   =    -- Check the context on the data decl
     checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)    `thenM_`