import Coercion
import Var
import VarSet
+import VarEnv
import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import PrelNames
+import Module
import DynFlags
import SrcLoc
import Util
import ListSetOps
import Maybes
+import ErrUtils
import Outputable
import FastString
import Control.Monad
tcPolyExprNC expr res_ty
= do { traceTc "tcPolyExprNC" (ppr res_ty)
- ; (gen_fn, expr') <- tcGen (GenSkol res_ty) emptyVarSet res_ty $ \ _ rho ->
+ ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
tcMonoExprNC expr rho
; return (mkLHsWrap gen_fn expr') }
-- Remember to extend the lexical type-variable environment
; (gen_fn, expr')
- <- tcGen (SigSkol ExprSigCtxt) emptyVarSet sig_tc_ty $ \ skol_tvs res_ty ->
+ <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
-- See Note [More instantiated than scoped] in TcBinds
tcMonoExprNC expr res_ty
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcBody }
-tcExpr (HsIf pred b1 b2) res_ty
- = do { pred' <- tcMonoExpr pred boolTy
- ; b1' <- tcMonoExpr b1 res_ty
- ; b2' <- tcMonoExpr b2 res_ty
- ; return (HsIf pred' b1' b2') }
-
-tcExpr (HsDo do_or_lc stmts body _) res_ty
- = tcDoStmts do_or_lc stmts body res_ty
+tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
+ = do { pred' <- tcMonoExpr pred boolTy
+ ; b1' <- tcMonoExpr b1 res_ty
+ ; b2' <- tcMonoExpr b2 res_ty
+ ; return (HsIf Nothing pred' b1' b2') }
+
+tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
+ = do { pred_ty <- newFlexiTyVarTy openTypeKind
+ ; b1_ty <- newFlexiTyVarTy openTypeKind
+ ; b2_ty <- newFlexiTyVarTy openTypeKind
+ ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
+ ; fun' <- tcSyntaxOp IfOrigin fun if_ty
+ ; pred' <- tcMonoExpr pred pred_ty
+ ; b1' <- tcMonoExpr b1 b1_ty
+ ; b2' <- tcMonoExpr b2 b2_ty
+ -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
+ -- so maybe we should use the code for function applications
+ -- (which would allow ifThenElse to be higher rank).
+ -- But it's a little awkward, so I'm leaving it alone for now
+ -- and it maintains uniformity with other rebindable syntax
+ ; return (HsIf (Just fun') pred' b1' b2') }
+
+tcExpr (HsDo do_or_lc stmts _) res_ty
+ = tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
ptext (sLit "was found where an expression was expected")])
\end{code}
+Note [Rebindable syntax for if]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rebindable syntax for 'if' uses the most flexible possible type
+for conditionals:
+ ifThenElse :: p -> b1 -> b2 -> res
+to support expressions like this:
+
+ ifThenElse :: Maybe a -> (a -> b) -> b -> b
+ ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e
+
+ example :: String
+ example = if Just 2
+ then \v -> show v
+ else "No value"
+
+
%************************************************************************
%* *
Record construction and update
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
- enumFromToPName elt_ty
+ (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak
; return $ mkHsWrapCoI coi
(PArrSeq enum_from_to (FromTo expr1' expr2')) }
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (PArrSeqOrigin seq)
- enumFromThenToPName elt_ty
+ (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak
; return $ mkHsWrapCoI coi
(PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
-- Typecheck the result, thereby propagating
-- info (if any) from result into the argument types
-- Both actual_res_ty and res_ty are deeply skolemised
- ; co_res <- unifyType actual_res_ty res_ty
+ ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
+ unifyType actual_res_ty res_ty
-- Typecheck the arguments
; args1 <- tcArgs fun args expected_arg_tys
quotes (ppr fun) <> text ", namely"])
2 (quotes (ppr arg))
+funResCtxt :: LHsExpr Name -> TcType -> TcType
+ -> TidyEnv -> TcM (TidyEnv, Message)
+-- When we have a mis-match in the return type of a function
+-- try to give a helpful message about too many/few arguments
+funResCtxt fun fun_res_ty res_ty env0
+ = do { fun_res' <- zonkTcType fun_res_ty
+ ; res' <- zonkTcType res_ty
+ ; let n_fun = length (fst (tcSplitFunTys fun_res'))
+ n_res = length (fst (tcSplitFunTys res'))
+ what | n_fun > n_res = ptext (sLit "few")
+ | otherwise = ptext (sLit "many")
+ extra | n_fun == n_res = empty
+ | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
+ <+> ptext (sLit "is applied to too") <+> what
+ <+> ptext (sLit "arguments")
+ msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+ ; return (env0, msg $$ extra) }
+
badFieldTypes :: [(Name,TcType)] -> SDoc
badFieldTypes prs
= hang (ptext (sLit "Record update for insufficiently polymorphic field")
projects / ghc-hetmet.git / blobdiff