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.
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
--
-- 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
- 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)
-- Reverse the final matches, to get it back in the right order
getMonoBind bind binds = (bind, binds)
| otherwise
= do ps <- checkPatterns pats
let match_span = combineSrcSpans lhs_loc rhs_span
| 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.
-- 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) }
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
; return (PatBind lhs grhss placeHolderType placeHolderNames) }
| 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
| 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
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)))
= return (Just (L loc' op, True, (l:r:es)))
+ | otherwise -- Infix data con; keep going
= do { mb_l <- go l es
; case mb_l of
Just (op', True, j : k : es')
= do { mb_l <- go l es
; case mb_l of
Just (op', True, j : k : es')
= checkPrec op (unLoc p1) False `thenM_`
checkPrec op (unLoc p2) True
= 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) ->
checkPrec op (ConPatIn op1 (InfixCon _ _)) right
= lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->