[project @ 1996-06-05 06:44:31 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 81edf59..528607c 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -27,8 +27,8 @@ module DsUtils (
        showForErr
     ) where
 
-import Ubiq
-import DsLoop          ( match, matchSimply )
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop)                ( match, matchSimply )
 
 import HsSyn           ( HsExpr(..), OutPat(..), HsLit(..),
                          Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
@@ -40,20 +40,25 @@ import DsMonad
 
 import CoreUtils       ( coreExprType, mkCoreIfThenElse )
 import PprStyle                ( PprStyle(..) )
-import PprType         ( pprType{-ToDo:rm-} )
-import PrelInfo                ( stringTy, iRREFUT_PAT_ERROR_ID )
+import PrelVals                ( iRREFUT_PAT_ERROR_ID, voidId )
 import Pretty          ( ppShow )
 import Id              ( idType, dataConArgTys, mkTupleCon,
+                         pprId{-ToDo:rm-},
                          DataCon(..), DictVar(..), Id(..), GenId )
 import Literal         ( Literal(..) )
-import TyCon           ( mkTupleTyCon )
+import TyCon           ( mkTupleTyCon, isNewTyCon, tyConDataCons )
 import Type            ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
-                         isUnboxedType, applyTyCon, getAppDataTyCon
+                         mkTheta, isUnboxedType, applyTyCon, getAppTyCon
                        )
+import TysWiredIn      ( voidTy )
 import UniqSet         ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
 import Util            ( panic, assertPanic, pprTrace{-ToDo:rm-} )
-
-splitDictType = panic "DsUtils.splitDictType"
+import PprCore{-ToDo:rm-}
+--import PprType--ToDo:rm
+import Pretty--ToDo:rm
+import TyVar--ToDo:rm
+import Unique--ToDo:rm
+import Usage--ToDo:rm
 \end{code}
 
 %************************************************************************
@@ -132,6 +137,11 @@ mkCoAlgCaseMatchResult :: Id                               -- Scrutinee
                    -> 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 +175,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) = pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ 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 +420,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
@@ -422,7 +447,7 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
        applyTyCon (mkTupleTyCon no_of_binders)
                   (map idType locals)
       where
-       theta = map (splitDictType . idType) dicts
+       theta = mkTheta (map idType dicts)
 
     mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
 
@@ -527,13 +552,13 @@ which is of course utterly wrong.  Rather than drop the condition that
 only boxed types can be let-bound, we just turn the fail into a function
 for the primitive case:
 \begin{verbatim}
-       let fail.33 :: () -> Int#
+       let fail.33 :: Void -> Int#
            fail.33 = \_ -> error "Help"
        in
        case x of
                p1 -> ...
-               p2 -> fail.33 ()
-               p3 -> fail.33 ()
+               p2 -> fail.33 void
+               p3 -> fail.33 void
                p4 -> ...
 \end{verbatim}
 
@@ -548,19 +573,16 @@ mkFailurePair :: Type             -- Result type of the whole case expression
                                -- applied to unit tuple
 mkFailurePair ty
   | isUnboxedType ty
-  = newFailLocalDs (mkFunTys [unit_ty] ty)     `thenDs` \ fail_fun_var ->
-    newSysLocalDs unit_ty                      `thenDs` \ fail_fun_arg ->
+  = newFailLocalDs (mkFunTys [voidTy] ty)      `thenDs` \ fail_fun_var ->
+    newSysLocalDs voidTy                       `thenDs` \ fail_fun_arg ->
     returnDs (\ body ->
                NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
-             App (Var fail_fun_var) (VarArg unit_id))
+             App (Var fail_fun_var) (VarArg voidId))
 
   | otherwise
   = newFailLocalDs ty          `thenDs` \ fail_var ->
     returnDs (\ body -> NonRec fail_var body, Var fail_var)
+\end{code}
+
 
-unit_id :: Id  -- out here to avoid CAF (sigh)
-unit_id = mkTupleCon 0
 
-unit_ty :: Type
-unit_ty = idType unit_id
-\end{code}