Commit a106a200 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Minor refactor of TcExpr.tcApp

This refactoring has no change in behaviour but makes the
structure clearer
parent be1ca0e4
......@@ -1143,7 +1143,8 @@ tcApp1 e res_ty
mk_hs_app f (HsValArg a) = mkHsApp f a
mk_hs_app f (HsTypeArg a) = mkHsAppTypeOut f a
tcApp :: Maybe SDoc -- like "The function `f' is applied to"
tcApp, tcGeneralApp
:: Maybe SDoc -- like "The function `f' is applied to"
-- or leave out to get exactly that message
-> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args
-> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
......@@ -1152,63 +1153,78 @@ tcApp :: Maybe SDoc -- like "The function `f' is applied to"
-- But OpApp is slightly different, so that's why the caller
-- must assemble
tcApp m_herald orig_fun orig_args res_ty
= go orig_fun orig_args
where
go :: LHsExpr GhcRn -> [LHsExprArgIn]
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
go (L _ (HsPar e)) args = go e args
go (L _ (HsApp e1 e2)) args = go e1 (HsValArg e2:args)
go (L _ (HsAppType e t)) args = go e (HsTypeArg t:args)
go (L loc (HsVar (L _ fun))) args
| fun `hasKey` tagToEnumKey
, count isHsValArg args == 1
= do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
; return (wrap, expr, args) }
| fun `hasKey` seqIdKey
, count isHsValArg args == 2
= do { (wrap, expr, args) <- tcSeq loc fun args res_ty
; return (wrap, expr, args) }
go (L loc (HsRecFld (Ambiguous lbl _))) args@(HsValArg (L _ arg) : _)
| Just sig_ty <- obviousSig arg
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args }
-- See Note [Visible type application for the empty list constructor]
go (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg]
= do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind
; let list_ty = TyConApp listTyCon [ty_arg']
; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt
list_ty res_ty
; let expr :: LHsExpr GhcTcId
expr = L loc $ ExplicitList ty_arg' Nothing []
; return (idHsWrapper, expr, []) }
go fun args
= do { -- Type-check the function
; (fun1, fun_sigma) <- tcInferFun fun
; let orig = lexprCtOrigin fun
; (wrap_fun, args1, actual_res_ty)
<- tcArgs fun fun_sigma orig args
(m_herald `orElse` mk_app_msg fun args)
-- this is just like tcWrapResult, but the types don't line
-- up to call that function
; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
tcSubTypeDS_NC_O orig GenSigCtxt
(Just $ unLoc $ foldl mk_hs_app fun args)
actual_res_ty res_ty
; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
tcApp m_herald (L _ (HsPar fun)) args res_ty
= tcApp m_herald fun args res_ty
tcApp m_herald (L _ (HsApp fun arg1)) args res_ty
= tcApp m_herald fun (HsValArg arg1 : args) res_ty
tcApp m_herald (L _ (HsAppType fun ty1)) args res_ty
= tcApp m_herald fun (HsTypeArg ty1 : args) res_ty
tcApp m_herald (L loc (HsRecFld fld_lbl)) args res_ty
| Ambiguous lbl _ <- fld_lbl -- Still ambiguous
, HsValArg (L _ arg) : _ <- args -- A value arg is first
, Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
; let unambig_fun = L loc (HsRecFld (Unambiguous lbl sel_name))
; tcGeneralApp m_herald unambig_fun args res_ty }
tcApp _ (L loc (HsVar (L _ fun_id))) args res_ty
-- Special typing rule for tagToEnum#
| fun_id `hasKey` tagToEnumKey
, n_val_args == 1
= do { (wrap, expr, args) <- tcTagToEnum loc fun_id args res_ty
; return (wrap, expr, args) }
-- Special typing rule for 'seq'
| fun_id `hasKey` seqIdKey
, n_val_args == 2
= do { (wrap, expr, args) <- tcSeq loc fun_id args res_ty
; return (wrap, expr, args) }
where
n_val_args = count isHsValArg args
tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg] res_ty
-- See Note [Visible type application for the empty list constructor]
= do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind
; let list_ty = TyConApp listTyCon [ty_arg']
; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt
list_ty res_ty
; let expr :: LHsExpr GhcTcId
expr = L loc $ ExplicitList ty_arg' Nothing []
; return (idHsWrapper, expr, []) }
tcApp m_herald fun args res_ty
= tcGeneralApp m_herald fun args res_ty
---------------------
-- tcGeneralApp deals with the general case;
-- the special cases are handled by tcApp
tcGeneralApp m_herald fun args res_ty
= do { -- Type-check the function
; (fun1, fun_sigma) <- tcInferFun fun
; let orig = lexprCtOrigin fun
; (wrap_fun, args1, actual_res_ty)
<- tcArgs fun fun_sigma orig args
(m_herald `orElse` mk_app_msg fun args)
-- this is just like tcWrapResult, but the types don't line
-- up to call that function
; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
tcSubTypeDS_NC_O orig GenSigCtxt
(Just $ unLoc $ foldl mk_hs_app fun args)
actual_res_ty res_ty
; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
where
mk_hs_app f (HsValArg a) = mkHsApp f a
mk_hs_app f (HsTypeArg a) = mkHsAppType f a
mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr)
, text "is applied to"]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment