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

@@ -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 =

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

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

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

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},

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) =>