[project @ 1996-05-06 11:01:29 by partain]

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

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 4522b96..9030f94 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -14,7 +14,7 @@ import DsLoop         -- partly to get dsBinds, partly to chk dsExpr
 import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
                          Match, Qual, HsBinds, Stmt, PolyType )
 import TcHsSyn         ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
-                         TypecheckedRecordBinds(..)
+                         TypecheckedRecordBinds(..), TypecheckedPat(..)
                        )
 import CoreSyn
 
@@ -22,7 +22,8 @@ import DsMonad
 import DsCCall         ( dsCCall )
 import DsListComp      ( dsListComp )
 import DsUtils         ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
-                         mkErrorAppDs, showForErr
+                         mkErrorAppDs, showForErr, EquationInfo,
+                         MatchResult
                        )
 import Match           ( matchWrapper )
 
@@ -38,6 +39,7 @@ import Id             ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
                        )
 import Literal         ( mkMachInt, Literal(..) )
 import MagicUFs                ( MagicUnfoldingFun )
+import Name            ( Name{--O only-} )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType )
 import PrelInfo                ( mkTupleTy, unitTy, nilDataCon, consDataCon,
@@ -45,8 +47,11 @@ import PrelInfo              ( mkTupleTy, unitTy, nilDataCon, consDataCon,
                          rEC_UPD_ERROR_ID
                        )
 import Pretty          ( ppShow, ppBesides, ppPStr, ppStr )
-import Type            ( splitSigmaTy, splitFunTy, typePrimRep, getAppDataTyCon )
-import TyVar           ( nullTyVarEnv, addOneToTyVarEnv )
+import TyCon           ( isDataTyCon, isNewTyCon )
+import Type            ( splitSigmaTy, splitFunTy, typePrimRep,
+                         getAppDataTyCon, getAppTyCon, applyTy
+                       )
+import TyVar           ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
 import Usage           ( UVar(..) )
 import Util            ( zipEqual, pprError, panic, assertPanic )
 
@@ -308,10 +313,23 @@ dsExpr (ExplicitTuple expr_list)
            (map coreExprType core_exprs)
            core_exprs
 
+-- Two cases, one for ordinary constructors and one for newtype constructors
 dsExpr (HsCon con tys args)
+  | isDataTyCon tycon                  -- The usual datatype case
   = mapDs dsExpr args  `thenDs` \ args_exprs ->
     mkConDs con tys args_exprs
 
+  | otherwise                          -- The newtype case
+  = ASSERT( isNewTyCon tycon )
+    ASSERT( null rest_args )
+    dsExpr first_arg           `thenDs` \ arg_expr ->
+    returnDs (Coerce (CoerceIn con) result_ty arg_expr)
+
+  where
+    (first_arg:rest_args) = args
+    (args_tys, result_ty) = splitFunTy (foldl applyTy (idType con) tys)
+    (tycon,_)            = getAppTyCon result_ty
+
 dsExpr (ArithSeqOut expr (From from))
   = dsExpr expr                  `thenDs` \ expr2 ->
     dsExpr from                  `thenDs` \ from2 ->
@@ -358,26 +376,23 @@ before printing it as
 dsExpr (RecordCon con_expr rbinds)
   = dsExpr con_expr    `thenDs` \ con_expr' ->
     let
-       con_id   = get_con_id con_expr'
+       con_id       = get_con con_expr'
+       (arg_tys, _) = splitFunTy (coreExprType con_expr')
 
-       mk_arg lbl
+       mk_arg (arg_ty, lbl)
          = case [rhs | (sel_id,rhs,_) <- rbinds,
                        lbl == recordSelectorFieldLabel sel_id] of
              (rhs:rhss) -> ASSERT( null rhss )
                            dsExpr rhs
-             []         -> mkErrorAppDs rEC_CON_ERROR_ID (fieldLabelType lbl) (showForErr lbl)
-
-       -- ToDo Bug: fieldLabelType lbl needs to be instantiated with appropriate type args
-       --           problem also arises if ty is extraced by splitting the type of the con_id
+             []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
     in
-    mapDs mk_arg (dataConFieldLabels con_id) `thenDs` \ con_args ->
+    mapDs mk_arg (arg_tys `zipEqual` dataConFieldLabels con_id) `thenDs` \ con_args ->
     mkAppDs con_expr' [] con_args
   where
-       -- The "con_expr'" is simply an application of the constructor Id
-       -- to types and (perhaps) dictionaries.  This boring little 
-       -- function gets the constructor out.
-    get_con_id (App fun _) = get_con_id fun
-    get_con_id (Var con)   = con
+       -- "con_expr'" is simply an application of the constructor Id
+       -- to types and (perhaps) dictionaries. This gets the constructor...
+    get_con (Var con)   = con
+    get_con (App fun _) = get_con fun
 \end{code}
 
 Record update is a little harder. Suppose we have the decl: