[commit: ghc] wip/impredicativity: Get back special cases for SectionL and SectionR in TcExpr (7d9b1fd)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/impredicativity
Link       : http://ghc.haskell.org/trac/ghc/changeset/7d9b1fda7724c61a5b389244bb57896171f36573/ghc

>---------------------------------------------------------------

commit 7d9b1fda7724c61a5b389244bb57896171f36573
Author: Alejandro Serrano <trupill at gmail.com>
Date:   Thu Jul 9 15:22:17 2015 +0200

    Get back special cases for SectionL and SectionR in TcExpr


>---------------------------------------------------------------

7d9b1fda7724c61a5b389244bb57896171f36573
 compiler/hsSyn/HsUtils.hs    |  2 +-
 compiler/typecheck/TcExpr.hs | 28 ++++++++++++++++++----------
 2 files changed, 19 insertions(+), 11 deletions(-)

diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index fd3d5ef..486c35a 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -23,7 +23,7 @@ module HsUtils(
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
-  coToHsWrapper, mkHsDictLet, mkHsLams,
+  coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams,
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdCast,
 
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 4737bfa..5ddfed9 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -286,23 +286,31 @@ tcExpr app@(OpApp _ _ _ _) res_ty = tcApp app res_ty
                (mkLHsWrapCo co_a arg2') }
 -}
 
+tcExpr (SectionL arg1 op) res_ty
+  = do { dflags <- getDynFlags      -- Note [Left sections]
+       ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
+                         | otherwise                        = 2
+       ; (co_fun, args_tys@(arg1_ty : _), rest_ty) <-
+           matchExpectedFunTys (mk_app_msg op) n_reqd_args res_ty
+       ; let op_ty = mkFunTys args_tys rest_ty
+          -- typecheck op and arg1
+       ; op'   <- tcPolyMonoExprNC op op_ty
+       ; arg1' <- tcArg op' (arg1, arg1_ty, 1)
+       ; return $ SectionL arg1' (mkLHsWrapCo co_fun op') }
+
 -- Right sections, equivalent to \ x -> x `op` expr, or
 --      \ x -> op x expr
-
-tcExpr app@(SectionL _ _) res_ty = tcApp app res_ty
-tcExpr app@(SectionR _ _) res_ty = tcApp app res_ty
-{-
+tcExpr (SectionR op arg2) res_ty
   = do { -- res_ty = arg1_ty -> rest_ty
          (co_fun, [arg1_ty], rest_ty) <-
            matchExpectedFunTys (mk_app_msg op) 1 res_ty
        ; arg2_ty <- newFlexiTyVarTy openTypeKind
          -- op_ty = arg1_ty -> arg2_ty -> rest_ty
-       ; let op_ty = mkFunTys [arg1_ty,arg2_ty] rest_ty
+       ; let op_ty = mkFunTys [arg1_ty, arg2_ty] rest_ty
          -- typecheck op and arg2
-       ; op'   <- tcCheckFun op op_ty
-       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
+       ; op'   <- tcPolyMonoExprNC op op_ty
+       ; arg2' <- tcArg op' (arg2, arg2_ty, 2)
        ; return $ SectionR (mkLHsWrapCo co_fun op') arg2' }
--}
 
 tcExpr (ExplicitTuple tup_args boxity) res_ty
   | all tupArgPresent tup_args
@@ -1010,7 +1018,7 @@ tc_app fun_expr args fun_ty res_ty
                        args1                          -- Arguments
                        (coToHsWrapper co_res) } } }   -- Coercion to expected result type
 
-mk_app_msg :: LHsExpr TcId -> SDoc
+mk_app_msg :: Outputable a => a -> SDoc
 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
                      , ptext (sLit "is applied to")]
 
@@ -1286,7 +1294,7 @@ tcTagToEnum loc fun_name arg res_ty
         ; arg' <- tcPolyMonoExpr arg intPrimTy
         ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
               rep_ty = mkTyConApp rep_tc rep_args
-              wrapper = coToHsWrapper (mkTcSymCo $ TcCoercion coi)
+              wrapper = coToHsWrapperR (mkTcSymCo $ TcCoercion coi)
 
         ; return (TcAppResult fun' [arg'] wrapper) }
                   -- coi is a Representational coercion