import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), StmtCtxt(..), Match(..), HsBinds(..), MonoBinds(..),
- mkSimpleMatch
+ Stmt(..), HsMatchContext(..), Match(..), HsBinds(..), MonoBinds(..),
+ mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
- TypecheckedStmt,
- maybeBoxedPrimType
-
+ TypecheckedStmt
)
import CoreSyn
+import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import DsMonad
import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsGRHSs ( dsGuarded )
-import DsCCall ( dsCCall )
+import DsCCall ( dsCCall, resultWrapper )
import DsListComp ( dsListComp )
-import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
+import DsUtils ( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS,
+ mkConsExpr, mkNilExpr, mkIntegerLit
+ )
import Match ( matchWrapper, matchSimply )
-import CoreUtils ( coreExprType )
+import FieldLabel ( FieldLabel, fieldLabelTyCon )
import CostCentre ( mkUserCC )
-import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
-import Const ( Con(..) )
-import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
-import Const ( mkMachInt, Literal(..), mkStrLit )
-import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
-import TyCon ( isNewTyCon )
+import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isExistentialDataCon )
-import Type ( splitFunTys, mkTyConApp,
- splitAlgTyConApp, splitTyConApp_maybe, isNotUsgTy, unUsgTy,
+import Literal ( Literal(..) )
+import TyCon ( tyConDataCons )
+import Type ( splitFunTys,
+ splitAlgTyConApp, splitTyConApp_maybe, tyConAppArgs,
splitAppTy, isUnLiftedType, Type
)
-import TysWiredIn ( tupleCon, unboxedTupleCon,
- listTyCon, mkListTy,
- charDataCon, charTy, stringTy
- )
-import BasicTypes ( RecFlag(..) )
+import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon, isIntegerTy )
+import BasicTypes ( RecFlag(..), Boxity(..) )
import Maybes ( maybeToBool )
+import PrelNames ( hasKey, ratioTyConKey )
import Util ( zipEqual, zipWithEqual )
import Outputable
+
+import Ratio ( numerator, denominator )
\end{code}
in
mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat))
`thenDs` \ error_expr ->
- matchSimply rhs PatBindMatch pat body' error_expr
+ matchSimply rhs PatBindRhs pat body' error_expr
where
- result_ty = coreExprType body
+ result_ty = exprType body
-- Ordinary case for bindings
dsLet (MonoBind binds sigs is_rec) body
%************************************************************************
%* *
-\subsection[DsExpr-vars-and-cons]{Variables and constructors}
+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
%* *
%************************************************************************
\begin{code}
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
-dsExpr e@(HsVar var) = returnDs (Var var)
-dsExpr e@(HsIPVar var) = returnDs (Var var)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[DsExpr-literals]{Literals}
-%* *
-%************************************************************************
-
-We give int/float literals type @Integer@ and @Rational@, respectively.
-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
-around them.
-
-ToDo: put in range checks for when converting ``@i@''
-(or should that be in the typechecker?)
-
-For numeric literals, we try to detect there use at a standard type
-(@Int@, @Float@, etc.) are directly put in the right constructor.
-[NB: down with the @App@ conversion.]
-Otherwise, we punt, putting in a @NoRep@ Core literal (where the
-representation decisions are delayed)...
-
-See also below where we look for @DictApps@ for \tr{plusInt}, etc.
-
-\begin{code}
-dsExpr (HsLitOut (HsString s) _)
- | _NULL_ s
- = returnDs (mkNilExpr charTy)
-
- | _LENGTH_ s == 1
- = let
- the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_ s))]
- the_nil = mkNilExpr charTy
- the_cons = mkConsExpr charTy the_char the_nil
- in
- returnDs the_cons
-
-
--- "_" => build (\ c n -> c 'c' n) -- LATER
-
--- otherwise, leave it as a NoRepStr;
--- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
-
-dsExpr (HsLitOut (HsString str) _)
- = returnDs (mkStringLitFS str)
-
-dsExpr (HsLitOut (HsLitLit str) ty)
- | isUnLiftedType ty
- = returnDs (mkLit (MachLitLit str ty))
- | otherwise
- = case (maybeBoxedPrimType ty) of
- Just (boxing_data_con, prim_ty) ->
- returnDs ( mkConApp boxing_data_con [mkLit (MachLitLit str prim_ty)] )
- _ ->
- pprError "ERROR:"
- (vcat
- [ hcat [ text "Cannot see data constructor of ``literal-literal''s type: "
- , text "value:", quotes (quotes (ptext str))
- , text "; type: ", ppr ty
- ]
- , text "Try compiling with -fno-prune-tydecls."
- ])
-
- where
- (data_con, prim_ty)
- = case (maybeBoxedPrimType ty) of
- Just (boxing_data_con, prim_ty) -> (boxing_data_con, prim_ty)
- Nothing
- -> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
- (hcat [ptext str, text "; type: ", ppr ty])
-
-dsExpr (HsLitOut (HsInt i) ty)
- = returnDs (mkLit (NoRepInteger i ty))
-
-dsExpr (HsLitOut (HsFrac r) ty)
- = returnDs (mkLit (NoRepRational r ty))
-
--- others where we know what to do:
-
-dsExpr (HsLitOut (HsIntPrim i) _)
- | (i >= toInteger minInt && i <= toInteger maxInt)
- = returnDs (mkLit (mkMachInt i))
- | otherwise
- = error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
-
-dsExpr (HsLitOut (HsFloatPrim f) _)
- = returnDs (mkLit (MachFloat f))
- -- ToDo: range checking needed!
-
-dsExpr (HsLitOut (HsDoublePrim d) _)
- = returnDs (mkLit (MachDouble d))
- -- ToDo: range checking needed!
-
-dsExpr (HsLitOut (HsChar c) _)
- = returnDs ( mkConApp charDataCon [mkLit (MachChar c)] )
-
-dsExpr (HsLitOut (HsCharPrim c) _)
- = returnDs (mkLit (MachChar c))
-
-dsExpr (HsLitOut (HsStringPrim s) _)
- = returnDs (mkLit (MachStr s))
-
--- end of literals magic. --
+dsExpr (HsVar var) = returnDs (Var var)
+dsExpr (HsIPVar var) = returnDs (Var var)
+dsExpr (HsLit lit) = dsLit lit
+-- HsOverLit has been gotten rid of by the type checker
dsExpr expr@(HsLam a_Match)
- = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
+ = matchWrapper LambdaExpr [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
returnDs (mkLams binders matching_code)
dsExpr expr@(HsApp fun arg)
= dsExpr op `thenDs` \ core_op ->
-- for the type of y, we need the type of op's 2nd argument
let
- (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
in
dsExpr expr `thenDs` \ x_core ->
newSysLocalDs x_ty `thenDs` \ x_id ->
= dsExpr op `thenDs` \ core_op ->
-- for the type of x, we need the type of op's 2nd argument
let
- (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
in
dsExpr expr `thenDs` \ y_core ->
newSysLocalDs x_ty `thenDs` \ x_id ->
returnDs (bindNonRec y_id y_core $
Lam x_id (mkApps core_op [Var x_id, Var y_id]))
-dsExpr (CCall lbl args may_gc is_asm result_ty)
+dsExpr (HsCCall lbl args may_gc is_asm result_ty)
= mapDs dsExpr args `thenDs` \ core_args ->
dsCCall lbl core_args may_gc is_asm result_ty
-- dsCCall does all the unboxification, etc.
dsExpr (HsCase discrim matches src_loc)
| all ubx_tuple_match matches
= putSrcLocDs src_loc $
- dsExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
case matching_code of
Case (Var x) bndr alts | x == discrim_var ->
returnDs (Case core_discrim bndr alts)
_ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
where
- ubx_tuple_match (Match _ [TuplePat ps False{-unboxed-}] _ _) = True
+ ubx_tuple_match (Match _ [TuplePat ps Unboxed] _ _) = True
ubx_tuple_match _ = False
dsExpr (HsCase discrim matches src_loc)
= putSrcLocDs src_loc $
- dsExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
-> Just elt_ty
other -> Nothing
-- We need the ListComp form to use deListComp (rather than the "do" form)
- -- because the "return" in a do block is a call to "PrelBase.return", and
- -- not a ReturnStmt. Only the ListComp form has ReturnStmts
+ -- because the interpretation of ExprStmt depends on what sort of thing
+ -- it is.
Just elt_ty = maybe_list_comp
dsExpr (ExplicitListOut ty xs)
= go xs
where
- list_ty = mkListTy ty
-
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
- ASSERT( isNotUsgTy ty )
returnDs (mkConsExpr ty core_x core_xs)
-dsExpr (ExplicitTuple expr_list boxed)
+dsExpr (ExplicitTuple expr_list boxity)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
- returnDs (mkConApp ((if boxed
- then tupleCon
- else unboxedTupleCon) (length expr_list))
- (map (Type . unUsgTy . coreExprType) core_exprs ++ core_exprs))
- -- the above unUsgTy is *required* -- KSW 1999-04-07
-
-dsExpr (HsCon con_id [ty] [arg])
- | isNewTyCon tycon
- = dsExpr arg `thenDs` \ arg' ->
- returnDs (Note (Coerce result_ty (unUsgTy (coreExprType arg'))) arg')
- where
- result_ty = mkTyConApp tycon [ty]
- tycon = dataConTyCon con_id
-
-dsExpr (HsCon con_id tys args)
- = mapDs dsExpr args `thenDs` \ args2 ->
- ASSERT( all isNotUsgTy tys )
- returnDs (mkConApp con_id (map Type tys ++ args2))
+ returnDs (mkConApp (tupleCon boxity (length expr_list))
+ (map (Type . exprType) core_exprs ++ core_exprs))
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr (RecordConOut data_con con_expr rbinds)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
- (arg_tys, _) = splitFunTys (coreExprType con_expr')
+ (arg_tys, _) = splitFunTys (exprType con_expr')
mk_arg (arg_ty, lbl)
= case [rhs | (sel_id,rhs,_) <- rbinds,
other -> recUpdError "M.lhs/230"
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
-RHSs, and do not generate a Core @Con@ directly, because the constructor
+RHSs, and do not generate a Core constructor application directly, because the constructor
might do some argument-evaluation first; and may have to throw away some
dictionaries.
\begin{code}
+dsExpr (RecordUpdOut record_expr record_out_ty dicts [])
+ = dsExpr record_expr
+
dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
- = dsExpr record_expr `thenDs` \ record_expr' ->
+ = getSrcLocDs `thenDs` \ src_loc ->
+ dsExpr record_expr `thenDs` \ record_expr' ->
-- Desugar the rbinds, and generate let-bindings if
-- necessary so that we don't lose sharing
let
- ds_rbind (sel_id, rhs, pun_flag)
- = dsExpr rhs `thenDs` \ rhs' ->
- returnDs (recordSelectorFieldLabel sel_id, rhs')
- in
- mapDs ds_rbind rbinds `thenDs` \ rbinds' ->
- let
- record_in_ty = coreExprType record_expr'
- (tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
- (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
- cons_to_upd = filter has_all_fields cons
-
- -- initial_args are passed to every constructor
- initial_args = map Type out_inst_tys ++ map Var dicts
-
+ record_in_ty = exprType record_expr'
+ in_inst_tys = tyConAppArgs record_in_ty
+ out_inst_tys = tyConAppArgs record_out_ty
+
mk_val_arg field old_arg_id
- = case [rhs | (f, rhs) <- rbinds', field == f] of
+ = case [rhs | (sel_id, rhs, _) <- rbinds,
+ field == recordSelectorFieldLabel sel_id] of
(rhs:rest) -> ASSERT(null rest) rhs
- [] -> Var old_arg_id
+ [] -> HsVar old_arg_id
mk_alt con
- = newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids ->
+ = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
-- This call to dataConArgTys won't work for existentials
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
- rhs = mkApps (mkApps (Var (dataConId con)) initial_args) val_args
+ rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConWrapId con))
+ out_inst_tys)
+ dicts)
+ val_args
in
- returnDs (DataCon con, arg_ids, rhs)
-
- mk_default
- | length cons_to_upd == length cons
- = returnDs []
- | otherwise
- = mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty "" `thenDs` \ err ->
- returnDs [(DEFAULT, [], err)]
+ returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)]
+ rhs
+ (Just record_out_ty)
+ src_loc)
in
-- Record stuff doesn't work for existentials
- ASSERT( all (not . isExistentialDataCon) cons )
+ ASSERT( all (not . isExistentialDataCon) data_cons )
+
+ -- It's important to generate the match with matchWrapper,
+ -- and the right hand sides with applications of the wrapper Id
+ -- so that everything works when we are doing fancy unboxing on the
+ -- constructor aguments.
+ mapDs mk_alt cons_to_upd `thenDs` \ alts ->
+ matchWrapper RecUpd alts "record update" `thenDs` \ ([discrim_var], matching_code) ->
- newSysLocalDs record_in_ty `thenDs` \ case_bndr ->
- mapDs mk_alt cons_to_upd `thenDs` \ alts ->
- mk_default `thenDs` \ deflt ->
+ returnDs (bindNonRec discrim_var record_expr' matching_code)
- returnDs (Case record_expr' case_bndr (alts ++ deflt))
where
+ updated_fields :: [FieldLabel]
+ updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_,_) <- rbinds]
+
+ -- Get the type constructor from the first field label,
+ -- so that we are sure it'll have all its DataCons
+ -- (In GHCI, it's possible that some TyCons may not have all
+ -- their constructors, in a module-loop situation.)
+ tycon = fieldLabelTyCon (head updated_fields)
+ data_cons = tyConDataCons tycon
+ cons_to_upd = filter has_all_fields data_cons
+
has_all_fields :: DataCon -> Bool
has_all_fields con_id
- = all ok rbinds
+ = all (`elem` con_fields) updated_fields
where
- con_fields = dataConFieldLabels con_id
- ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields
+ con_fields = dataConFieldLabels con_id
\end{code}
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
#endif
-out_of_range_msg -- ditto
- = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
\end{code}
%--------------------------------------------------------------------
Basically does the translation given in the Haskell~1.3 report:
\begin{code}
-dsDo :: StmtCtxt
+dsDo :: HsMatchContext
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
= let
(_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
- go [ReturnStmt expr]
- = dsExpr expr `thenDs` \ expr2 ->
- returnDs (mkApps (Var return_id) [Type b_ty, expr2])
-
- go (GuardStmt expr locn : stmts)
- = do_expr expr locn `thenDs` \ expr2 ->
- go stmts `thenDs` \ rest ->
- let msg = ASSERT( isNotUsgTy b_ty )
- "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
- returnDs (mkIfThenElse expr2
- rest
- (App (App (Var fail_id)
- (Type b_ty))
- (mkLit (mkStrLit msg stringTy))))
-
+ -- For ExprStmt, see the comments near HsExpr.HsStmt about
+ -- exactly what ExprStmts mean!
+ --
+ -- In dsDo we can only see DoStmt and ListComp (no gaurds)
+
+ go [ResultStmt expr locn]
+ | isDoExpr do_or_lc = do_expr expr locn
+ | otherwise = do_expr expr locn `thenDs` \ expr2 ->
+ returnDs (mkApps (Var return_id) [Type b_ty, expr2])
+
go (ExprStmt expr locn : stmts)
+ | isDoExpr do_or_lc
= do_expr expr locn `thenDs` \ expr2 ->
+ go stmts `thenDs` \ rest ->
let
- (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
+ (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a)
in
- if null stmts then
- returnDs expr2
- else
- go stmts `thenDs` \ rest ->
- newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
- returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
- Lam ignored_result_id rest])
+ newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
+ returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
+ Lam ignored_result_id rest])
+
+ | otherwise -- List comprehension
+ = do_expr expr locn `thenDs` \ expr2 ->
+ go stmts `thenDs` \ rest ->
+ let
+ msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ in
+ mkStringLit msg `thenDs` \ core_msg ->
+ returnDs (mkIfThenElse expr2 rest
+ (App (App (Var fail_id) (Type b_ty)) core_msg))
go (LetStmt binds : stmts )
= go stmts `thenDs` \ rest ->
= putSrcLocDs locn $
dsExpr expr `thenDs` \ expr2 ->
let
- (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
+ (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a)
fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
- (HsLitOut (HsString (_PK_ msg)) stringTy)
- msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty )
- ASSERT2( isNotUsgTy b_ty, ppr b_ty )
- "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ (HsLit (HsString (_PK_ msg)))
+ msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(HsDoOut do_or_lc stmts return_id then_id
fail_id result_ty locn)
, mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
]
in
- matchWrapper DoBindMatch the_matches match_msg
+ matchWrapper DoExpr the_matches match_msg
`thenDs` \ (binders, matching_code) ->
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
match_msg = case do_or_lc of
- DoStmt -> "`do' statement"
+ DoExpr -> "`do' statement"
ListComp -> "comprehension"
\end{code}
+
+%************************************************************************
+%* *
+\subsection[DsExpr-literals]{Literals}
+%* *
+%************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+
\begin{code}
-var_pat (WildPat _) = True
-var_pat (VarPat _) = True
-var_pat _ = False
+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)
\end{code}
+
+