Print infix function definitions correctly in HsSyn

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 242cca8..0469b48 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -89,8 +89,9 @@ dsHsBind auto_scc rest (VarBind var expr)
     addDictScc var core_expr   `thenDs` \ core_expr' ->
     returnDs ((var, core_expr') : rest)
 
-dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick })
-  = matchWrapper (FunRhs (idName fun)) matches         `thenDs` \ (args, body) ->
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, 
+                                 fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf })
+  = matchWrapper (FunRhs (idName fun) inf) matches     `thenDs` \ (args, body) ->
     mkOptTickBox tick body                             `thenDs` \ body' ->
     dsCoercion co_fn (return (mkLams args body'))      `thenDs` \ rhs ->
     returnDs ((fun,rhs) : rest)

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index f9219ba..34a3a20 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -104,8 +104,9 @@ ds_val_bind (NonRecursive, hsbinds) body
        --       below.  Then pattern-match would fail.  Urk.)
     putSrcSpanDs loc   $
     case bind of
-      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
-       -> matchWrapper (FunRhs (idName fun)) matches           `thenDs` \ (args, rhs) ->
+      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, 
+               fun_tick = tick, fun_infix = inf }
+       -> matchWrapper (FunRhs (idName fun ) inf) matches      `thenDs` \ (args, rhs) ->
           ASSERT( null args )  -- Functions aren't lifted
           ASSERT( isIdHsWrapper co_fn )
            mkOptTickBox tick rhs                               `thenDs` \ rhs' ->

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 52c2674..ca18706 100644 (file)
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -123,8 +123,8 @@ pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
   where
     (ppr_match, pref)
        = case kind of
-            FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
-            other      -> (pprMatchContext kind, \ pp -> pp)
+            FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+            other        -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats pats = sep (map ppr pats)
 

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 6c46fa2..c0f01a8 100644 (file)
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -242,14 +242,13 @@ ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 
 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = ppr var <+> equals <+> pprExpr (unLoc rhs)
-ppr_monobind (FunBind { fun_id = fun, 
+ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
                        fun_matches = matches,
                        fun_tick = tick }) = 
                           (case tick of 
                              Nothing -> empty
                              Just t  -> text "-- tick id = " <> ppr t
-                          ) $$ pprFunBind (unLoc fun) matches
-      -- ToDo: print infix if appropriate
+                          ) $$ pprFunBind (unLoc fun) inf matches
 
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
                         abs_exports = exports, abs_binds = val_binds })
@@ -546,3 +545,4 @@ pprPrag :: Outputable id => id -> LPrag -> SDoc
 pprPrag var (L _ (InlinePrag inl))         = ppr inl <+> ppr var
 pprPrag var (L _ (SpecPrag expr ty _ inl)) = pprSpec var ty inl
 \end{code}
+

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 9161d46..8830155 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -674,8 +674,8 @@ pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc m
                                           -- a place-holder before typechecking
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
-pprFunBind fun matches = pprMatches (FunRhs fun) matches
+pprFunBind :: (OutputableBndr id) => id -> Bool -> MatchGroup id -> SDoc
+pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
@@ -685,14 +685,29 @@ pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
 
 pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
 pprMatch ctxt (Match pats maybe_ty grhss)
-  = pp_name ctxt <+> sep [sep (map ppr pats), 
-                    ppr_maybe_ty, 
-                    nest 2 (pprGRHSs ctxt grhss)]
+  = herald <+> sep [sep (map ppr other_pats), 
+                   ppr_maybe_ty, 
+                   nest 2 (pprGRHSs ctxt grhss)]
   where
-    pp_name (FunRhs fun) = ppr fun     -- Not pprBndr; the AbsBinds will
-                                       -- have printed the signature
-    pp_name LambdaExpr   = char '\\'
-    pp_name other       = empty
+    (herald, other_pats) 
+       = case ctxt of
+           FunRhs fun is_infix
+               | not is_infix -> (ppr fun, pats)
+                       -- f x y z = e
+                       -- Not pprBndr; the AbsBinds will
+                       -- have printed the signature
+
+               | null pats3 -> (pp_infix, [])
+                       -- x &&& y = e
+
+               | otherwise -> (parens pp_infix, pats3)
+                       -- (x &&& y) z = e
+               where
+                 (pat1:pat2:pats3) = pats
+                 pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2
+
+           LambdaExpr -> (char '\\', pats)
+           other      -> (empty,     pats)
 
     ppr_maybe_ty = case maybe_ty of
                        Just ty -> dcolon <+> ppr ty
@@ -918,7 +933,7 @@ pp_dotdot = ptext SLIT(" .. ")
 
 \begin{code}
 data HsMatchContext id -- Context of a Match
-  = FunRhs id                  -- Function binding for f
+  = FunRhs id Bool             -- Function binding for f; True <=> written infix
   | CaseAlt                    -- Guard on a case alternative
   | LambdaExpr                 -- Pattern of a lambda
   | ProcExpr                   -- Pattern of a proc
@@ -952,7 +967,7 @@ isListCompExpr _        = False
 \end{code}
 
 \begin{code}
-matchSeparator (FunRhs _)   = ptext SLIT("=")
+matchSeparator (FunRhs {})  = ptext SLIT("=")
 matchSeparator CaseAlt      = ptext SLIT("->") 
 matchSeparator LambdaExpr   = ptext SLIT("->") 
 matchSeparator ProcExpr     = ptext SLIT("->") 
@@ -962,7 +977,7 @@ matchSeparator RecUpd       = panic "unused"
 \end{code}
 
 \begin{code}
-pprMatchContext (FunRhs fun)     = ptext SLIT("the definition of") <+> quotes (ppr fun)
+pprMatchContext (FunRhs fun _)           = ptext SLIT("the definition of") <+> quotes (ppr fun)
 pprMatchContext CaseAlt                  = ptext SLIT("a case alternative")
 pprMatchContext RecUpd           = ptext SLIT("a record-update construct")
 pprMatchContext PatBindRhs       = ptext SLIT("a pattern binding")
@@ -993,7 +1008,7 @@ pprStmtResultContext other      = ptext SLIT("the result of") <+> pprStmtContext
 -}
 
 -- Used to generate the string for a *runtime* error message
-matchContextErrString (FunRhs fun)              = "function " ++ showSDoc (ppr fun)
+matchContextErrString (FunRhs fun _)                    = "function " ++ showSDoc (ppr fun)
 matchContextErrString CaseAlt                   = "case"
 matchContextErrString PatBindRhs                = "pattern binding"
 matchContextErrString RecUpd                    = "record update"

diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot
index 503701b..b56ef47 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs-boot
+++ b/compiler/hsSyn/HsExpr.lhs-boot
@@ -23,5 +23,5 @@ pprPatBind :: (OutputableBndr b, OutputableBndr i) =>
        LPat b -> GRHSs i -> SDoc
 
 pprFunBind :: (OutputableBndr i) => 
-       i -> MatchGroup i -> SDoc
+       i -> Bool -> MatchGroup i -> SDoc
 \end{code}

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 1733e7a..d54f76e 100644 (file)
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -380,7 +380,7 @@ rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches
 
        ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
                                -- bindSigTyVars tests for Opt_ScopedTyVars
-                            rnMatchGroup (FunRhs plain_name) matches
+                            rnMatchGroup (FunRhs plain_name inf) matches
 
        ; checkPrecMatch inf plain_name matches'
 
@@ -444,12 +444,12 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix =
        -- type variables.  See comments in RnSource.rnSourceDecl(ClassDecl)
     rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _))
        = extendTyVarEnvFVRn gen_tvs    $
-         rnMatch (FunRhs sel_name) match
+         rnMatch (FunRhs sel_name inf) match
        where
          tvs     = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
          gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] 
 
-    rn_match sel_name match = rnMatch (FunRhs sel_name) match
+    rn_match sel_name match = rnMatch (FunRhs sel_name inf) match
 
 
 -- Can't handle method pattern-bindings which bind multiple methods.

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 351b6d8..93a9010 100644 (file)
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -511,7 +511,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
        -- e.g.         f = \(x::forall a. a->a) -> <body>
        --      We want to infer a higher-rank type for f
     setSrcSpan b_loc   $
-    do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches)
+    do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
 
                -- Check for an unboxed tuple type
                --      f = (# True, False #)
@@ -546,7 +546,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
                        | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
 
        ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs    $
-                              tcMatchesFun mono_name matches mono_ty
+                              tcMatchesFun mono_name inf matches mono_ty
 
        ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, 
                                    fun_infix = inf, fun_matches = matches',
@@ -653,8 +653,8 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind)
 -------------------
 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
 tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
-  = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches 
-                                           (idType mono_id)
+  = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
+                                           matches (idType mono_id)
        ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
                            bind_fvs = placeHolderNames, fun_co_fn = co_fn,
                            fun_tick = Nothing }) }

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 485aacb..bd83a55 100644 (file)
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -48,12 +48,12 @@ is used in error messages.  It checks that all the equations have the
 same number of arguments before using @tcMatches@ to do the work.
 
 \begin{code}
-tcMatchesFun :: Name
+tcMatchesFun :: Name -> Bool
             -> MatchGroup Name
             -> BoxyRhoType             -- Expected type of function
             -> TcM (HsWrapper, MatchGroup TcId)        -- Returns type of body
 
-tcMatchesFun fun_name matches exp_ty
+tcMatchesFun fun_name inf matches exp_ty
   = do {  -- Check that they all have the same no of arguments
           -- Location is in the monad, set the caller so that 
           -- any inter-equation error messages get some vaguely
@@ -76,7 +76,7 @@ tcMatchesFun fun_name matches exp_ty
     doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
          <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
     n_pats = matchGroupArity matches
-    match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
+    match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
 \end{code}
 
 @tcMatchesCase@ doesn't do the argument-count check because the

diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot
index bb9fa66..e50949f 100644 (file)
--- a/compiler/typecheck/TcMatches.lhs-boot
+++ b/compiler/typecheck/TcMatches.lhs-boot
@@ -9,7 +9,7 @@ tcGRHSsPat    :: GRHSs Name
              -> BoxyRhoType
              -> TcM (GRHSs TcId)
 
-tcMatchesFun :: Name
+tcMatchesFun :: Name -> Bool
             -> MatchGroup Name
             -> BoxyRhoType
             -> TcM (HsWrapper, MatchGroup TcId)