#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..),
- failureFreePat
+ HsBinds(..), Stmt(..), StmtCtxt(..)
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
- mkHsTyApp
+ mkHsTyApp, maybeBoxedPrimType
)
import TcMonad
import Unique ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
+ thenMClassOpKey, failMClassOpKey, returnMClassOpKey
)
import Outputable
import Maybes ( maybeToBool )
in
-- Arguments
- mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..(length args)] `thenNF_Tc` \ arg_tys ->
- tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
+ let n_args = length args
+ tv_idxs | n_args == 0 = []
+ | otherwise = [1..n_args]
+ in
+ mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs `thenNF_Tc` \ arg_tys ->
+ tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
-- The argument types can be unboxed or boxed; the result
-- type must, however, be boxed since it's an argument to the IO
-- 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 [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
-
returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
(CCall lbl args' may_gc is_asm result_ty),
-- do the wrapping in the newtype constructor here
let
bad_fields = badFields rbinds data_con
in
- mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
+ if not (null bad_fields) then
+ mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
+ failTc -- Fail now, because tcRecordBinds will crash on a bad field
+ else
-- Typecheck the record bindings
- -- (Do this after checkRecordFields in case there's a field that
- -- doesn't match the constructor.)
tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
tcMonoExpr (RecordUpd record_expr rbinds) res_ty
= tcAddErrCtxt recordUpdCtxt $
- -- STEP 1
- -- Figure out the tycon and data cons from the first field name
+ -- STEP 0
+ -- Check that the field names are really field names
ASSERT( not (null rbinds) )
let
- ((first_field_name, _, _) : rest) = rbinds
+ field_names = [field_name | (field_name, _, _) <- rbinds]
in
- tcLookupValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
- (case maybe_sel_id of
- Just sel_id | isRecordSelector sel_id -> returnTc sel_id
- other -> failWithTc (notSelector first_field_name)
- ) `thenTc` \ sel_id ->
+ mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids ->
let
+ bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
+ case maybe_sel_id of
+ Nothing -> True
+ Just sel_id -> not (isRecordSelector sel_id)
+ ]
+ in
+ mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_`
+ if not (null bad_guys) then
+ failTc
+ else
+
+ -- STEP 1
+ -- Figure out the tycon and data cons from the first field name
+ let
+ (Just sel_id : _) = maybe_sel_ids
(_, tau) = splitForAllTys (idType sel_id)
Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
(tycon, _, data_cons) = splitAlgTyConApp data_ty
tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
-- STEP 2
- -- Check for bad fields
+ -- Check that at least one constructor has all the named fields
+ -- i.e. has an empty set of bad fields returned by badFields
checkTc (any (null . badFields rbinds) data_cons)
(badFieldsUpd rbinds) `thenTc_`
+
-- STEP 3
-- Typecheck the update bindings.
-- (Do this after checking for bad fields in case there's a field that
newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
+ -- If it's a comprehension we're dealing with,
+ -- force it to be a list comprehension.
+ -- (as of Haskell 98, monad comprehensions are no more.)
+ (case do_or_lc of
+ ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
+ _ -> returnTc ()) `thenTc_`
tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
--
tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
- tcLookupValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ tcLookupValueByKey failMClassOpKey `thenNF_Tc` \ fail_sel_id ->
newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
- newMethod DoOrigin zero_sel_id [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
+ newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) ->
let
- monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
- perhaps_zero_lie | all failure_free stmts' = emptyLIE
- | otherwise = zero_lie
-
- failure_free (BindStmt pat _ _) = failureFreePat pat
- failure_free (GuardStmt _ _) = False
- failure_free other_stmt = True
+ monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
in
- returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id res_ty src_loc,
+ returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
stmts_lie `plusLIE` monad_lie)
\end{code}
the_app = foldl HsApp fun args -- Used in error messages
appCtxt fun args
- = ptext SLIT("In the application") <+> (ppr the_app)
+ = ptext SLIT("In the application") <+> quotes (ppr the_app)
where
the_app = foldl HsApp fun args -- Used in error messages
notSelector field
= hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
+
+illegalCcallTyErr isArg ty
+ = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in _ccall_ or _casm_:")])
+ 4 (hsep [ppr ty])
+ where
+ arg_or_res
+ | isArg = ptext SLIT("argument")
+ | otherwise = ptext SLIT("result")
+
+
\end{code}
projects / ghc-hetmet.git / blobdiff