- = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2a) ->
- tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2b) ->
- tcAddErrCtxt (exprCtxt in_expr) $
- tcSubExp res_ty op_res_ty `thenTc` \ (co_fn, lie3) ->
- returnTc (OpApp arg1' op' fix arg2',
- lie1 `plusLIE` lie2a `plusLIE` lie2b `plusLIE` lie3)
-\end{code}
-
-The interesting thing about @ccall@ is that it is just a template
-which we instantiate by filling in details about the types of its
-argument and result (ie minimal typechecking is performed). So, the
-basic story is that we allocate a load of type variables (to hold the
-arg/result types); unify them with the args/result; and store them for
-later use.
-
-\begin{code}
-tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
-
- = getDOptsTc `thenNF_Tc` \ dflags ->
-
- checkTc (not (is_casm && dopt_HscLang dflags /= HscC))
- (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
- text "Either compile with -fvia-C, or, better, rewrite your code",
- text "to use the foreign function interface. _casm_s are deprecated",
- text "and support for them may one day disappear."])
- `thenTc_`
-
- -- Get the callable and returnable classes.
- tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
- tcLookupClass cReturnableClassName `thenNF_Tc` \ cReturnableClass ->
- tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
- let
- new_arg_dict (arg, arg_ty)
- = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
- [mkClassPred cCallableClass [arg_ty]] `thenNF_Tc` \ arg_dicts ->
- returnNF_Tc arg_dicts -- Actually a singleton bag
-
- result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
- in
-
- -- Arguments
- let tv_idxs | null args = []
- | otherwise = [1..length args]
- in
- newTyVarTys (length tv_idxs) openTypeKind `thenNF_Tc` \ arg_tys ->
- tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
-
- -- The argument types can be unlifted or lifted; the result
- -- type must, however, be lifted since it's an argument to the IO
- -- type constructor.
- newTyVarTy liftedTypeKind `thenNF_Tc` \ result_ty ->
- let
- io_result_ty = mkTyConApp ioTyCon [result_ty]
- in
- unifyTauTy res_ty io_result_ty `thenTc_`
-
- -- Construct the extra insts, which encode the
- -- constraints on the argument and result types.
- mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
- newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenNF_Tc` \ ccres_dict ->
- returnTc (HsCCall lbl args' may_gc is_casm io_result_ty,
- mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie)
+ = tcExpr_id op `thenM` \ (op', op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
+ tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' ->
+ addErrCtxt (exprCtxt in_expr) $
+ tcSubExp res_ty op_res_ty `thenM` \ co_fn ->
+ returnM (OpApp arg1' op' fix arg2')