Commit a8427a41 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Print infix function definitions correctly in HsSyn

parent f6a68d31
......@@ -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)
......
......@@ -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' ->
......
......@@ -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)
......
......@@ -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}
......@@ -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"
......
......@@ -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}
......@@ -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.
......
......@@ -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 }) }
......
......@@ -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
......
......@@ -9,7 +9,7 @@ tcGRHSsPat :: GRHSs Name
-> BoxyRhoType
-> TcM (GRHSs TcId)
tcMatchesFun :: Name
tcMatchesFun :: Name -> Bool
-> MatchGroup Name
-> BoxyRhoType
-> TcM (HsWrapper, MatchGroup TcId)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment