From f41ca5ee7aa614ff1cd5edcab159d18c2934d60d Mon Sep 17 00:00:00 2001 From: Matthew Fluet Date: Sun, 17 Mar 2024 19:47:22 +0000 Subject: [PATCH] Show pattern and expression applications in infix in error messages Record whether a pattern or expression application originated from an infix application and layout such patterns and expressions as appropriate, so that error messages appear as they are written in the source file. Consider the program (with type errors): datatype t = $ of int * int infix $ val _ = case 1 $ 1 of true $ false => false val _ = 1 + 2.0 + "b" + true Previously, the error messages were: Error: z.sml 3.24-3.35. Constructor applied to incorrect argument in pattern. expects: [int] * [int] but got: [bool] * [bool] in: $ (true, false) Error: z.sml 4.9-4.15. Function applied to incorrect argument. expects: _ * [int] but got: _ * [real] in: + (1, 2.0) Error: z.sml 4.9-4.21. Function applied to incorrect argument. expects: _ * [int] but got: _ * [string] in: + (+ (1, 2.0), "b") Error: z.sml 4.9-4.28. Function applied to incorrect argument. expects: _ * [int] but got: _ * [bool] in: + (+ (+ (1, 2.0), "b"), true) Now, the error messages are: Error: z.sml 3.24-3.35. Constructor applied to incorrect argument in pattern. expects: [int] * [int] but got: [bool] * [bool] in: true $ false Error: z.sml 4.9-4.15. Function applied to incorrect argument. expects: _ * [int] but got: _ * [real] in: 1 + 2.0 Error: z.sml 4.9-4.21. Function applied to incorrect argument. expects: _ * [int] but got: _ * [string] in: (1 + 2.0) + "b" Error: z.sml 4.9-4.28. Function applied to incorrect argument. expects: _ * [int] but got: _ * [bool] in: ((1 + 2.0) + "b") + true --- mlton/ast/ast-core.fun | 52 ++++++++++++++++++++++------ mlton/ast/ast-core.sig | 6 ++-- mlton/ast/ast-programs.fun | 4 +-- mlton/elaborate/elaborate-core.fun | 4 +-- mlton/elaborate/precedence-parse.fun | 18 ++++++---- mlton/elaborate/scope.fun | 8 +++-- 6 files changed, 65 insertions(+), 27 deletions(-) diff --git a/mlton/ast/ast-core.fun b/mlton/ast/ast-core.fun index c59ee0c912..459ed7d843 100644 --- a/mlton/ast/ast-core.fun +++ b/mlton/ast/ast-core.fun @@ -1,4 +1,4 @@ -(* Copyright (C) 2009,2012,2015,2017,2019 Matthew Fluet. +(* Copyright (C) 2009,2012,2015,2017,2019,2024 Matthew Fluet. * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh * Jagannathan, and Stephen Weeks. * Copyright (C) 1997-2000 NEC Research Institute. @@ -68,7 +68,7 @@ structure Pat = struct open Wrap datatype node = - App of Longcon.t * t + App of {con: Longcon.t, arg: t, wasInfix: bool} | Const of Const.t | Constraint of t * Type.t | FlatApp of t vector @@ -120,8 +120,22 @@ structure Pat = fun delimit t = if isDelimited then t else paren t in case node p of - App (c, p) => delimit (mayAlign [Longcon.layout c, - layoutF p]) + App {con, arg, wasInfix} => + if wasInfix + then let + val (arg1, arg2) = + case node arg of + Tuple args => + if Vector.length args = 2 + then (Vector.sub (args, 0), Vector.sub (args, 1)) + else Error.bug "AstCore.Pat.layout: App, wasInfix" + | _ => Error.bug "AstCore.Pat.layout: App, wasInfix" + in + delimit (seq [layoutF arg1, str " ", + Longcon.layout con, str " ", + layoutF arg2]) + end + else delimit (mayAlign [Longcon.layout con, layoutF arg]) | Const c => Const.layout c | Constraint (p, t) => delimit (layoutConstraint (layoutF p, t)) | FlatApp ps => @@ -176,7 +190,7 @@ structure Pat = val c = checkSyntax in case node p of - App (_, p) => c p + App {arg, ...} => c arg | Const _ => () | Constraint (p, t) => (c p; Type.checkSyntax t) | FlatApp ps => Vector.foreach (ps, c) @@ -324,7 +338,7 @@ structure Priority = datatype expNode = Andalso of exp * exp - | App of exp * exp + | App of {func: exp, arg: exp, wasInfix: bool} | Case of exp * match | Const of Const.t | Constraint of exp * Type.t @@ -436,8 +450,26 @@ fun layoutExp arg = Andalso (e, e') => delimit (mayAlign [layoutExpF e, seq [str "andalso ", layoutExpF e']]) - | App (function, argument) => - delimit (mayAlign [layoutExpF function, layoutExpF argument]) + | App {func, arg, wasInfix} => + if wasInfix + then let + val (arg1, arg2) = + case node arg of + Record rcd => + (case Record.detupleOpt rcd of + SOME args => + if Vector.length args = 2 + then (#2 (Vector.sub (args, 0)), + #2 (Vector.sub (args, 1))) + else Error.bug "AstCore.Exp.layout: App, wasInfix" + | NONE => Error.bug "AstCore.Exp.layout: App, wasInfix") + | _ => Error.bug "AstCore.Exp.layout: App, wasInfix" + in + delimit (seq [layoutExpF arg1, str " ", + layoutExpF func, str " ", + layoutExpF arg2]) + end + else delimit (mayAlign [layoutExpF func, layoutExpF arg]) | Case (expr, match) => delimit (align [seq [str "case ", layoutExpT expr, str " of"], @@ -576,7 +608,7 @@ fun checkSyntaxExp (e: exp): unit = in case node e of Andalso (e1, e2) => (c e1; c e2) - | App (e1, e2) => (c e1; c e2) + | App {func, arg, ...} => (c func; c arg) | Case (e, m) => (c e; checkSyntaxMatch m) | Const _ => () | Constraint (e, t) => (c e; Type.checkSyntax t) @@ -687,7 +719,7 @@ structure Exp = val var = longvid o Longvid.short o Vid.fromVar fun app (e1: t, e2: t): t = - makeRegion (App (e1, e2), + makeRegion (App {func = e1, arg = e2, wasInfix = false}, Region.append (region e1, region e2)) fun lett (ds: dec vector, e: t, r: Region.t): t = diff --git a/mlton/ast/ast-core.sig b/mlton/ast/ast-core.sig index 7bf65a6370..c5a4301cfc 100644 --- a/mlton/ast/ast-core.sig +++ b/mlton/ast/ast-core.sig @@ -1,4 +1,4 @@ -(* Copyright (C) 2009,2012,2015,2017,2019 Matthew Fluet. +(* Copyright (C) 2009,2012,2015,2017,2019,2024 Matthew Fluet. * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh * Jagannathan, and Stephen Weeks. * Copyright (C) 1997-2000 NEC Research Institute. @@ -45,7 +45,7 @@ signature AST_CORE = sharing type Item.pat = t datatype node = - App of Longcon.t * t + App of {con: Longcon.t, arg: t, wasInfix: bool} | Const of Const.t | Constraint of t * Type.t | FlatApp of t vector @@ -138,7 +138,7 @@ signature AST_CORE = type t datatype node = Andalso of t * t - | App of t * t + | App of {func: t, arg: t, wasInfix: bool} | Case of t * match | Const of Const.t | Constraint of t * Type.t diff --git a/mlton/ast/ast-programs.fun b/mlton/ast/ast-programs.fun index ee0938b87f..58c03c5986 100644 --- a/mlton/ast/ast-programs.fun +++ b/mlton/ast/ast-programs.fun @@ -1,4 +1,4 @@ -(* Copyright (C) 2017 Matthew Fluet. +(* Copyright (C) 2017,2024 Matthew Fluet. * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh * Jagannathan, and Stephen Weeks. * Copyright (C) 1997-2000 NEC Research Institute. @@ -87,7 +87,7 @@ structure Program = in case Exp.node e of Andalso (e1, e2) => (exp e1; exp e2) - | App (e, e') => (exp e; exp e') + | App {func, arg, ...} => (exp func; exp arg) | Case (e, m) => (exp e; match m) | Constraint (e, _) => exp e | FlatApp es => exps es diff --git a/mlton/elaborate/elaborate-core.fun b/mlton/elaborate/elaborate-core.fun index 9c86255791..b924de7f5b 100644 --- a/mlton/elaborate/elaborate-core.fun +++ b/mlton/elaborate/elaborate-core.fun @@ -713,7 +713,7 @@ val elaboratePat: Cpat.wild (Type.new ()) in case Apat.node p of - Apat.App (c, p) => + Apat.App {con = c, arg = p, ...} => (case Env.lookupLongcon (E, c) of NONE => dontCare () | SOME (con, s) => @@ -3098,7 +3098,7 @@ fun elaborateDec (d, {env = E, nest}) = in Cexp.make (Cexp.node e, Type.bool) end - | Aexp.App (ef, ea) => + | Aexp.App {func = ef, arg = ea, ...} => let val cef = elab ef val cea = elab ea diff --git a/mlton/elaborate/precedence-parse.fun b/mlton/elaborate/precedence-parse.fun index 96386174d1..b73349ff70 100644 --- a/mlton/elaborate/precedence-parse.fun +++ b/mlton/elaborate/precedence-parse.fun @@ -25,7 +25,7 @@ struct let val arg = Exp.tuple (Vector.new2 (argl, argr)) in - Exp.makeRegion (Exp.App (func, arg), + Exp.makeRegion (Exp.App {func = func, arg = arg, wasInfix = true}, Exp.region arg) end end @@ -34,10 +34,12 @@ structure Pat = struct open Pat local - fun finishApply {func, arg, region, ctxt} = + fun finishApply {func, arg, region, ctxt, wasInfix} = case Pat.node func of Pat.Var {name, ...} => - Pat.makeRegion (Pat.App (Longvid.toLongcon name, arg), + Pat.makeRegion (Pat.App {con = Longvid.toLongcon name, + arg = arg, + wasInfix = wasInfix}, region) | _ => let @@ -53,14 +55,16 @@ struct fun apply ctxt {func, arg} = finishApply {func = func, arg = arg, region = Region.append (Pat.region func, Pat.region arg), - ctxt = ctxt} + ctxt = ctxt, + wasInfix = false} fun applyInfix ctxt {func, argl, argr} = let val arg = Pat.tuple (Vector.new2 (argl, argr)) in finishApply {func = func, arg = arg, region = Pat.region arg, - ctxt = ctxt} + ctxt = ctxt, + wasInfix = true} end end end @@ -133,7 +137,7 @@ fun 'a parse {apply: {func: 'a, arg: 'a} -> 'a, end fun start token = ensureNONf (token, NILf, true) (* parse an expression *) - fun parse (stack: 'a precStack, (item: 'a, fixval: Fixval.t)) = + fun parse (stack: 'a precStack, (item: 'a, fixval: Fixval.t)) : 'a precStack = case (stack, (item, fixval)) of (NONf (e, r), (e', Fixval.Nonfix)) => NONf (apply {func = e, arg = e'}, r) | (p as INf _, token) => ensureNONf (token, p, false) @@ -150,7 +154,7 @@ fun 'a parse {apply: {func: 'a, arg: 'a} -> 'a, | (p as NONf _, (e', Fixval.Infix (_, rbp))) => INf (rbp, e', p) | _ => Error.bug "PrecedenceParse.parse.parse" (* clean up the stack *) - fun finish stack = + fun finish (stack: 'a precStack) : 'a = case stack of NONf (e1, INf (_, e2, NONf (e3, r))) => finish (NONf (applyInfix {func = e2, argl = e3, argr = e1}, diff --git a/mlton/elaborate/scope.fun b/mlton/elaborate/scope.fun index 38cd38a7a0..e0fb8c7acd 100644 --- a/mlton/elaborate/scope.fun +++ b/mlton/elaborate/scope.fun @@ -1,4 +1,4 @@ -(* Copyright (C) 2017 Matthew Fluet. +(* Copyright (C) 2017,2024 Matthew Fluet. * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh * Jagannathan, and Stephen Weeks. * Copyright (C) 1997-2000 NEC Research Institute. @@ -98,7 +98,7 @@ fun ('down, 'up) datatype z = datatype Pat.node fun visit (p: Pat.t): 'up = (case Pat.node p of - App (_, p) => visit p + App {arg, ...} => visit arg | Const _ => initUp | Constraint (p, t) => combineUp (visit p, visitTy (t, d)) @@ -324,7 +324,9 @@ fun ('down, 'up) in case Exp.node e of Andalso (e1, e2) => do2 (loop e1, loop e2, Andalso) - | App (e1, e2) => do2 (loop e1, loop e2, App) + | App {func, arg, wasInfix} => + do2 (loop func, loop arg, fn (func, arg) => + App {func = func, arg = arg, wasInfix = wasInfix}) | Case (e, m) => do2 (loop e, loopMatch m, Case) | Const _ => empty () | Constraint (e, t) =>