[project @ 1997-07-05 02:25:45 by sof]

ghc/compiler/typecheck/TcTyClsDecls.lhs

@@ -50,36 +50,34 @@ import Util		( panic{-, pprTrace-} )
 The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
-tcTyAndClassDecls1 :: InstanceMapper
+tcTyAndClassDecls1 :: TcEnv s -> InstanceMapper	-- Knot tying stuff
 		   -> [RenamedHsDecl]
 		   -> TcM s (TcEnv s)
 
-tcTyAndClassDecls1 inst_mapper decls
+tcTyAndClassDecls1 unf_env inst_mapper decls
   = sortByDependency decls 		`thenTc` \ groups ->
-    tcGroups inst_mapper groups
+    tcGroups unf_env inst_mapper groups
 
-tcGroups inst_mapper []
+tcGroups unf_env inst_mapper []
   = tcGetEnv	`thenNF_Tc` \ env ->
     returnTc env
 
-tcGroups inst_mapper (group:groups)
-  = tcGroup inst_mapper group	`thenTc` \ new_env ->
+tcGroups unf_env inst_mapper (group:groups)
+  = tcGroup unf_env inst_mapper group	`thenTc` \ new_env ->
 
 	-- Extend the environment using the new tycons and classes
     tcSetEnv new_env $
 
 	-- Do the remaining groups
-    tcGroups inst_mapper groups
+    tcGroups unf_env inst_mapper groups
 \end{code}
 
 Dealing with a group
 ~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-tcGroup :: InstanceMapper -> Bag RenamedHsDecl -> TcM s (TcEnv s)
-tcGroup inst_mapper decls
-  = -- pprTrace "tcGroup: " (hsep (map (fst.fmt_decl) (bagToList decls))) $
-
-	-- TIE THE KNOT
+tcGroup :: TcEnv s -> InstanceMapper -> Bag RenamedHsDecl -> TcM s (TcEnv s)
+tcGroup unf_env inst_mapper decls
+  = 	-- TIE THE KNOT
     fixTc ( \ ~(tycons,classes,_) ->
 
 		-- EXTEND TYPE AND CLASS ENVIRONMENTS
@@ -93,7 +91,7 @@ tcGroup inst_mapper decls
       tcTyVarScope tyvar_names 			( \ tyvars ->
 
 		-- DEAL WITH THE DEFINITIONS THEMSELVES
-	foldBag combine (tcDecl inst_mapper)
+	foldBag combine (tcDecl unf_env inst_mapper)
 		(returnTc (emptyBag, emptyBag))
 		decls
       )						`thenTc` \ (tycon_bag,class_bag) ->
@@ -122,16 +120,16 @@ tcGroup inst_mapper decls
 Dealing with one decl
 ~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-tcDecl  :: InstanceMapper
+tcDecl  :: TcEnv s -> InstanceMapper
 	-> RenamedHsDecl
 	-> TcM s (Bag TyCon, Bag Class)
 
-tcDecl inst_mapper (TyD decl)
+tcDecl unf_env inst_mapper (TyD decl)
   = tcTyDecl decl	`thenTc` \ tycon ->
     returnTc (unitBag tycon, emptyBag)
 
-tcDecl inst_mapper (ClD decl)
-  = tcClassDecl1 inst_mapper decl   `thenTc` \ clas ->
+tcDecl unf_env inst_mapper (ClD decl)
+  = tcClassDecl1 unf_env inst_mapper decl   `thenTc` \ clas ->
     returnTc (emptyBag, unitBag clas)
 \end{code}
 

ghc/compiler/typecheck/TcTyDecls.lhs

@@ -17,14 +17,14 @@ IMP_Ubiq(){-uitous-}
 import HsSyn		( TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), HsExpr(..), 
 			  Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), 
 			  HsBinds(..), HsLit, Stmt, DoOrListComp, ArithSeqInfo,
-			  SYN_IE(RecFlag), nonRecursive,
+			  SYN_IE(RecFlag), nonRecursive, andMonoBinds, 
 			  HsType, Fake, InPat, HsTyVar, Fixity,
 			  MonoBinds(..), Sig 
 			)
 import HsTypes		( getTyVarName )
 import RnHsSyn		( RenamedTyDecl(..), RenamedConDecl(..)	)
 import TcHsSyn		( mkHsTyLam, mkHsDictLam, tcIdType,
-			  SYN_IE(TcHsBinds), TcIdOcc(..)
+			  SYN_IE(TcHsBinds), TcIdOcc(..), SYN_IE(TcMonoBinds)
 			)
 import Inst		( newDicts, InstOrigin(..), Inst )
 import TcMonoType	( tcHsTypeKind, tcHsType, tcContext )
@@ -168,13 +168,13 @@ Generating constructor/selector bindings for data declarations
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s)
-mkDataBinds [] = returnTc ([], EmptyBinds)
+mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
+mkDataBinds [] = returnTc ([], EmptyMonoBinds)
 mkDataBinds (tycon : tycons) 
   | isSynTyCon tycon = mkDataBinds tycons
   | otherwise	     = mkDataBinds_one tycon	`thenTc` \ (ids1, b1) ->
 		       mkDataBinds tycons	`thenTc` \ (ids2, b2) ->
-		       returnTc (ids1++ids2, b1 `ThenBinds` b2)
+		       returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
 
 mkDataBinds_one tycon
   = ASSERT( isAlgTyCon tycon )
@@ -189,9 +189,7 @@ mkDataBinds_one tycon
 		| data_id <- data_ids, isLocallyDefined data_id
 		]
     in	
-    returnTc (data_ids,
-	      MonoBind (foldr AndMonoBinds EmptyMonoBinds binds) [] nonRecursive
-	     )
+    returnTc (data_ids, andMonoBinds binds)
   where
     data_cons = tyConDataCons tycon
     fields = [ (con, field) | con   <- data_cons,