From 17bc1b7942092bd6d1ce0d4a437cd9377787964a Mon Sep 17 00:00:00 2001 From: Josh Brown Date: Sun, 28 Sep 2025 17:36:06 +1000 Subject: [PATCH 1/4] lay foundations for parser --- src/Parser.res | 150 ++++++++++++++++++++++++++++++++++++++++++ tests/ParserTests.res | 19 ++++++ 2 files changed, 169 insertions(+) create mode 100644 src/Parser.res create mode 100644 tests/ParserTests.res diff --git a/src/Parser.res b/src/Parser.res new file mode 100644 index 00000000..86d2bba9 --- /dev/null +++ b/src/Parser.res @@ -0,0 +1,150 @@ +type sourceloc = { + line: int, + col: int, + idx: int, +} + +type parserError<'info> = { + message: 'info, + pos: sourceloc, +} + +type parserState = {pos: sourceloc} + +type t<'a> = (string, parserState) => result<('a, parserState), parserError> + +let initialState = {pos: {line: 1, col: 1, idx: 0}} +let runParser = (p: t<'a>, str: string): result<('a, string), parserError> => { + p(str, initialState)->Result.map(((res, state)) => ( + res, + str->String.sliceToEnd(~start=state.pos.idx), + )) +} + +let map = (p: t<'a>, f: 'a => 'b): t<'b> => (str, state) => + p(str, state)->Result.map(((res, state)) => (f(res), state)) +let pure = (a): t<'a> => (_, state) => Ok((a, state)) +let bind = (p1: t<'a>, p2: 'a => t<'b>): t<'b> => (str, state) => + p1(str, state)->Result.flatMap(((res, state)) => p2(res)(str, state)) +let apply = (p: t<'a>, pf: t<'a => 'b>): t<'b> => p->bind(a => pf->map(f => f(a))) + +let then = (p1: t<'a>, p2: t<'b>): t<'b> => p1->bind(_ => p2) +let thenIgnore = (p1: t<'a>, p2: t<'b>): t<'a> => p1->bind(res => p2->map(_ => res)) +let or = (p1: t<'a>, p2: t<'a>): t<'a> => (str, state) => + switch p1(str, state) { + | Ok(r) => Ok(r) + | Error(_) => p2(str, state) + } +let fail = (info): t<'a> => (_, state) => Error({message: info, pos: state.pos}) +let void = (p: t<'a>): t => p->map(_ => ()) + +let getState: t = (_, state) => Ok((state, state)) +let setState = (newState: parserState): t => (_, _) => Ok(((), newState)) +let modifyState = (f: parserState => parserState) => getState->bind(state => setState(f(state))) +let readStr: t = (str, state) => Ok((str, state)) +let getCurrentStr: t = (str, state) => Ok(( + str->String.sliceToEnd(~start=state.pos.idx), + state, +)) + +let eof: t = getState->bind(state => readStr->map(str => state.pos.idx >= str->String.length)) + +// fixpoints are necessary because rescript compiler complains very ambiguously +// about not knowing the size of recursive combinators +let fix = (f: t<'a> => t<'a>): t<'a> => { + let pRef = ref(fail("umm")) + pRef := f((str, state) => pRef.contents(str, state)) + pRef.contents +} + +let consume = (l: int): t => + getCurrentStr->bind(str => { + if str->String.length < l { + fail("tried to consume too much") + } else { + let consumed = str->String.slice(~start=0, ~end=l) + let vOffset = consumed->String.split("\n")->Array.length - 1 + let hOffset = consumed->String.length - consumed->String.lastIndexOfOpt("\n")->Option.getOr(0) + modifyState(state => { + pos: { + col: vOffset > 0 ? hOffset : state.pos.col + hOffset, + line: state.pos.line + vOffset, + idx: state.pos.idx + l, + }, + })->then(pure(consumed)) + } + }) + +let execRe = (re, str) => { + re + ->RegExp.exec(str) + ->Option.map(result => { + open RegExp.Result + (matches(result), fullMatch(result)->String.length) + }) +} + +// this will be released in Core in 12.0.0.4, remove then +@get external regexpFlags: RegExp.t => string = "flags" + +let string = s => + getCurrentStr->bind(str => + if str->String.startsWith(s) { + consume(String.length(s))->then(pure(s)) + } else { + fail("doesn't start with string") + } + ) + +let regex = (re: RegExp.t): t> => { + let wrapped = { + let source = re->RegExp.source + if source->String.startsWith("^") { + re + } else { + RegExp.fromStringWithFlags(`^${source}`, ~flags=re->regexpFlags) + } + } + getCurrentStr->bind(str => + switch execRe(wrapped, str) { + | Some((matches, l)) => consume(l)->then(pure(matches)) + | None => fail("regex failed") + } + ) +} + +let regex1 = (re: RegExp.t): t => + regex(re)->bind(matches => + switch matches { + | [x] => pure(x) + | _ => fail("more than one match") + } + ) + +let peek = (n): t => (str, state) => { + let res = str->String.slice(~start=state.pos.idx, ~end=state.pos.idx + n) + Ok((res, state)) +} + +type length = int +let takeWhileMany = (f: string => option) => + fix(p => + getCurrentStr->bind(str => + switch f(str) { + | Some(length) => consume(length)->bind(s => p->map(s' => String.concat(s, s'))) + | None => pure("") + } + ) + ) + +let takeWhile = (f: string => bool) => + takeWhileMany(s => + if f(s) { + Some(1) + } else { + None + } + ) + +let lexeme = p => p->thenIgnore(regex(%re(`/^\s*/`))->void) +let token = s => string(s)->lexeme diff --git a/tests/ParserTests.res b/tests/ParserTests.res new file mode 100644 index 00000000..06b1efb7 --- /dev/null +++ b/tests/ParserTests.res @@ -0,0 +1,19 @@ +open Zora +module P = Parser + +let testParse = (t: Zora.t, p, str, ~expect=?) => { + switch P.runParser(p, str) { + | Ok((res, "")) => expect->Option.map(expect => t->equal(res, expect))->ignore + | Ok((_, rem)) => t->fail(~msg=`failed to consume remaining input: ${rem}`) + | Error(e) => t->fail(~msg=`parse failed`) + } +} + +zoraBlock("parse", t => { + t->testParse(P.string("a"), "a", ~expect="a") + t->testParse(P.token("a"), "a \n\r", ~expect="a") + t->testParse(P.string("a")->P.or(P.string("b")), "b", ~expect="b") + let abs = + P.takeWhile(s => s->String.startsWith("a"))->P.bind(res => P.string("b")->P.map(b => (res, b))) + t->testParse(abs, "aaaab", ~expect=("aaaa", "b")) +}) From 0bea65c294ceff03d27377416fb3f822e34e1904 Mon Sep 17 00:00:00 2001 From: Josh Brown Date: Mon, 29 Sep 2025 10:01:03 +1000 Subject: [PATCH 2/4] implement sexp parser with new lib --- src/Parser.res | 67 ++++++++++++++++++++++++++++++++++--------- src/Rule.res | 2 +- tests/ParserTests.res | 4 +++ 3 files changed, 59 insertions(+), 14 deletions(-) diff --git a/src/Parser.res b/src/Parser.res index 86d2bba9..a82b167f 100644 --- a/src/Parser.res +++ b/src/Parser.res @@ -4,17 +4,17 @@ type sourceloc = { idx: int, } -type parserError<'info> = { +type err<'info> = { message: 'info, pos: sourceloc, } -type parserState = {pos: sourceloc} +type state = {pos: sourceloc} -type t<'a> = (string, parserState) => result<('a, parserState), parserError> +type t<'a> = (string, state) => result<('a, state), err> let initialState = {pos: {line: 1, col: 1, idx: 0}} -let runParser = (p: t<'a>, str: string): result<('a, string), parserError> => { +let runParser = (p: t<'a>, str: string): result<('a, string), err> => { p(str, initialState)->Result.map(((res, state)) => ( res, str->String.sliceToEnd(~start=state.pos.idx), @@ -27,20 +27,30 @@ let pure = (a): t<'a> => (_, state) => Ok((a, state)) let bind = (p1: t<'a>, p2: 'a => t<'b>): t<'b> => (str, state) => p1(str, state)->Result.flatMap(((res, state)) => p2(res)(str, state)) let apply = (p: t<'a>, pf: t<'a => 'b>): t<'b> => p->bind(a => pf->map(f => f(a))) - let then = (p1: t<'a>, p2: t<'b>): t<'b> => p1->bind(_ => p2) let thenIgnore = (p1: t<'a>, p2: t<'b>): t<'a> => p1->bind(res => p2->map(_ => res)) + +let fail = (info): t<'a> => (_, state) => Error({message: info, pos: state.pos}) +let void = (p: t<'a>): t => p->map(_ => ()) +// backtracks by default +let optional = (p: t<'a>): t> => (str, state) => { + switch p(str, state) { + | Ok((res, state)) => Ok((Some(res), state)) + | Error(_) => Ok((None, state)) + } +} let or = (p1: t<'a>, p2: t<'a>): t<'a> => (str, state) => switch p1(str, state) { | Ok(r) => Ok(r) | Error(_) => p2(str, state) } -let fail = (info): t<'a> => (_, state) => Error({message: info, pos: state.pos}) -let void = (p: t<'a>): t => p->map(_ => ()) +let choice = (ps: array>): t<'a> => { + ps->Array.reduce(fail("no matches"), or) +} -let getState: t = (_, state) => Ok((state, state)) -let setState = (newState: parserState): t => (_, _) => Ok(((), newState)) -let modifyState = (f: parserState => parserState) => getState->bind(state => setState(f(state))) +let getState: t = (_, state) => Ok((state, state)) +let setState = (newState: state): t => (_, _) => Ok(((), newState)) +let modifyState = (f: state => state) => getState->bind(state => setState(f(state))) let readStr: t = (str, state) => Ok((str, state)) let getCurrentStr: t = (str, state) => Ok(( str->String.sliceToEnd(~start=state.pos.idx), @@ -49,14 +59,25 @@ let getCurrentStr: t = (str, state) => Ok(( let eof: t = getState->bind(state => readStr->map(str => state.pos.idx >= str->String.length)) -// fixpoints are necessary because rescript compiler complains very ambiguously -// about not knowing the size of recursive combinators +// fixpoints using references as a layer of indirection are necessary because +// the compiler complains very ambiguously about not knowing the size of +// (directly) recursive combinators let fix = (f: t<'a> => t<'a>): t<'a> => { let pRef = ref(fail("umm")) pRef := f((str, state) => pRef.contents(str, state)) pRef.contents } +let many = p => + fix(f => + optional(p)->bind(o => + switch o { + | Some(res) => f->map(l => l->List.add(res)) + | None => pure(list{}) + } + ) + )->map(List.toArray) +let between = (inner: t<'a>, o1: t, o2: t): t<'a> => o1->then(inner)->thenIgnore(o2) let consume = (l: int): t => getCurrentStr->bind(str => { if str->String.length < l { @@ -92,7 +113,7 @@ let string = s => if str->String.startsWith(s) { consume(String.length(s))->then(pure(s)) } else { - fail("doesn't start with string") + fail(`${str->String.slice(~start=0, ~end=10)} doesn't start with string ${s}`) } ) @@ -146,5 +167,25 @@ let takeWhile = (f: string => bool) => } ) +let dbg = (p: t<'a>, ~label): t<'a> => { + let dbgInfo = title => + getCurrentStr->bind(str => + getState->map(state => { + let currSurr = `${str->String.slice(~start=0, ~end=10)}...` + let stateStr = `${state.pos.line->Int.toString}:${state.pos.col->Int.toString}` + Console.log(`${title} ${label} at:\n${currSurr}\nstate: ${stateStr}`) + }) + ) + dbgInfo("enter") + ->then(p) + ->bind(res => { + Console.log(("successfully parsed", res)) + dbgInfo("exit")->map(_ => res) + }) +} + let lexeme = p => p->thenIgnore(regex(%re(`/^\s*/`))->void) let token = s => string(s)->lexeme + +let decimal = regex1(%re(`/(\d+)/`))->map(xStr => xStr->Int.fromString->Option.getExn) +let whitespace = regex(%re(`/\s*/`))->void diff --git a/src/Rule.res b/src/Rule.res index 4378692f..e9dbeebf 100644 --- a/src/Rule.res +++ b/src/Rule.res @@ -2,7 +2,7 @@ open Signatures // the tree sitter plugin hates backslashes in string literals unless they're on the top // level.. let ruleNamePattern = "^[^|()\\s\\-—][^()\\s]*" -let vinculumRES = "^\s*\\n\\s*[-—][-—][\\-—]+[ \t]*([^()|\\s\\-—][^()\\s]*)?" +let vinculumRES = "^\\n?\\s*[-—][-—][\\-—]+[ \t]*([^()|\\s\\-—][^()\\s]*)?" module Make = (Term: TERM, Judgment: JUDGMENT with module Term := Term) => { type rec t = {vars: array, premises: array, conclusion: Judgment.t} let rec substitute = (rule: t, subst: Term.subst) => { diff --git a/tests/ParserTests.res b/tests/ParserTests.res index 06b1efb7..4d7c3977 100644 --- a/tests/ParserTests.res +++ b/tests/ParserTests.res @@ -10,10 +10,14 @@ let testParse = (t: Zora.t, p, str, ~expect=?) => { } zoraBlock("parse", t => { + open Parser t->testParse(P.string("a"), "a", ~expect="a") t->testParse(P.token("a"), "a \n\r", ~expect="a") t->testParse(P.string("a")->P.or(P.string("b")), "b", ~expect="b") let abs = P.takeWhile(s => s->String.startsWith("a"))->P.bind(res => P.string("b")->P.map(b => (res, b))) t->testParse(abs, "aaaab", ~expect=("aaaa", "b")) + let brackets = many(lexeme(decimal))->between(token("("), token(")")) + t->testParse(brackets, "(1)", ~expect=[1]) + t->testParse(brackets, "(1 2 3)", ~expect=[1, 2, 3]) }) From e0c7c776fd7bf83e9aee779f9fa704249066bc9f Mon Sep 17 00:00:00 2001 From: Josh Brown Date: Wed, 1 Apr 2026 08:07:19 +1100 Subject: [PATCH 3/4] fix parser lib --- src/Parser.res | 63 +++++++++------ src/SExp.res | 186 ++++++++++----------------------------------- src/StringA.res | 10 +-- tests/RuleTest.res | 59 ++++++++------ 4 files changed, 123 insertions(+), 195 deletions(-) diff --git a/src/Parser.res b/src/Parser.res index a82b167f..de2e0b61 100644 --- a/src/Parser.res +++ b/src/Parser.res @@ -21,11 +21,11 @@ let runParser = (p: t<'a>, str: string): result<('a, string), err> => { )) } -let map = (p: t<'a>, f: 'a => 'b): t<'b> => (str, state) => - p(str, state)->Result.map(((res, state)) => (f(res), state)) +let map = (p: t<'a>, f: 'a => 'b): t<'b> => + (str, state) => p(str, state)->Result.map(((res, state)) => (f(res), state)) let pure = (a): t<'a> => (_, state) => Ok((a, state)) -let bind = (p1: t<'a>, p2: 'a => t<'b>): t<'b> => (str, state) => - p1(str, state)->Result.flatMap(((res, state)) => p2(res)(str, state)) +let bind = (p1: t<'a>, p2: 'a => t<'b>): t<'b> => + (str, state) => p1(str, state)->Result.flatMap(((res, state)) => p2(res)(str, state)) let apply = (p: t<'a>, pf: t<'a => 'b>): t<'b> => p->bind(a => pf->map(f => f(a))) let then = (p1: t<'a>, p2: t<'b>): t<'b> => p1->bind(_ => p2) let thenIgnore = (p1: t<'a>, p2: t<'b>): t<'a> => p1->bind(res => p2->map(_ => res)) @@ -33,17 +33,19 @@ let thenIgnore = (p1: t<'a>, p2: t<'b>): t<'a> => p1->bind(res => p2->map(_ => r let fail = (info): t<'a> => (_, state) => Error({message: info, pos: state.pos}) let void = (p: t<'a>): t => p->map(_ => ()) // backtracks by default -let optional = (p: t<'a>): t> => (str, state) => { - switch p(str, state) { - | Ok((res, state)) => Ok((Some(res), state)) - | Error(_) => Ok((None, state)) - } -} -let or = (p1: t<'a>, p2: t<'a>): t<'a> => (str, state) => - switch p1(str, state) { - | Ok(r) => Ok(r) - | Error(_) => p2(str, state) +let optional = (p: t<'a>): t> => + (str, state) => { + switch p(str, state) { + | Ok((res, state)) => Ok((Some(res), state)) + | Error(_) => Ok((None, state)) + } } +let or = (p1: t<'a>, p2: t<'a>): t<'a> => + (str, state) => + switch p1(str, state) { + | Ok(r) => Ok(r) + | Error(_) => p2(str, state) + } let choice = (ps: array>): t<'a> => { ps->Array.reduce(fail("no matches"), or) } @@ -142,10 +144,11 @@ let regex1 = (re: RegExp.t): t => } ) -let peek = (n): t => (str, state) => { - let res = str->String.slice(~start=state.pos.idx, ~end=state.pos.idx + n) - Ok((res, state)) -} +let peek = (n): t => + (str, state) => { + let res = str->String.slice(~start=state.pos.idx, ~end=state.pos.idx + n) + Ok((res, state)) + } type length = int let takeWhileMany = (f: string => option) => @@ -167,7 +170,7 @@ let takeWhile = (f: string => bool) => } ) -let dbg = (p: t<'a>, ~label): t<'a> => { +let dbg = (p: t<'a>, label): t<'a> => { let dbgInfo = title => getCurrentStr->bind(str => getState->map(state => { @@ -184,8 +187,24 @@ let dbg = (p: t<'a>, ~label): t<'a> => { }) } -let lexeme = p => p->thenIgnore(regex(%re(`/^\s*/`))->void) +let lexeme = p => p->thenIgnore(regex(/^\s*/)->void) let token = s => string(s)->lexeme -let decimal = regex1(%re(`/(\d+)/`))->map(xStr => xStr->Int.fromString->Option.getExn) -let whitespace = regex(%re(`/\s*/`))->void +let decimal = regex1(/(\d+)/)->map(xStr => xStr->Int.fromString->Option.getExn) +let whitespace = regex(/\s*/)->void + +let lift = (f: string => result<('a, string), string>): t<'a> => + getCurrentStr->bind(str => + switch f(str) { + | Ok((res, remaining)) => { + let length = String.length(str) - String.length(remaining) + consume(length)->map(_ => res) + } + | Error(msg) => fail(msg) + } + ) +let liftParse = ( + f: (string, ~scope: array<'m>, ~gen: 'g=?) => result<('a, string), string>, + ~scope: array<'m>, + ~gen: option<'g>=?, +): t<'a> => lift(s => f(s, ~scope, ~gen?)) diff --git a/src/SExp.res b/src/SExp.res index 836f6b53..e1a4138c 100644 --- a/src/SExp.res +++ b/src/SExp.res @@ -250,10 +250,6 @@ module Make = (Atom: AtomDef.COERCIBLE_ATOM): { let prettyPrintSubst = (sub, ~scope) => Util.prettyPrintMap(sub, ~showV=t => prettyPrint(t, ~scope)) - let symbolRegexpString = `^([^\\s()\\[\\]]+)` - let varRegexpString = "^\\\\([0-9]+)$" - let schematicRegexpString = "^\\?([0-9]+)$" - type lexeme = LParen | RParen | VarT(int) | AtomT(Atom.t) | SchematicT(int) let nameRES = "^([^\\s.\\[\\]()]+)\\." let prettyPrintMeta = (str: string) => { String.concat(str, ".") @@ -269,149 +265,49 @@ module Make = (Atom: AtomDef.COERCIBLE_ATOM): { } } } - let parse = (str: string, ~scope: array, ~gen=?) => { - let cur = ref(String.make(str)) - let lex: unit => option = () => { - let str = String.trim(cur.contents) - cur := str - let checkVariable = (candidate: string) => { - let varRegexp = RegExp.fromString(varRegexpString) - switch Array.indexOf(scope, candidate) { - | -1 => - switch varRegexp->RegExp.exec(candidate) { - | Some(res') => - switch RegExp.Result.matches(res') { - | [idx] => Some(idx->Int.fromString->Option.getUnsafe) - | _ => None - } - | None => None - } - | idx => Some(idx) - } - } - if String.get(str, 0) == Some("(") { - cur := String.sliceToEnd(str, ~start=1) - Some(LParen) - } else if String.get(str, 0) == Some(")") { - cur := String.sliceToEnd(str, ~start=1) - Some(RParen) - } else { - let symbolRegexp = RegExp.fromStringWithFlags(symbolRegexpString, ~flags="y") - switch symbolRegexp->RegExp.exec(str) { - | None => None - | Some(res) => - switch RegExp.Result.matches(res) { - | [symb] => { - let specialSymb = tok => { - cur := String.sliceToEnd(str, ~start=RegExp.lastIndex(symbolRegexp)) - Some(tok) - } - let regularSymb = () => { - // FIX: not ideal to throw away symbol error message - Console.log(("current", cur.contents)) - Atom.parse(cur.contents, ~scope) - ->Util.Result.ok - ->Option.map(((s, rest)) => { - cur := rest - Console.log(("parsed", s, cur.contents)) - AtomT(s) - }) - } - switch checkVariable(symb) { - | Some(idx) => specialSymb(VarT(idx)) - | None => { - let schematicRegexp = RegExp.fromString(schematicRegexpString) - switch schematicRegexp->RegExp.exec(symb) { - | None => regularSymb() - | Some(res') => - switch RegExp.Result.matches(res') { - | [s] => specialSymb(SchematicT(s->Int.fromString->Option.getUnsafe)) - | _ => regularSymb() - } - } - } - } - } - | _ => None + let mkParser = (~scope: array, ~gen=?): Parser.t => { + open Parser + let varLit = string("\\")->then(decimal) + let ident = regex1(/([^\s\(\)]+)/) + let varIdx = + varLit + ->or( + ident->bind(id => + switch scope->Array.indexOfOpt(id) { + | Some(idx) => pure(idx) + | None => fail("expected variable") } - } - } - } + ), + ) + ->lexeme + let var = varIdx->map(idx => Var({idx: idx})) - let peek = () => { - // a bit slow, better would be to keep a backlog of lexed tokens.. - let str = String.make(cur.contents) - let tok = lex() - cur := str - tok - } - exception ParseError(string) - let rec parseExp = () => { - let tok = peek() - switch tok { - | Some(AtomT(s)) => { - let _ = lex() - Some(Atom(s)) - } - | Some(VarT(idx)) => { - let _ = lex() - Some(Var({idx: idx})) - } - | Some(SchematicT(num)) => { - let _ = lex() - switch lex() { - | Some(LParen) => { - let it = ref(None) - let bits = [] - let getVar = (t: option) => - switch t { - | Some(VarT(idx)) => Some(idx) - | _ => None - } - while { - it := lex() - it.contents->getVar->Option.isSome - } { - Array.push(bits, it.contents->getVar->Option.getUnsafe) - } - switch it.contents { - | Some(RParen) => - switch gen { - | Some(g) => { - seen(g, num) - Some(Schematic({schematic: num, allowed: bits})) - } - | None => throw(ParseError("Schematics not allowed here")) - } - | _ => throw(ParseError("Expected closing parenthesis")) - } - } - | _ => throw(ParseError("Expected opening parenthesis")) - } - } - | Some(LParen) => { - let _ = lex() - let bits = [] - let it = ref(None) - while { - it := parseExp() - it.contents->Option.isSome - } { - Array.push(bits, it.contents->Option.getUnsafe) - } - switch lex() { - | Some(RParen) => Some(Compound({subexps: bits})) - | _ => throw(ParseError("Expected closing parenthesis")) - } - } - | _ => None - } - } - switch parseExp() { - | exception ParseError(s) => Error(s) - | None => Error("No expression to parse") - | Some(e) => Ok((e, cur.contents)) - } + let schemaLit = + string("?") + ->then(decimal) + ->bind(schematic => + many(varIdx) + ->between(token("("), token(")")) + ->map(allowed => { + gen->Option.map(g => allowed->Array.forEach(n => seen(g, n)))->ignore + Schematic({schematic, allowed}) + }) + ) + let inner = fix(f => + choice([ + schemaLit, + var, + liftParse(Atom.parse, ~scope, ~gen?)->map(a => Atom(a)), + many(f) + ->between(token("("), token(")")) + ->map(subexps => Compound({subexps: subexps})), + ])->lexeme + ) + whitespace->then(inner) + } + + let parse = (str: string, ~scope: array, ~gen=?) => { + Parser.runParser(mkParser(~scope, ~gen?), str)->Result.mapError(e => e.message) } let rec concrete = t => diff --git a/src/StringA.res b/src/StringA.res index 654a50f7..85604d37 100644 --- a/src/StringA.res +++ b/src/StringA.res @@ -479,11 +479,11 @@ module AtomView = { } let parenthesise = f => - [ - {React.string("(")} , - ...f, - {React.string(")")} , - ] + Array.flat([ + [ {React.string("(")} ], + f, + [ {React.string(")")} ], + ]) let intersperse = a => Util.intersperse(a, ~with=React.string(" ")) diff --git a/tests/RuleTest.res b/tests/RuleTest.res index 9b9d23e0..7ca2e560 100644 --- a/tests/RuleTest.res +++ b/tests/RuleTest.res @@ -31,26 +31,39 @@ module MakeTest = (Term: TERM, Judgment: JUDGMENT with module Term := Term) => { } } -// zoraBlock("string terms", t => { -// module T = MakeTest(StringSExp, StringSExpJ) -// t->T.testParseInner( -// `[s1. ("$s1" p) |- ("($s1)" p)]`, -// { -// vars: ["s1"], -// premises: [ -// { -// vars: [], -// premises: [], -// conclusion: StringSExp.Compound( -// [StringA.Atom.Var({idx: 0})], -// SExp.pAtom("p")->StringA.AtomJudgment.ConstS->StringSymbolic.Atom, -// ), -// }, -// ], -// conclusion: ( -// [StringA.Atom.String("("), StringA.Atom.Var({idx: 0}), StringA.Atom.String(")")], -// SExp.pAtom("p")->StringA.AtomJudgment.ConstS->StringSymbolic.Atom, -// ), -// }, -// ) -// }) +zoraBlock("string terms", t => { + module StringSymbol = AtomDef.MakeAtomAndView( + Coercible.StringA, + StringA.AtomView, + Coercible.Symbolic, + Symbolic.AtomView, + ) + module StringSExp = SExp.Make(StringSymbol.Atom) + module T = MakeTest(StringSExp, StringSExp) + t->T.testParseInner( + `[s1. ("$s1" p) |- ("($s1)" p)]`, + { + vars: ["s1"], + premises: [ + { + vars: [], + premises: [], + conclusion: StringSExp.Compound({ + subexps: [ + [StringA.Var({idx: 0})]->StringSymbol.Atom.Left->StringSExp.Atom, + "p"->StringSymbol.Atom.Right->StringSExp.Atom, + ], + }), + }, + ], + conclusion: StringSExp.Compound({ + subexps: [ + [StringA.String("("), StringA.Var({idx: 0}), StringA.String(")")] + ->StringSymbol.Atom.Left + ->StringSExp.Atom, + "p"->StringSymbol.Atom.Right->StringSExp.Atom, + ], + }), + }, + ) +}) From 20f51108a6efb25f317607488fd001f513fafe18 Mon Sep 17 00:00:00 2001 From: Josh Brown Date: Thu, 2 Apr 2026 14:06:03 +1100 Subject: [PATCH 4/4] improve parsing error messages with expects clause --- src/Parser.res | 65 +++++++++++++++++++++++++++++++++++--------------- src/SExp.res | 13 +++++----- 2 files changed, 52 insertions(+), 26 deletions(-) diff --git a/src/Parser.res b/src/Parser.res index de2e0b61..f6356cf1 100644 --- a/src/Parser.res +++ b/src/Parser.res @@ -4,25 +4,52 @@ type sourceloc = { idx: int, } -type err<'info> = { - message: 'info, +type info = { + msg?: string, + expects: array, +} + +type err = { + info: info, pos: sourceloc, } type state = {pos: sourceloc} -type t<'a> = (string, state) => result<('a, state), err> +type t<'a> = (string, state) => result<('a, state), err> +let infoPretty = (info: info) => { + let expectedMsg = switch info.expects { + | [] => None + | [expect] => Some(`expected ${expect}`) + | _ => { + let n = Array.length(info.expects) + let first = info.expects->Array.slice(~start=0, ~end=n - 1)->Array.join(", ") + Some(`expected ${first}, or ${info.expects[n - 1]->Option.getUnsafe}`) + } + } + switch (info.msg, expectedMsg) { + | (Some(infoMsg), Some(expectedMsg)) => `parse failed: ${infoMsg}\n ${expectedMsg}` + | (None, Some(msg)) | (Some(msg), None) => `parse failed: ${msg}` + | (None, None) => `parse failed` + } +} let initialState = {pos: {line: 1, col: 1, idx: 0}} -let runParser = (p: t<'a>, str: string): result<('a, string), err> => { - p(str, initialState)->Result.map(((res, state)) => ( - res, - str->String.sliceToEnd(~start=state.pos.idx), - )) +let runParser = (p: t<'a>, str: string): result<('a, string), string> => { + p(str, initialState) + ->Result.map(((res, state)) => (res, str->String.sliceToEnd(~start=state.pos.idx))) + ->Result.mapError(err => { + `around ${str->String.slice(~start=err.pos.idx, ~end=err.pos.idx + 5)}:\n${infoPretty( + err.info, + )}` + }) } let map = (p: t<'a>, f: 'a => 'b): t<'b> => (str, state) => p(str, state)->Result.map(((res, state)) => (f(res), state)) +let mapError = (p: t<'a>, f: err => err) => (str, state) => p(str, state)->Result.mapError(f) +let label = (p: t<'a>, label: string) => + p->mapError(err => {...err, info: {...err.info, expects: [label]}}) let pure = (a): t<'a> => (_, state) => Ok((a, state)) let bind = (p1: t<'a>, p2: 'a => t<'b>): t<'b> => (str, state) => p1(str, state)->Result.flatMap(((res, state)) => p2(res)(str, state)) @@ -30,22 +57,22 @@ let apply = (p: t<'a>, pf: t<'a => 'b>): t<'b> => p->bind(a => pf->map(f => f(a) let then = (p1: t<'a>, p2: t<'b>): t<'b> => p1->bind(_ => p2) let thenIgnore = (p1: t<'a>, p2: t<'b>): t<'a> => p1->bind(res => p2->map(_ => res)) -let fail = (info): t<'a> => (_, state) => Error({message: info, pos: state.pos}) +let fail = (info): t<'a> => (_, state) => Error({info: {msg: info, expects: []}, pos: state.pos}) +let expected = (expects: array, ~msg=?): t<'a> => + (_, state) => Error({info: {?msg, expects}, pos: state.pos}) let void = (p: t<'a>): t => p->map(_ => ()) // backtracks by default -let optional = (p: t<'a>): t> => - (str, state) => { - switch p(str, state) { - | Ok((res, state)) => Ok((Some(res), state)) - | Error(_) => Ok((None, state)) - } - } let or = (p1: t<'a>, p2: t<'a>): t<'a> => (str, state) => switch p1(str, state) { | Ok(r) => Ok(r) - | Error(_) => p2(str, state) + | Error(e1) => + p2(str, state)->Result.mapError(e2 => { + ...e2, + info: {expects: Array.concat(e1.info.expects, e2.info.expects)}, + }) } +let optional = (p: t<'a>): t> => p->map(a => Some(a))->or(pure(None)) let choice = (ps: array>): t<'a> => { ps->Array.reduce(fail("no matches"), or) } @@ -115,7 +142,7 @@ let string = s => if str->String.startsWith(s) { consume(String.length(s))->then(pure(s)) } else { - fail(`${str->String.slice(~start=0, ~end=10)} doesn't start with string ${s}`) + expected([`literal ${s}`]) } ) @@ -131,7 +158,7 @@ let regex = (re: RegExp.t): t> => { getCurrentStr->bind(str => switch execRe(wrapped, str) { | Some((matches, l)) => consume(l)->then(pure(matches)) - | None => fail("regex failed") + | None => expected([`regex pattern ${re->RegExp.source}`]) } ) } diff --git a/src/SExp.res b/src/SExp.res index e1a4138c..d12a9bc4 100644 --- a/src/SExp.res +++ b/src/SExp.res @@ -295,20 +295,19 @@ module Make = (Atom: AtomDef.COERCIBLE_ATOM): { ) let inner = fix(f => choice([ - schemaLit, - var, - liftParse(Atom.parse, ~scope, ~gen?)->map(a => Atom(a)), + schemaLit->label("schematic"), + var->label("variable"), + liftParse(Atom.parse, ~scope, ~gen?)->map(a => Atom(a))->label("atom"), many(f) - ->between(token("("), token(")")) + ->between(token("(")->label("open expression"), token(")")->label("close expression")) ->map(subexps => Compound({subexps: subexps})), ])->lexeme ) whitespace->then(inner) } - let parse = (str: string, ~scope: array, ~gen=?) => { - Parser.runParser(mkParser(~scope, ~gen?), str)->Result.mapError(e => e.message) - } + let parse = (str: string, ~scope: array, ~gen=?) => + Parser.runParser(mkParser(~scope, ~gen?), str) let rec concrete = t => switch t {