Merge pull request #554 from MatthewFluet/constant-and-infix-elaborat…

…e-error-messages

Update elaboration error messages involving constants and infix pats/exps

mlton/ast/ast-const.fun

@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2024 Matthew Fluet.
+ * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -11,49 +12,25 @@ struct
 
 open S Region.Wrap
 
-datatype node =
+datatype value =
    Bool of bool
  | Char of IntInf.t
  | Int of IntInf.t
  | Real of string
- | String of IntInf.t vector
+ | String of {char: IntInf.t, yytext: string} vector
  | Word of IntInf.t
+datatype node = Node of {value: value, yytext: string}
 type t = node Region.Wrap.t
 type node' = node
 type obj = t
 
-fun ordToString (c: IntInf.t): string =
-      let
-         fun loop (n: int, c: IntInf.t, ac: char list) =
-            if n = 0
-               then implode ac
-            else
-               let
-                  val (q, r) = IntInf.quotRem (c, 0x10)
-               in
-                  loop (n - 1, q, Char.fromHexDigit (Int.fromIntInf r) :: ac)
-               end
-         fun doit (n, esc) = concat ["\\", esc, loop (n, c, [])]
-      in
-         if c <= 0xFF
-            then Char.escapeSML (Char.fromInt (Int.fromIntInf c))
-         else if c <= 0xFFFF
-            then doit (4, "u")
-         else doit (8, "U")
-      end
-
 local
-   open Layout
+   fun mk sel c = let val Node r = node c in sel r end
 in
-   fun layout c =
-      case node c of
-         Bool b => if b then str "true" else str "false"
-       | Char c => str (concat ["#\"", ordToString c, "\""])
-       | Int s => str (IntInf.toString s)
-       | Real l => String.layout l
-       | String s =>
-            str (concat ["\"", concat (Vector.toListMap (s, ordToString)), "\""])
-       | Word w => str (concat ["0wx", IntInf.format (w, StringCvt.HEX)])
+   val value = mk #value
+   val yytext = mk #yytext
 end
 
+fun layout (c: t) = Layout.str (yytext c)
+
 end

mlton/ast/ast-const.sig

@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2024 Matthew Fluet.
+ * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -15,16 +16,17 @@ signature AST_CONST =
       include AST_CONST_STRUCTS
 
       type t
-      datatype node =
+      datatype value =
          Bool of bool
        | Char of IntInf.t
        | Int of IntInf.t
        | Real of string
-       | String of IntInf.t vector
+       | String of {char: IntInf.t, yytext: string} vector
        | Word of IntInf.t
+      datatype node = Node of {value: value, yytext: string}
       include WRAPPED sharing type node' = node
                       sharing type obj = t
 
       val layout: t -> Layout.t
-      val ordToString: IntInf.t -> string
+      val value: t -> value
    end

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

@@ -1,4 +1,4 @@
-(* Copyright (C) 2009-2012,2015,2017,2019-2020 Matthew Fluet.
+(* Copyright (C) 2009-2012,2015,2017,2019-2020,2024 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -384,7 +384,7 @@ fun 'a elabConst (c: Aconst.t,
             NONE => Tycon.bogus
           | SOME c => c
    in
-      case Aconst.node c of
+      case Aconst.value c of
          Aconst.Bool b => if b then t else f
        | Aconst.Char ch =>
             delay
@@ -438,11 +438,11 @@ fun 'a elabConst (c: Aconst.t,
                            (WordXVector.tabulate
                             ({elementSize = ws}, Vector.length v, fn i =>
                              let
-                                val ch = Vector.sub (v, i)
+                                val {char = ch, yytext} = Vector.sub (v, i)
                              in
                                 if CharSize.isInRange (cs, ch)
                                    then WordX.fromIntInf (ch, ws)
-                                   else (List.push (bigs, ch)
+                                   else (List.push (bigs, yytext)
                                          ; WordX.zero ws)
                              end))
                         val () =
@@ -452,15 +452,16 @@ fun 'a elabConst (c: Aconst.t,
                                    (Aconst.region c,
                                     seq [str "string constant with ",
                                          str (case !bigs of
-                                                 [_] => "character "
-                                               | _ => "characters "),
-                                         str "too large for type: ",
+                                                 [_] => "character"
+                                               | _ => "characters"),
+                                         str " too large for type: ",
                                          seq (Layout.separate
                                               (List.revMap
-                                               (!bigs, fn ch =>
-                                                Aconst.layout (Aconst.makeRegion (Aconst.Char ch, Region.bogus))),
+                                               (!bigs, fn yytext =>
+                                                seq [str "#\"", str yytext, str "\""]),
                                                ", "))],
-                                    seq [str "type: ", layoutPrettyType ty])
+                                    align [seq [str "type: ", layoutPrettyType ty],
+                                           seq [str "in: ", Aconst.layout c]])
                      in
                         wv
                      end))
@@ -712,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) =>
@@ -1801,7 +1802,12 @@ fun export {attributes: ImportExportAttribute.t list,
          Aexp.longvid (Longvid.short
                        (Vid.fromSymbol (Symbol.fromString name, region)))
       fun int (i: int): Aexp.t =
-         Aexp.const (Aconst.makeRegion (Aconst.Int (IntInf.fromInt i), region))
+         let
+            val node = Aconst.Node {value = Aconst.Int (IntInf.fromInt i),
+                                    yytext = Int.toString i}
+         in
+            Aexp.const (Aconst.makeRegion (node, region))
+         end
       val f = Var.fromSymbol (Symbol.fromString "f", region)
       val p = Var.fromSymbol (Symbol.fromString "p", region)
    in
@@ -3092,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},