[project @ 1996-05-01 18:36:59 by partain]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsUtils.lhs

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 9726092..411a7c1 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -43,18 +43,24 @@ import PprStyle             ( PprStyle(..) )
 import PrelInfo                ( stringTy, iRREFUT_PAT_ERROR_ID )
 import Pretty          ( ppShow )
 import Id              ( idType, dataConArgTys, mkTupleCon,
+                         pprId{-ToDo:rm-},
                          DataCon(..), DictVar(..), Id(..), GenId )
 import Literal         ( Literal(..) )
-import TyCon           ( mkTupleTyCon )
-import Type            ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType,
-                         applyTyCon, getAppDataTyCon
+import TyCon           ( mkTupleTyCon, isNewTyCon, tyConDataCons )
+import Type            ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
+                         isUnboxedType, applyTyCon,
+                         getAppDataTyCon, getAppTyCon
                        )
 import UniqSet         ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
-import Util            ( panic, assertPanic )
+import Util            ( panic, assertPanic, pprTrace{-ToDo:rm-} )
+import PprCore{-ToDo:rm-}
+--import PprType--ToDo:rm
+import Pretty--ToDo:rm
+import TyVar--ToDo:rm
+import Unique--ToDo:rm
+import Usage--ToDo:rm
 
-quantifyTy = panic "DsUtils.quantifyTy"
 splitDictType = panic "DsUtils.splitDictType"
-mkCoTyApps = panic "DsUtils.mkCoTyApps"
 \end{code}
 
 %************************************************************************
@@ -131,7 +137,13 @@ mkCoPrimCaseMatchResult var alts
 mkCoAlgCaseMatchResult :: Id                           -- Scrutinee
                    -> [(DataCon, [Id], MatchResult)]   -- Alternatives
                    -> DsM MatchResult
+
 mkCoAlgCaseMatchResult var alts
+  | isNewTyCon tycon           -- newtype case; use a let
+  = ASSERT( newtype_sanity )
+    returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
+
+  | otherwise                  -- datatype case  
   =        -- Find all the constructors in the type which aren't
            -- explicitly mentioned in the alternatives:
     case un_mentioned_constructors of
@@ -165,8 +177,21 @@ mkCoAlgCaseMatchResult var alts
                                      (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
                                      cxt1)
   where
+       -- Common stuff
     scrut_ty = idType var
-    (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
+    (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ 
+                            getAppTyCon scrut_ty
+
+       -- Stuff for newtype
+    (con_id, arg_ids, match_result) = head alts
+    arg_id                         = head arg_ids
+    coercion_bind                  = NonRec arg_id (Coerce (CoerceOut con_id) 
+                                                           (idType arg_id)
+                                                           (Var var))
+    newtype_sanity                 = null (tail alts) && null (tail arg_ids)
+
+       -- Stuff for data types
+    data_cons = tyConDataCons tycon
 
     un_mentioned_constructors
       = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
@@ -397,7 +422,9 @@ The general case:
 
 \begin{code}
 mkTupleBind tyvars dicts local_global_prs tuple_expr
-  = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
+  = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
+
+    newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
 
     zipWithDs (mk_selector (Var tuple_var))
              local_global_prs
@@ -417,10 +444,10 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
 
     tuple_var_ty :: Type
     tuple_var_ty
-      = case (quantifyTy tyvars (mkRhoTy theta
-                                 (applyTyCon (mkTupleTyCon no_of_binders)
-                                             (map idType locals)))) of
-         (_{-tossed templates-}, ty) -> ty
+      = mkForAllTys tyvars $
+       mkRhoTy theta      $
+       applyTyCon (mkTupleTyCon no_of_binders)
+                  (map idType locals)
       where
        theta = map (splitDictType . idType) dicts
 
@@ -434,17 +461,14 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
        returnDs (
            global,
            mkLam tyvars dicts (
-               mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
-                               binders selected)
+               mkTupleSelector
+                   (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
+                             (map VarArg dicts))
+                   binders
+                   selected)
        )
-
-mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
-mkApp_XX expr []        = expr
-mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
 \end{code}
 
-
-
 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 has only one element, it is the identity function.
 \begin{code}