From: simonpj@microsoft.com <unknown>
Date: Wed, 22 Aug 2007 23:03:24 +0000 (+0000)
Subject: Print infix function definitions correctly in HsSyn
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;ds=sidebyside

Print infix function definitions correctly in HsSyn
---

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 242cca8..0469b48 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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)