Skip to content

Commit

Permalink
Updates and minor bug fix to precedence parsing of function clauses
Browse files Browse the repository at this point in the history 
Consider the following program:

    infix & && << >>
    datatype ('a, 'b) p = & of 'a * 'b

    (* should error *)
    fun (_ f _) = ()

    (* should error *)
    fun fst x & y = x

    (* should error *)
    fun fst x && y = x

    (* should error *)
    fun << (x, y) = ()

    (* should error *)
    fun << (x, y) z = ()

    (* should error *)
    fun << && >> = ()

    (* should error *)
    fun (f) x = ()

    (* should error *)
    fun x && y & z = 1

Each of these function declarations erroneously uses infix identifiers
in a function clause.  Previously, only the second, seventh, and
eighth were reported as errors:

    Error: z.sml 8.11-8.11.
      Constructor used without argument in pattern: &.
    Error: z.sml 23.6-23.6.
      Function defined with illegal name: f.
        in: fun f x = ()
    Error: z.sml 26.12-26.12.
      Constructor used without argument in pattern: &.

Now, we give more descriptive error messages:

    Error: z.sml 5.5-5.11.
      Function clause with improper infix pattern.
        in: fun (_ f _) = ()
    Error: z.sml 5.5-5.11.
      Function clause with no arguments.
        in: fun (_ f _) = ()
    Error: z.sml 8.5-8.9.
      Function clause with improper infix pattern.
        in: fun fst x & y = x
    Warning: z.sml 8.11-8.11.
      Constructor redefined by fun: &.
        in: fun fst x & y = x
    Error: z.sml 8.5-8.7.
      Undefined constructor: fst.
    Error: z.sml 8.17-8.17.
      Undefined variable: x.
    Error: z.sml 11.5-11.9.
      Function clause with improper infix pattern.
        in: fun fst x && y = x
    Error: z.sml 11.5-11.7.
      Undefined constructor: fst.
    Error: z.sml 11.18-11.18.
      Undefined variable: x.
    Error: z.sml 14.5-14.6.
      Function clause starts with infix identifier: <<.
        in: fun << (x, y) = ()
    Error: z.sml 17.5-17.6.
      Function clause starts with infix identifier: <<.
        in: fun << (x, y) z = ()
    Error: z.sml 20.5-20.6.
      Function clause starts with infix identifier: <<.
        in: fun << && >> = ()
    Error: z.sml 20.11-20.12.
      Identifier must be used infix: >>.
        in: fun << && >> = ()
    Error: z.sml 23.5-23.7.
      Function clause with improper infix pattern.
        in: fun f x = ()
    Error: z.sml 26.5-26.10.
      Function clause with improper infix pattern.
        in: fun x && y & z = 1
    Error: z.sml 26.7-26.8.
      Undefined constructor: &&.
  • Loading branch information
@MatthewFluet
MatthewFluet committed Jun 1, 2017
1 parent 37ddbe5 commit 1a6d25e
Show file tree
Hide file tree
Showing 3 changed files with 599 additions and 109 deletions.
322 changes: 213 additions & 109 deletions mlton/elaborate/precedence-parse.fun
View file
Expand Up @@ -17,6 +17,54 @@ in structure Exp = Exp
structure Vid = Vid
end

structure Exp =
struct
open Exp
fun apply {func, arg} = Exp.app (func, arg)
fun applyInfix {func, argl, argr} =
let
val arg = Exp.tuple (Vector.new2 (argl, argr))
in
Exp.makeRegion (Exp.App (func, arg),
Exp.region arg)
end
end

structure Pat =
struct
open Pat
local
fun finishApply {func, arg, region, lay} =
case Pat.node func of
Pat.Var {name, ...} =>
Pat.makeRegion (Pat.App (Longvid.toLongcon name, arg),
region)
| _ =>
let
val () =
Control.error
(region,
Layout.str "non-constructor applied to argument in pattern",
lay ())
in
Pat.wild
end
in
fun apply lay {func, arg} =
finishApply {func = func, arg = arg,
region = Region.append (Pat.region func, Pat.region arg),
lay = lay}
fun applyInfix lay {func, argl, argr} =
let
val arg = Pat.tuple (Vector.new2 (argl, argr))
in
finishApply {func = func, arg = arg,
region = Pat.region arg,
lay = lay}
end
end
end

structure Fixval =
struct
datatype t = Nonfix | Infix of int * int
Expand Down Expand Up @@ -68,32 +116,33 @@ fun 'a parse {apply: {func: 'a, arg: 'a} -> 'a,
let
fun error (r: Region.t, msg: string) =
Control.error (r, Layout.str msg, lay ())
fun ensureNONf ((e, f), p) =
fun ensureNONf ((e, f), p, start) =
let
val _ =
case f of
Fixval.Nonfix => ()
| _ =>
Control.error
error
(region e,
Layout.str (concat ["identifier must be used infix: ",
toString e]),
lay ())
concat [if start
then name ^ " starts with infix identifier: "
else "identifier must be used infix: ",
toString e])
in
NONf (e, p)
end
fun start token = ensureNONf (token, NILf)
fun start token = ensureNONf (token, NILf, true)
(* parse an expression *)
fun parse (stack: 'a precStack, (item: 'a, fixval: Fixval.t)) =
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)
| (p as INf _, token) => ensureNONf (token, p, false)
| (p as NONf (e1, INf (bp, e2, NONf (e3, r))),
(e4, f as Fixval.Infix (lbp, rbp))) =>
if lbp > bp then INf (rbp, e4, p)
else (if lbp = bp
then error (region e1,
"operators of same precedence with mixed associativity")
then error (Region.append (region e2, region e4),
concat ["infix identifiers with equal precedence but mixed associativity: ", toString e2, ", ", toString e4])
else ();
parse (NONf (applyInfix {func = e2, argl = e3, argr = e1},
r),
Expand All @@ -108,7 +157,7 @@ fun 'a parse {apply: {func: 'a, arg: 'a} -> 'a,
r))
| NONf (e1, NILf) => e1
| INf (_, e1, NONf (e2, p)) =>
(error (region e1, concat [name, " ends with infix identifier"])
(error (region e1, concat [name, " ends with infix identifier: ", toString e1])
; finish (NONf (apply {func = e2, arg = e1}, p)))
| NILf => Error.bug "PrecedenceParse.parse.finish: NILf"
| _ => Error.bug "PrecedenceParse.parse.finish"
Expand All @@ -128,41 +177,14 @@ fun 'a parse {apply: {func: 'a, arg: 'a} -> 'a,
end

fun parsePat (ps, E, lay) =
let
fun finishApply {func, arg, region} =
case Pat.node func of
Pat.Var {name, ...} =>
Pat.makeRegion (Pat.App (Longvid.toLongcon name, arg),
region)
| _ =>
let
val () =
Control.error
(region,
Layout.str "non-constructor applied to argument in pattern",
lay ())
in
Pat.wild
end
fun apply {func, arg} =
finishApply {func = func, arg = arg,
region = Region.append (Pat.region func, Pat.region arg)}
fun applyInfix {func, argl, argr} =
let
val arg = Pat.tuple (Vector.new2 (argl, argr))
in
finishApply {func = func, arg = arg, region = Pat.region arg}
end
in
parse {apply = apply,
applyInfix = applyInfix,
fixval = fn p => Fixval.makePat (p, E),
items = ps,
lay = lay,
name = "pattern",
region = Pat.region,
toString = Layout.toString o Pat.layout}
end
parse {apply = Pat.apply lay,
applyInfix = Pat.applyInfix lay,
fixval = fn p => Fixval.makePat (p, E),
items = ps,
lay = lay,
name = "pattern",
region = Pat.region,
toString = Layout.toString o Pat.layout}

val parsePat =
Trace.trace ("PrecedenceParse.parsePat",
Expand All @@ -171,25 +193,14 @@ val parsePat =
parsePat

fun parseExp (es, E, lay) =
let
fun apply {func, arg} = Exp.app (func, arg)
fun applyInfix {func, argl, argr} =
let
val arg = Exp.tuple (Vector.new2 (argl, argr))
in
Exp.makeRegion (Exp.App (func, arg),
Exp.region arg)
end
in
parse {apply = apply,
applyInfix = applyInfix,
fixval = fn e => Fixval.makeExp (e, E),
items = es,
lay = lay,
name = "expression",
region = Exp.region,
toString = Layout.toString o Exp.layout}
end
parse {apply = Exp.apply,
applyInfix = Exp.applyInfix,
fixval = fn e => Fixval.makeExp (e, E),
items = es,
lay = lay,
name = "expression",
region = Exp.region,
toString = Layout.toString o Exp.layout}

val parseExp =
Trace.trace ("PrecedenceParse.parseExp",
Expand All @@ -201,59 +212,152 @@ val parseExp =
(* parseClause *)
(*---------------------------------------------------*)

structure ClausePat =
struct
datatype t =
Apply of {func: t, arg: t}
| ApplyInfix of {func: t, argl: t, argr: t}
| Pat of Pat.t

fun region p =
case p of
Apply {func, arg} =>
Region.append (region func, region arg)
| ApplyInfix {argl, argr, ...} =>
Region.append (region argl, region argr)
| Pat p => Pat.region p

local
fun toPat p =
case p of
Apply {func, arg} =>
let
val func = toPat func
val arg = toPat arg
in
Pat.makeRegion
(Pat.FlatApp (Vector.new2 (func, arg)),
Region.append (Pat.region func, Pat.region arg))
end
| ApplyInfix {func, argl, argr} =>
let
val func = toPat func
val argl = toPat argl
val argr = toPat argr
in
Pat.makeRegion
(Pat.FlatApp (Vector.new3 (argl, func, argr)),
Region.append (Pat.region argl, Pat.region argr))
end
| Pat p => p
in
val layout = Pat.layout o toPat
end
end

fun parseClausePats (ps, E, lay) =
parse {apply = ClausePat.Apply,
applyInfix = ClausePat.ApplyInfix,
fixval = fn ClausePat.Pat p => Fixval.makePat (p, E)
| _ => Fixval.Nonfix,
items = Vector.map (ps, ClausePat.Pat),
lay = lay,
name = "function clause",
region = ClausePat.region,
toString = Layout.toString o ClausePat.layout}

fun parseClause (pats: Pat.t vector, E: Env.t, lay) =
let
fun error (region, msg) =
(Control.error (region, msg, lay ())
; {func = Ast.Var.bogus,
args = Vector.new0 ()})
Control.error (region, msg, lay ())
fun improper region =
error
(region, Layout.str "function clause with improper infix pattern")

fun toPat p=
case p of
ClausePat.Pat p => p
| ClausePat.Apply {func, arg} =>
Pat.apply lay
{func = toPat func,
arg = toPat arg}
| ClausePat.ApplyInfix {func, argl, argr} =>
Pat.applyInfix lay
{func = toPat func,
argl = toPat argl,
argr = toPat argr}
fun toPatTop p =
case p of
ClausePat.Pat p => p
| _ => (improper (ClausePat.region p)
; toPat p)
fun toPatList p =
let
fun loop (p, args) =
case p of
ClausePat.Apply {func, arg} =>
loop (func, (toPatTop arg)::args)
| _ => (toPatTop p)::args
in
loop (p, [])
end

fun done (func: Pat.t, args: Pat.t list) =
let
fun illegal () =
error (Pat.region func,
Layout.seq [Layout.str "function defined with illegal name: ",
Pat.layout func])
fun illegalName () =
(error (Pat.region func,
Layout.seq [Layout.str "function clause with illegal name: ",
Pat.layout func])
; Ast.Var.bogus)
val func =
case Pat.node func of
Pat.Var {name, ...} =>
(case Longvid.split name of
([], x) => Vid.toVar x
| _ => illegalName ())
| _ => illegalName ()
val args = Vector.fromList args
val _ =
if Vector.isEmpty args
then error (Region.append (Pat.region (Vector.sub (pats, 0)),
Pat.region (Vector.last pats)),
Layout.str "function clause with no arguments")
else ()
in
case Pat.node func of
Pat.Var {name, ...} =>
(case Longvid.split name of
([], x) => {func = Vid.toVar x,
args = Vector.fromList args}
| _ => illegal ())
| _ => illegal ()
{func = func, args = args}
end
fun doneApplyInfix ({func, argl, argr}, rest) =
let
val func = toPatTop func
val argl = toPatTop argl
val argr = toPatTop argr
in
done (func, (Pat.tuple (Vector.new2 (argl, argr)))::rest)
end
val tuple = Pat.tuple o Vector.new2
fun parse (ps : Pat.t list) =
case ps of
p :: rest =>
let
fun continue () =
case rest of
[] => error (Region.append (Pat.region (Vector.sub (pats, 0)),
Pat.region (Vector.last pats)),
Layout.str "function defined with no arguments")
| _ => done (p, rest)
in
case Pat.node p of
Pat.FlatApp ps =>
if 3 = Vector.length ps
then
let
fun p i = Vector.sub (ps, i)
in done (p 1, tuple (p 0, p 2) :: rest)
end
else continue ()
| Pat.Paren p => parse (p :: rest)
| _ => continue ()
end
| _ => Error.bug "PrecedenceParse.parseClause: empty"
val pats = Vector.toList pats
in
case pats of
[a, b, c] => (case Fixval.makePat (b, E) of
Fixval.Nonfix => parse pats
| _ => done (b, [tuple (a, c)]))
| _ => parse pats
case parseClausePats (pats, E, lay) of
ClausePat.ApplyInfix func_argl_argr =>
doneApplyInfix (func_argl_argr, [])
| p =>
(case toPatList p of
[] => Error.bug "PrecedenceParse.parseClause: empty"
| p::rest =>
let
val improper = fn () =>
(improper (Pat.region p)
; done (Pat.var Ast.Var.bogus, rest))
in
case Pat.node p of
Pat.Paren p' =>
(case Pat.node p' of
Pat.FlatApp pats =>
(case parseClausePats (pats, E, lay) of
ClausePat.ApplyInfix func_argl_argr =>
doneApplyInfix (func_argl_argr, rest)
| _ => improper ())
| _ => improper ())
| _ => done (p, rest)
end)
end

end

0 comments on commit 1a6d25e

Please sign in to comment.