From: simonpj@microsoft.com <unknown>
Date: Fri, 19 May 2006 09:50:22 +0000 (+0000)
Subject: Bug-fix for infix function definitions (parse/rename)
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cbc86d748d5f7b5ad5503c9e87c0b5c0402f27bc

Bug-fix for infix function definitions (parse/rename)

Fix a crash provoked by

	x `op` y = x
	op       = True

The trouble was that there is currently a single 'infix' flag for the
whole group; and RnTypes.checkPrecMatch was therefore expecting the
second eqn to have two args.

This fixes the crash, and also or-s the infix flags for the various
eqns together; previously it was just taken from the first eqn, which
was wrong.
---

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 9a3c70a..15aa859 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -231,15 +231,18 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 --
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
-getMonoBind (L loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds
-  | has_args mtchs
-  = go mtchs loc binds
+getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, 
+				   fun_matches = MatchGroup mtchs1 _ })) binds
+  | has_args mtchs1
+  = go is_infix1 mtchs1 loc1 binds
   where
-    go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds)
-	| f == f2 = go (mtchs2++mtchs1) loc binds
-	where loc = combineSrcSpans loc1 loc2
-    go mtchs1 loc binds
-	= (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds)
+    go is_infix mtchs loc 
+       (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
+			        fun_matches = MatchGroup mtchs2 _ })) : binds)
+	| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) 
+		        (combineSrcSpans loc loc2) binds
+    go is_infix mtchs loc binds
+	= (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
 	-- Reverse the final matches, to get it back in the right order
 
 getMonoBind bind binds = (bind, binds)
@@ -603,12 +606,16 @@ checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
   | otherwise
   = do	ps <- checkPatterns pats
 	let match_span = combineSrcSpans lhs_loc rhs_span
-	    matches    = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
-	return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches,
-			  fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
+	return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
 	-- The span of the match covers the entire equation.  
 	-- That isn't quite right, but it'll do for now.
 
+makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
+-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
+makeFunBind fn is_infix ms 
+  = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
+	      fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+
 checkPatBind lhs (L _ grhss)
   = do	{ lhs <- checkPattern lhs
 	; return (PatBind lhs grhss placeHolderType placeHolderNames) }
@@ -672,15 +679,29 @@ isFunLhs e = go e []
 	| not (isRdrDataCon f)	 = return (Just (L loc f, False, es))
    go (L _ (HsApp f e)) es 	 = go f (e:es)
    go (L _ (HsPar e))   es@(_:_) = go e es
+
+	-- For infix function defns, there should be only one infix *function*
+	-- (though there may be infix *datacons* involved too).  So we don't
+	-- need fixity info to figure out which function is being defined.
+	--	a `K1` b `op` c `K2` d
+	-- must parse as
+	--	(a `K1` b) `op` (c `K2` d)
+	-- The renamer checks later that the precedences would yield such a parse.
+	-- 
+	-- There is a complication to deal with bang patterns.
+	--
+	-- ToDo: what about this?
+	--		x + 1 `op` y = ...
+
    go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
 	| Just (e',es') <- splitBang e
 	= do { bang_on <- extension bangPatEnabled
 	     ; if bang_on then go e' (es' ++ es)
 	       else return (Just (L loc' op, True, (l:r:es))) }
 		-- No bangs; behave just like the next case
-	| not (isRdrDataCon op) 
+	| not (isRdrDataCon op) 	-- We have found the function!
 	= return (Just (L loc' op, True, (l:r:es)))
-	| otherwise
+	| otherwise			-- Infix data con; keep going
 	= do { mb_l <- go l es
 	     ; case mb_l of
 		 Just (op', True, j : k : es')
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index d7d435c..e209036 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -416,7 +416,14 @@ checkPrecMatch True op (MatchGroup ms _)
       = checkPrec op (unLoc p1) False	`thenM_`
         checkPrec op (unLoc p2) True
 
-    check _ = panic "checkPrecMatch"
+    check _ = return ()	
+	-- This can happen.  Consider
+	--	a `op` True = ...
+	--	op          = ...
+	-- The infix flag comes from the first binding of the group
+	-- but the second eqn has no args (an error, but not discovered
+	-- until the type checker).  So we don't want to crash on the
+	-- second eqn.
 
 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
   = lookupFixityRn op		`thenM` \  op_fix@(Fixity op_prec  op_dir) ->