-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_maybe ty) of
- Just (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (con, i_ty)
-
- _ -> (panic "ratio_data_con", panic "integer_ty")
+dsRecStmt :: Type -- Monad type constructor :: * -> *
+ -> [(Name,Id)] -- Rebound Ids
+ -> [TypecheckedStmt]
+ -> [Id] -> [Id] -> [TypecheckedHsExpr]
+ -> TypecheckedStmt
+dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets
+ = ASSERT( length vars == length rets )
+ BindStmt tup_pat mfix_app noSrcLoc
+ where
+ vars@(var1:rest) = later_vars ++ rec_vars -- Always at least one
+ rets@(ret1:_) = map HsVar later_vars ++ rec_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 = mkCoreTupTy (map idType vars)
+ -- Deals with singleton case
+ tup_pat | one_var = VarPat var1
+ | otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
+
+ body = HsDo DoExpr (stmts ++ [return_stmt])
+ [(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
+ (mkAppTy m_ty tup_ty)
+ noSrcLoc
+
+ Var return_id = lookupReboundName ds_meths returnMName
+ Var mfix_id = lookupReboundName ds_meths mfixName
+
+ return_stmt = ResultStmt return_app noSrcLoc
+ return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr