-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcInferRhoNC, tcSyntaxOp ) where
#include "HsVersions.h"
-- to do so himself.
tcPolyExpr expr res_ty
- = addErrCtxt (exprCtxt (unLoc expr)) $
+ = addErrCtxt (exprCtxt expr) $
(do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
tcPolyExprNC expr res_ty
| isSigmaTy res_ty
= do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
- ; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
+ ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing (tcPolyExprNC expr)
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
-- E.g. forall a. Eq a => forall b. Ord b => ....
; return (mkLHsWrap gen_fn expr') }
| otherwise
- = tcMonoExpr expr res_ty
+ = tcMonoExprNC expr res_ty
---------------
tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
---------------
-tcMonoExpr :: LHsExpr Name -- Expression to type check
- -> BoxyRhoType -- Expected type (could be a type variable)
- -- Definitely no foralls at the top
- -- Can contain boxes, which will be filled in
- -> TcM (LHsExpr TcId)
-
-tcMonoExpr (L loc expr) res_ty
+tcMonoExpr, tcMonoExprNC
+ :: LHsExpr Name -- Expression to type check
+ -> BoxyRhoType -- Expected type (could be a type variable)
+ -- Definitely no foralls at the top
+ -- Can contain boxes, which will be filled in
+ -> TcM (LHsExpr TcId)
+
+tcMonoExpr expr res_ty
+ = addErrCtxt (exprCtxt expr) $
+ tcMonoExprNC expr res_ty
+
+tcMonoExprNC (L loc expr) res_ty
= ASSERT( not (isSigmaTy res_ty) )
setSrcSpan loc $
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
---------------
-tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
-tcInferRho expr = tcInfer (tcMonoExpr expr)
+tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
+tcInferRho expr = tcInfer (tcMonoExpr expr)
+tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
\end{code}
\begin{code}
tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
+ = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
+
tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; return $ mkHsWrapCoI coi (HsLit lit)
}
-tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
+tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar expr') }
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-- Remember to extend the lexical type-variable environment
- ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
- tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
- tcPolyExprNC expr res_ty)
+ ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $
+ tcMonoExprNC expr
; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
-- \ x -> e op x,
-- or
-- \ x -> op e x,
--- or just
+-- or, if PostfixOperators is enabled, just
-- op e
--
--- We treat it as similar to the latter, so we don't
+-- With PostfixOperators we don't
-- actually require the function to take two arguments
-- at all. For example, (x `not`) means (not x);
--- you get postfix operators! Not really Haskell 98
--- I suppose, but it's less work and kind of useful.
+-- you get postfix operators! Not Haskell 98,
+-- but it's less work and kind of useful.
tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
- = do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
- ; return (SectionL arg1' (L loc op')) }
+ = do dflags <- getDOpts
+ if dopt Opt_PostfixOperators dflags
+ then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
+ return (SectionL arg1' (L loc op'))
+ else do (co_fn, (op', arg1'))
+ <- subFunTys doc 1 res_ty Nothing
+ $ \ [arg2_ty'] res_ty' ->
+ tcApp op 2 (tc_args arg2_ty') res_ty'
+ return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
+ where
+ doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
+ <+> ptext (sLit "takes one argument")
+ tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty]
+ = do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty)
+ ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty
+ ; qtys' <- mapM refineBox qtys -- c.f. tcArgs
+ ; return (qtys', arg1') }
+ tc_args _ _ _ _ = panic "tcExpr SectionL"
-- Right sections, equivalent to \ x -> x `op` expr, or
-- \ x -> op x expr
tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
- = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
+ = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
tcApp op 2 (tc_args arg1_ty') res_ty'
; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
where
--
-- But now, in the GADT world, we need to typecheck the scrutinee
-- first, to get type info that may be refined in the case alternatives
- (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
- (tcInferRho scrut)
+ (scrut', scrut_ty) <- tcInferRho scrut
; traceTc (text "HsCase" <+> ppr scrut_ty)
; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
mc_body = tcBody }
tcExpr (HsIf pred b1 b2) res_ty
- = do { pred' <- addErrCtxt (predCtxt pred) $
- tcMonoExpr pred boolTy
+ = do { pred' <- tcMonoExpr pred boolTy
; b1' <- tcMonoExpr b1 res_ty
; b2' <- tcMonoExpr b2 res_ty
; return (HsIf pred' b1' b2') }
-- The scrutinee should have a rigid type if x,y do
-- The general scheme is the same as in tcIdApp
tcExpr (ExplicitTuple exprs boxity) res_ty
- = do { tvs <- newBoxyTyVars [argTypeKind | e <- exprs]
+ = do { let kind = case boxity of { Boxed -> liftedTypeKind
+ ; Unboxed -> argTypeKind }
+ ; tvs <- newBoxyTyVars [kind | e <- exprs]
; let tup_tc = tupleTyCon boxity (length exprs)
tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs)
; checkWiredInTyCon tup_tc -- Ensure instances are available
; doStupidChecks fun ty_theta_prs'
-- Now do normal instantiation
- ; result <- go True fun ty_theta_prs'
+ ; method_sharing <- doptM Opt_MethodSharing
+ ; result <- go method_sharing True fun ty_theta_prs'
; traceTc (text "instFun result" <+> ppr result)
; return result
}
subst_pr (tvs, theta)
= (substTyVars subst tvs, substTheta subst theta)
- go _ fun [] = do {traceTc (text "go _ fun [] returns" <+> ppr fun) ; return fun }
+ go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
- go True (HsVar fun_id) ((tys,theta) : prs)
- | want_method_inst theta
+ go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
+ | want_method_inst method_sharing theta
= do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
; meth_id <- newMethodWithGivenTy orig fun_id tys
- ; go False (HsVar meth_id) prs }
+ ; go method_sharing False (HsVar meth_id) prs }
-- Go round with 'False' to prevent further use
-- of newMethod: see Note [Multiple instantiation]
- go _ fun ((tys, theta) : prs)
+ go method_sharing _ fun ((tys, theta) : prs)
= do { co_fn <- instCall orig tys theta
; traceTc (text "go yields co_fn" <+> ppr co_fn)
- ; go False (HsWrap co_fn fun) prs }
+ ; go method_sharing False (HsWrap co_fn fun) prs }
-- See Note [No method sharing]
- want_method_inst theta = not (null theta) -- Overloaded
- && not opt_NoMethodSharing
+ want_method_inst method_sharing theta = not (null theta) -- Overloaded
+ && method_sharing
\end{code}
Note [Multiple instantiation]
Boring and alphabetical:
\begin{code}
-caseScrutCtxt expr
- = hang (ptext (sLit "In the scrutinee of a case expression:")) 4 (ppr expr)
-
-exprCtxt expr
+exprCtxt (L _ expr)
= hang (ptext (sLit "In the expression:")) 4 (ppr expr)
fieldCtxt field_name
quotes (ppr fun) <> text ", namely"])
4 (quotes (ppr arg))
-predCtxt expr
- = hang (ptext (sLit "In the predicate expression:")) 4 (ppr expr)
-
nonVanillaUpd tycon
= vcat [ptext (sLit "Record update for the non-Haskell-98 data type")
<+> quotes (pprSourceTyCon tycon)
projects / ghc-hetmet.git / blobdiff