Add PostfixOperators flag for (e op) postfix operators; fixes trac #1824

[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 1d83c8a..fe1d0cf 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -223,18 +223,34 @@ tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_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
+                        $ \ [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
@@ -314,7 +330,9 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty        -- maybe empty
 --        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
@@ -785,7 +803,8 @@ instFun orig fun subst tv_theta_prs
        ; 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
        }
@@ -793,24 +812,24 @@ instFun orig fun subst tv_theta_prs
     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]