-dsLit :: HsLit -> DsM CoreExpr
-dsLit (HsChar c) = returnDs (mkConApp charDataCon [mkLit (MachChar c)])
-dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
-dsLit (HsString str) = mkStringLitFS str
-dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
-dsLit (HsInteger i) = mkIntegerLit i
-dsLit (HsInt i) = returnDs (mkConApp intDataCon [mkIntLit i])
-dsLit (HsIntPrim i) = returnDs (mkIntLit i)
-dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
-dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
-dsLit (HsLitLit str ty)
- = ASSERT( maybeToBool maybe_ty )
- returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
- where
- (maybe_ty, wrap_fn) = resultWrapper ty
- Just rep_ty = maybe_ty
-
-dsLit (HsRat r ty)
- = mkIntegerLit (numerator r) `thenDs` \ num ->
- mkIntegerLit (denominator r) `thenDs` \ denom ->
- returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
- where
- (ratio_data_con, integer_ty)
- = case splitAlgTyConApp ty of
- (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (con, i_ty)
+dsRecStmt :: Type -- Monad type constructor :: * -> *
+ -> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
+ -> [Id] -> [TypecheckedStmt] -> [TypecheckedHsExpr] -- Guts of the RecStmt
+ -> TypecheckedStmt
+dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
+ = ASSERT( length vars == length rets )
+ BindStmt tup_pat mfix_app noSrcLoc
+ where
+ (var1:rest) = vars -- Always at least one
+ (ret1:_) = rets
+ one_var = null rest
+
+ mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
+ mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
+
+ tup_expr | one_var = ret1
+ | otherwise = ExplicitTuple rets Boxed
+ tup_ty | one_var = idType var1
+ | otherwise = mkTupleTy Boxed (length vars) (map idType vars)
+ tup_pat | one_var = VarPat var1
+ | otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
+
+ body = HsDo DoExpr (stmts ++ [return_stmt])
+ ids -- Don't need the mfix, but it does no harm
+ (mkAppTy m_ty tup_ty)
+ noSrcLoc
+
+ return_stmt = ResultStmt return_app noSrcLoc
+ return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr