[project @ 2000-02-10 18:39:51 by lewie]

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

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 41e44c5..e2ba970 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -41,7 +41,7 @@ import HsSyn  -- oodles of it
 
 -- others:
 import Id      ( idName, idType, setIdType, omitIfaceSigForId, Id )
-import DataCon ( DataCon, dataConArgTys )      
+import DataCon ( DataCon, splitProductType_maybe )     
 import TcEnv   ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
                  ValueEnv, TcId, tcInstId
                )
@@ -138,13 +138,11 @@ DsCCall.lhs.
 \begin{code}
 maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
 maybeBoxedPrimType ty
-  = case splitAlgTyConApp_maybe ty of                                  -- Data type,
-      Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon        -- with exactly one constructor
-        -> case (dataConArgTys data_con tys_applied) of
-            [data_con_arg_ty]                          -- Applied to exactly one type,
-               | isUnLiftedType data_con_arg_ty        -- which is primitive
-               -> Just (data_con, data_con_arg_ty)
-            other_cases -> Nothing
+  = case splitProductType_maybe ty of                          -- Product data type
+      Just (tycon, tys_applied, data_con, [data_con_arg_ty])   -- constr has one arg
+         | isUnLiftedType data_con_arg_ty                      -- which is primitive
+        -> Just (data_con, data_con_arg_ty)
+
       other_cases -> Nothing
 \end{code}
 
@@ -237,7 +235,7 @@ zonkBinds binds
            fixNF_Tc (\ ~(_, new_ids) ->
                tcExtendGlobalValEnv (bagToList new_ids)        $
                zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
-               thing_inside (MonoBind new_bind [] is_rec)      `thenNF_Tc` \ stuff ->
+               thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
                returnNF_Tc (stuff, new_ids)
            )                                                   `thenNF_Tc` \ (stuff, _) ->
           returnNF_Tc stuff
@@ -348,6 +346,10 @@ zonkExpr (HsVar id)
   = zonkIdOcc id       `thenNF_Tc` \ id' ->
     returnNF_Tc (HsVar id')
 
+zonkExpr (HsIPVar id)
+  = zonkIdOcc id       `thenNF_Tc` \ id' ->
+    returnNF_Tc (HsIPVar id')
+
 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
 
 zonkExpr (HsLitOut lit ty)
@@ -399,6 +401,16 @@ zonkExpr (HsLet binds expr)
     zonkExpr expr      `thenNF_Tc` \ new_expr ->
     returnNF_Tc (HsLet new_binds new_expr)
 
+zonkExpr (HsWith expr binds)
+  = zonkExpr expr              `thenNF_Tc` \ new_expr ->
+    zonkIPBinds binds          `thenNF_Tc` \ new_binds ->
+    returnNF_Tc (HsWith new_expr new_binds)
+    where
+       zonkIPBinds = mapNF_Tc zonkIPBind
+       zonkIPBind (n, e) =
+           zonkExpr e          `thenNF_Tc` \ e' ->
+           returnNF_Tc (n, e')
+
 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 
 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
@@ -453,9 +465,9 @@ zonkExpr (CCall fun args may_gc is_casm result_ty)
     zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 
-zonkExpr (HsSCC label expr)
+zonkExpr (HsSCC lbl expr)
   = zonkExpr expr      `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (HsSCC label new_expr)
+    returnNF_Tc (HsSCC lbl new_expr)
 
 zonkExpr (TyLam tyvars expr)
   = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->