From 23f8381f633718612f51a3f8eca55bb99cabcb95 Mon Sep 17 00:00:00 2001 From: Viktor Palmkvist Date: Thu, 21 Nov 2024 14:38:19 +0100 Subject: [PATCH] Move scripts into misc/scripts --- Makefile | 12 +- misc/{ => scripts}/elide-cat | 0 misc/{ => scripts}/gen-tup-rules | 2 +- misc/{ => scripts}/repo-files | 0 misc/{ => scripts}/repo-ignored-files | 0 misc/{ => scripts}/with-tmp-dir | 0 misc/test | 23 +- misc/test-spec.mc | 85 +- misc/watch | 2 +- src/Tupdefault | 2 +- src/Tupfile | 119 +-- src/stdlib/parser/breakable-helper.mc | 1049 ------------------------- 12 files changed, 88 insertions(+), 1206 deletions(-) rename misc/{ => scripts}/elide-cat (100%) rename misc/{ => scripts}/gen-tup-rules (78%) rename misc/{ => scripts}/repo-files (100%) rename misc/{ => scripts}/repo-ignored-files (100%) rename misc/{ => scripts}/with-tmp-dir (100%) delete mode 100644 src/stdlib/parser/breakable-helper.mc diff --git a/Makefile b/Makefile index 4c3aad38a..75f47630a 100644 --- a/Makefile +++ b/Makefile @@ -42,7 +42,7 @@ default: bootstrap # directory, which should coincide with generated files .PHONY: clean clean: - bash -c 'mapfile -t args < <(misc/repo-ignored-files build); rm -rf "$${args[@]}"' + misc/scripts/repo-ignored-files build | tr "\n" "\0" | xargs -r0 rm -f find build -depth -type d -empty -delete @@ -50,30 +50,30 @@ clean: .PHONY: boot boot: - misc/with-tmp-dir dune build --root=src/boot/ --build-dir="{}" \ + misc/scripts/with-tmp-dir dune build --root=src/boot/ --build-dir="{}" \ "&&" dune install --root=src/boot/ --build-dir="{}" --prefix=$(current_dir)/build ">/dev/null" "2>&1" mv $(current_dir)"/build/bin/boot" build/$(BOOT_NAME) rm -f $(current_dir)"/build/lib/boot/dune-package" .PHONY: install-boot install-boot: - misc/with-tmp-dir dune build --root=src/boot/ --build-dir="{}" \ + misc/scripts/with-tmp-dir dune build --root=src/boot/ --build-dir="{}" \ "&&" dune install --root=src/boot/ --build-dir="{}" --prefix=$(prefix) --libdir=$(ocamllibdir) ">/dev/null 2>&1" .PHONY: uninstall-boot uninstall-boot: - misc/with-tmp-dir dune uninstall --root=src/boot --build-dir="{}" --prefix=$(prefix) --libdir=$(ocamllibdir) ">/dev/null 2>&1" + misc/scripts/with-tmp-dir dune uninstall --root=src/boot --build-dir="{}" --prefix=$(prefix) --libdir=$(ocamllibdir) ">/dev/null 2>&1" ## Formatting, checking and autoformatting respectively .PHONY: lint lint: - misc/with-tmp-dir dune fmt --root=src/boot/ --build-dir="{}" + misc/scripts/with-tmp-dir dune fmt --root=src/boot/ --build-dir="{}" .PHONY: fix fix: - misc/with-tmp-dir dune fmt --root=src/boot/ --build-dir="{}" --auto-promote + misc/scripts/with-tmp-dir dune fmt --root=src/boot/ --build-dir="{}" --auto-promote # Bootstrapping the `mi` executable diff --git a/misc/elide-cat b/misc/scripts/elide-cat similarity index 100% rename from misc/elide-cat rename to misc/scripts/elide-cat diff --git a/misc/gen-tup-rules b/misc/scripts/gen-tup-rules similarity index 78% rename from misc/gen-tup-rules rename to misc/scripts/gen-tup-rules index 4963c8401..6165c500b 100755 --- a/misc/gen-tup-rules +++ b/misc/scripts/gen-tup-rules @@ -2,7 +2,7 @@ set -e -DIR=$(dirname "$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )") +DIR=$(dirname "$(dirname "$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )")") TARGETDIR=$(realpath --relative-to="$DIR" .) cd "$DIR" diff --git a/misc/repo-files b/misc/scripts/repo-files similarity index 100% rename from misc/repo-files rename to misc/scripts/repo-files diff --git a/misc/repo-ignored-files b/misc/scripts/repo-ignored-files similarity index 100% rename from misc/repo-ignored-files rename to misc/scripts/repo-ignored-files diff --git a/misc/with-tmp-dir b/misc/scripts/with-tmp-dir similarity index 100% rename from misc/with-tmp-dir rename to misc/scripts/with-tmp-dir diff --git a/misc/test b/misc/test index 5670348cf..de615503d 100755 --- a/misc/test +++ b/misc/test @@ -16,16 +16,23 @@ if [ ! "$DIR" -ef "$TARGETDIR" ]; then exit 1 fi -export MCORE_LIBS=stdlib=$DIR/src/stdlib - if [ misc/test-spec -ot misc/test-spec.mc ]; then if command -v mi >/dev/null 2>&1; then + # NOTE(vipa, 2024-11-22): Use built-in mi, with built-in stdlib mi compile misc/test-spec.mc --output misc/test-spec else - build/mi compile misc/test-spec.mc --output misc/test-spec + # NOTE(vipa, 2024-11-22): Use bootstrapped mi, with repo-local stdlib and boot + MCORE_LIBS=stdlib=$DIR/src/stdlib OCAMLPATH=$DIR/build/lib:$OCAMLPATH build/mi compile misc/test-spec.mc --output misc/test-spec fi fi +# NOTE(vipa, 2024-11-22): Unconditionally overwrite MCORE_LIBS, since +# tests should run with this value. +export MCORE_LIBS=stdlib=$DIR/src/stdlib +if [[ ! (":$OCAMLPATH:" == *":$DIR/build/lib:"*) ]]; then + export OCAMLPATH=$DIR/build/lib:$OCAMLPATH +fi + if command -v tup >/dev/null 2>&1; then if [ -d ".tup" ]; then useTup=1 @@ -39,15 +46,7 @@ fi if [ $useTup -eq 1 ]; then echo "Using 'tup' as a test runner" - tmp=$(mktemp) - if ! misc/test-spec --tup-filter "$@" > "$tmp"; then - cat "$tmp" - rm "$tmp" - exit 1 - fi - mapfile -t args < "$tmp" - rm "$tmp" - exec tup -k "${args[@]}" + misc/test-spec --tup-filter "$@" | tr "\n" "\0" | xargs -0r tup -k else echo "Using 'make' as a test runner" exec make -f <(misc/test-spec --make "$@") diff --git a/misc/test-spec.mc b/misc/test-spec.mc index 70c164eea..62c568fea 100644 --- a/misc/test-spec.mc +++ b/misc/test-spec.mc @@ -285,16 +285,15 @@ let _glob _restrictToDir dir args.glob else Some args.glob in match glob with Some glob then - let globStr = strJoin "/" (cons "src" glob.dirs) in - let globStr = match glob.subdirs with IncludeSubs _ - then concat globStr "/**" - else globStr in - let globStr = switch glob.file - case ExactFile f then join [globStr, "/", f] - case SuffixFile f then join [globStr, "/*", f] + let dir = [strJoin "/" (cons "src" glob.dirs)] in + let depth = match glob.subdirs with IncludeSubs _ + then [] + else ["-maxdepth", "1"] in + let name = switch glob.file + case ExactFile f then ["-name", f] + case SuffixFile f then ["-name", concat "\\*" f] end in - let bashCmd = join ["\"for f in ", globStr, "; do echo \\$f; done\""] in - let res = sysRunCommand ["bash", "-O", "globstar", "-O", "nullglob", "-c", bashCmd] "" args.root in + let res = sysRunCommand (join [["find"], dir, depth, name]) "" args.root in let stringToPath = lam s. OrigPath { path = match strSplit "/" s with dirs ++ [file] in (dirs, file) } in let paths = init (strSplit "\n" res.stdout) in let paths = match args.files with Some files @@ -472,8 +471,9 @@ let testMain : [TestCollection] -> () = lam colls. (if setIsEmpty unknownColls then () else let msg = join [ "Unknown test set(s): ", strJoin ", " (setToSeq unknownColls), "\n" - , "Try one of these: ", strJoin ", " (setToSeq knownColls)] in - printLn msg; + , "Try one of these: ", strJoin ", " (setToSeq knownColls), "\n"] in + printError msg; + flushStderr (); exit 1); _phase "unknownColls"; @@ -568,8 +568,8 @@ let testMain : [TestCollection] -> () = lam colls. then "%2o" else pathToString stderr in let elideCat = match options.mode with TupRules _ - then "$(ROOT)/misc/elide-cat" - else "misc/elide-cat" in + then "$(ROOT)/misc/scripts/elide-cat" + else "misc/scripts/elide-cat" in let command = join [ "{ ", command, "; } >'", stdoutStr, "' 2>'", stderrStr , "' || { ", elideCat, " stdout '", stdoutStr, "'; ", elideCat, " stderr '", stderrStr, "'; false; }" @@ -621,9 +621,9 @@ let testMain : [TestCollection] -> () = lam colls. switch tasks.compile case Dont _ then () case Fail _ then - run.f {input = src, cmd = "%m compile --test %i --exit-before", tag = "exe"} + run.f {input = src, cmd = "%m compile --disable-prune-utests --test %i --exit-before", tag = "exe"} case Success _ then - let exe = run.m {input = src, cmd = "%m compile --test %i --output %o", tag = "exe"} in + let exe = run.m {input = src, cmd = "%m compile --disable-prune-utests --test %i --output %o", tag = "exe"} in (switch tasks.run case Dont _ then () case Fail _ then @@ -634,9 +634,9 @@ let testMain : [TestCollection] -> () = lam colls. (switch _minER tasks.run tasks.interpret case Dont _ then () case Fail _ then - run.f {input = src, cmd = "%m eval --test %i", tag = "eval"} + run.f {input = src, cmd = "%m eval --disable-prune-utests --test %i", tag = "eval"} case Success _ then - run.e {input = src, cmd = "%m eval --test %i", tag = "eval"} + run.e {input = src, cmd = "%m eval --disable-prune-utests --test %i", tag = "eval"} end) end in @@ -812,9 +812,30 @@ testMain , "test/examples/test-prune-utests.mc" ]); - -- Files where interpretation is expected to fail + -- Files using externals not available in the interpreter api.mark interpretFail (api.strsToPaths - [ "test/examples/utest.mc" + [ "stdlib/ext/file-ext.mc" + , "stdlib/ext/array-ext.mc" + , "stdlib/ext/async-ext.mc" + , "stdlib/ext/ext-test.mc" + , "stdlib/ext/dist-ext.mc" + , "stdlib/ext/local-search.mc" + , "stdlib/ext/math-ext.mc" + , "stdlib/ext/matrix-ext.mc" + , "stdlib/ext/toml-ext.mc" + , "test/examples/external/ext-list-map.mc" + , "test/examples/external/ext-list-concat-map.mc" + , "stdlib/multicore/atomic.mc" + , "stdlib/multicore/atomic.mc" + , "stdlib/multicore/channel.mc" + , "stdlib/multicore/thread.mc" + , "stdlib/multicore/thread-pool.mc" + , "stdlib/multicore/cond.mc" + , "stdlib/multicore/mutex.mc" + , "stdlib/multicore/pseq.mc" + , "stdlib/tuning/tune-options.mc" + , "stdlib/stats.mc" + , "stdlib/math.mc" ]); -- Files that *should* fail to compile @@ -988,6 +1009,32 @@ testMain api.mark interpretFail (api.strsToPaths ["test/meta/recursive-let.mc"]) } + , { testColl "ipopt" + with checkCondition = lam. + if eqi 0 (command "ocamlfind query ipoptml &>/dev/null") + then ConditionsMet () + -- TODO(vipa, 2024-11-22): This is technically incorrect, but + -- these tests are not run in the previous test suite, so we + -- ignore them like this + else ConditionsImpossible () + , conditionalInclusions = lam api. + api.mark {defaultTasks with interpret = Fail ()} + (api.glob ["stdlib", "ipopt"] (IncludeSubs ()) (SuffixFile ".mc")) + } + +, { testColl "sundials" + with checkCondition = lam. + if eqi 0 (command "ocamlfind query sundialsml &>/dev/null") + then ConditionsMet () + -- TODO(vipa, 2024-11-22): This is technically incorrect, but + -- these tests are not run in the previous test suite, so we + -- ignore them like this + else ConditionsImpossible () + , conditionalInclusions = lam api. + api.mark {defaultTasks with interpret = Fail ()} + (api.glob ["stdlib", "sundials"] (IncludeSubs ()) (SuffixFile ".mc")) + } + , { testColl "lrk" with exclusions = lam api. api.mark noTasks (api.glob ["test", "examples", "parser"] (IncludeSubs ()) (SuffixFile ".mc")) diff --git a/misc/watch b/misc/watch index 01f9a885c..bed504fc6 100755 --- a/misc/watch +++ b/misc/watch @@ -4,4 +4,4 @@ set -e DIR=$(dirname "$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )") -"$DIR/misc/repo-files" | entr -rc "$DIR/misc/test" "$@" +"$DIR/misc/scripts/repo-files" | entr -rc "$DIR/misc/test" "$@" diff --git a/src/Tupdefault b/src/Tupdefault index 2bcca106c..074664ad8 100644 --- a/src/Tupdefault +++ b/src/Tupdefault @@ -1,3 +1,3 @@ include_rules -run $(ROOT)/misc/gen-tup-rules +run $(ROOT)/misc/scripts/gen-tup-rules diff --git a/src/Tupfile b/src/Tupfile index 852e33e97..e5ce29f1c 100644 --- a/src/Tupfile +++ b/src/Tupfile @@ -5,133 +5,18 @@ STDLIB := MCORE_LIBS=stdlib=$(ROOT)/src/stdlib OCAMLPATH=$(VARIANT_SRC)/lib${OCA # NOTE(vipa, 2023-05-16): This is ugly, but appears stable and does # seem to work BOOT_LIB_FILES += lib/boot/META -BOOT_LIB_FILES += lib/boot/ast.ml BOOT_LIB_FILES += lib/boot/boot.a BOOT_LIB_FILES += lib/boot/boot.cma -BOOT_LIB_FILES += lib/boot/boot.cmi -BOOT_LIB_FILES += lib/boot/boot.cmt -BOOT_LIB_FILES += lib/boot/boot.cmx BOOT_LIB_FILES += lib/boot/boot.cmxa -BOOT_LIB_FILES += lib/boot/boot.ml -BOOT_LIB_FILES += lib/boot/boot__Ast.cmi -BOOT_LIB_FILES += lib/boot/boot__Ast.cmt -BOOT_LIB_FILES += lib/boot/boot__Ast.cmx -BOOT_LIB_FILES += lib/boot/boot__Bootparser.cmi -BOOT_LIB_FILES += lib/boot/boot__Bootparser.cmt -BOOT_LIB_FILES += lib/boot/boot__Bootparser.cmx -BOOT_LIB_FILES += lib/boot/boot__Builtin.cmi -BOOT_LIB_FILES += lib/boot/boot__Builtin.cmt -BOOT_LIB_FILES += lib/boot/boot__Builtin.cmx -BOOT_LIB_FILES += lib/boot/boot__Deadcode.cmi -BOOT_LIB_FILES += lib/boot/boot__Deadcode.cmt -BOOT_LIB_FILES += lib/boot/boot__Deadcode.cmx -BOOT_LIB_FILES += lib/boot/boot__Eval.cmi -BOOT_LIB_FILES += lib/boot/boot__Eval.cmt -BOOT_LIB_FILES += lib/boot/boot__Eval.cmx -BOOT_LIB_FILES += lib/boot/boot__Ext.cmi -BOOT_LIB_FILES += lib/boot/boot__Ext.cmt -BOOT_LIB_FILES += lib/boot/boot__Ext.cmx -BOOT_LIB_FILES += lib/boot/boot__Exttest.cmi -BOOT_LIB_FILES += lib/boot/boot__Exttest.cmt -BOOT_LIB_FILES += lib/boot/boot__Exttest.cmx -BOOT_LIB_FILES += lib/boot/boot__Intrinsics.cmi -BOOT_LIB_FILES += lib/boot/boot__Intrinsics.cmt -BOOT_LIB_FILES += lib/boot/boot__Intrinsics.cmti -BOOT_LIB_FILES += lib/boot/boot__Intrinsics.cmx -BOOT_LIB_FILES += lib/boot/boot__Lexer.cmi -BOOT_LIB_FILES += lib/boot/boot__Lexer.cmt -BOOT_LIB_FILES += lib/boot/boot__Lexer.cmx -BOOT_LIB_FILES += lib/boot/boot__Mexpr.cmi -BOOT_LIB_FILES += lib/boot/boot__Mexpr.cmt -BOOT_LIB_FILES += lib/boot/boot__Mexpr.cmx -BOOT_LIB_FILES += lib/boot/boot__Mlang.cmi -BOOT_LIB_FILES += lib/boot/boot__Mlang.cmt -BOOT_LIB_FILES += lib/boot/boot__Mlang.cmx -BOOT_LIB_FILES += lib/boot/boot__Msg.cmi -BOOT_LIB_FILES += lib/boot/boot__Msg.cmt -BOOT_LIB_FILES += lib/boot/boot__Msg.cmx -BOOT_LIB_FILES += lib/boot/boot__Parser.cmi -BOOT_LIB_FILES += lib/boot/boot__Parser.cmt -BOOT_LIB_FILES += lib/boot/boot__Parser.cmti -BOOT_LIB_FILES += lib/boot/boot__Parser.cmx -BOOT_LIB_FILES += lib/boot/boot__Parserutils.cmi -BOOT_LIB_FILES += lib/boot/boot__Parserutils.cmt -BOOT_LIB_FILES += lib/boot/boot__Parserutils.cmx -BOOT_LIB_FILES += lib/boot/boot__Patterns.cmi -BOOT_LIB_FILES += lib/boot/boot__Patterns.cmt -BOOT_LIB_FILES += lib/boot/boot__Patterns.cmx -BOOT_LIB_FILES += lib/boot/boot__Pprint.cmi -BOOT_LIB_FILES += lib/boot/boot__Pprint.cmt -BOOT_LIB_FILES += lib/boot/boot__Pprint.cmx -BOOT_LIB_FILES += lib/boot/boot__Pyast.cmi -BOOT_LIB_FILES += lib/boot/boot__Pyast.cmt -BOOT_LIB_FILES += lib/boot/boot__Pyast.cmx -BOOT_LIB_FILES += lib/boot/boot__Pyffi.cmi -BOOT_LIB_FILES += lib/boot/boot__Pyffi.cmt -BOOT_LIB_FILES += lib/boot/boot__Pyffi.cmx -BOOT_LIB_FILES += lib/boot/boot__Pypprint.cmi -BOOT_LIB_FILES += lib/boot/boot__Pypprint.cmt -BOOT_LIB_FILES += lib/boot/boot__Pypprint.cmx -BOOT_LIB_FILES += lib/boot/boot__Repl.cmi -BOOT_LIB_FILES += lib/boot/boot__Repl.cmt -BOOT_LIB_FILES += lib/boot/boot__Repl.cmx -BOOT_LIB_FILES += lib/boot/boot__Rope.cmi -BOOT_LIB_FILES += lib/boot/boot__Rope.cmt -BOOT_LIB_FILES += lib/boot/boot__Rope.cmti -BOOT_LIB_FILES += lib/boot/boot__Rope.cmx -BOOT_LIB_FILES += lib/boot/boot__Symbolize.cmi -BOOT_LIB_FILES += lib/boot/boot__Symbolize.cmt -BOOT_LIB_FILES += lib/boot/boot__Symbolize.cmx -BOOT_LIB_FILES += lib/boot/boot__Symbutils.cmi -BOOT_LIB_FILES += lib/boot/boot__Symbutils.cmt -BOOT_LIB_FILES += lib/boot/boot__Symbutils.cmx -BOOT_LIB_FILES += lib/boot/boot__Tensor.cmi -BOOT_LIB_FILES += lib/boot/boot__Tensor.cmt -BOOT_LIB_FILES += lib/boot/boot__Tensor.cmti -BOOT_LIB_FILES += lib/boot/boot__Tensor.cmx -BOOT_LIB_FILES += lib/boot/boot__Ustring.cmi -BOOT_LIB_FILES += lib/boot/boot__Ustring.cmt -BOOT_LIB_FILES += lib/boot/boot__Ustring.cmti -BOOT_LIB_FILES += lib/boot/boot__Ustring.cmx -BOOT_LIB_FILES += lib/boot/boot__Utils.cmi -BOOT_LIB_FILES += lib/boot/boot__Utils.cmt -BOOT_LIB_FILES += lib/boot/boot__Utils.cmx -BOOT_LIB_FILES += lib/boot/bootparser.ml -BOOT_LIB_FILES += lib/boot/builtin.ml -BOOT_LIB_FILES += lib/boot/deadcode.ml -BOOT_LIB_FILES += lib/boot/eval.ml -BOOT_LIB_FILES += lib/boot/ext.ml -BOOT_LIB_FILES += lib/boot/exttest.ml -BOOT_LIB_FILES += lib/boot/intrinsics.ml BOOT_LIB_FILES += lib/boot/intrinsics.mli -BOOT_LIB_FILES += lib/boot/lexer.ml -BOOT_LIB_FILES += lib/boot/mexpr.ml -BOOT_LIB_FILES += lib/boot/mlang.ml -BOOT_LIB_FILES += lib/boot/msg.ml -BOOT_LIB_FILES += lib/boot/opam -BOOT_LIB_FILES += lib/boot/parser.ml BOOT_LIB_FILES += lib/boot/parser.mli -BOOT_LIB_FILES += lib/boot/parserutils.ml -BOOT_LIB_FILES += lib/boot/patterns.ml -BOOT_LIB_FILES += lib/boot/pprint.ml -BOOT_LIB_FILES += lib/boot/pyast.ml -BOOT_LIB_FILES += lib/boot/pyffi.ml -BOOT_LIB_FILES += lib/boot/pypprint.ml -BOOT_LIB_FILES += lib/boot/repl.ml -BOOT_LIB_FILES += lib/boot/rope.ml BOOT_LIB_FILES += lib/boot/rope.mli -BOOT_LIB_FILES += lib/boot/symbolize.ml -BOOT_LIB_FILES += lib/boot/symbutils.ml -BOOT_LIB_FILES += lib/boot/tensor.ml BOOT_LIB_FILES += lib/boot/tensor.mli -BOOT_LIB_FILES += lib/boot/ustring.ml BOOT_LIB_FILES += lib/boot/ustring.mli -BOOT_LIB_FILES += lib/boot/utils.ml -BOOT_LIB_FILES += lib/boot/boot.cmxs -: |> ^b dune build^ ../misc/with-tmp-dir dune build --root=boot/ --build-dir="{}" "&&" cd . "&&" dune install --build-dir="{}" --prefix=\$(realpath $(VARIANT_SRC)) --root=boot/ ">/dev/null" "2>&1" "&&" mv $(VARIANT_SRC)/bin/boot %1o "&&" rm -rf $(VARIANT_SRC)/bin $(VARIANT_SRC)/lib/boot/dune-package |> mi-boot | $(BOOT_LIB_FILES) +preload boot -: | mi-boot $(BOOT_LIB_FILES) |> $(STDLIB) echo $OCAMLPATH > %o |> ocamlpath.txt +: |> ^b dune build^ OCAMLRUNPARAM=b ../misc/scripts/with-tmp-dir dune build --root=boot/ --build-dir="{}" "&&" mv "{}/default/"{META.boot,lib/META} "&&" shopt -s nullglob "&&" ocamlfind install -destdir $(VARIANT_SRC)/lib boot "{}/default/lib/"{META,*.mli,*.cmi,*.cmo,*.cmx,*.cma,*.cmxa,*.a} "&&" mv "{}"/default/boot.exe %1o |> mi-boot | $(BOOT_LIB_FILES) : main/mi-lite.mc | mi-boot $(BOOT_LIB_FILES) |> ^ ./boot eval %f -- 0 %f %o^ $(STDLIB) ./%1i eval %f -- 0 %f %o |> mi-lite : main/mi.mc | mi-lite $(BOOT_LIB_FILES) |> ^ ./mi-lite 1 %f %o^ $(STDLIB) ./%1i 1 %f %o |> mi1 diff --git a/src/stdlib/parser/breakable-helper.mc b/src/stdlib/parser/breakable-helper.mc deleted file mode 100644 index eb946d462..000000000 --- a/src/stdlib/parser/breakable-helper.mc +++ /dev/null @@ -1,1049 +0,0 @@ -include "breakable.mc" - -type AllowSet id -con AllowSet : all id. Map id () -> AllowSet id -con DisallowSet : all id. Map id () -> AllowSet id - -let _isWhitelist - : AllowSet id -> Bool - = lam a. match a with AllowSet _ then true else false - -type BreakableProduction prodLabel -con BreakableAtom : all prodLabel. - { label : prodLabel - } -> BreakableProduction prodLabel -con BreakableInfix : all prodLabel. - { label : prodLabel - , leftAllow : AllowSet prodLabel - , rightAllow : AllowSet prodLabel - } -> BreakableProduction prodLabel -con BreakablePrefix : all prodLabel. - { label : prodLabel - , rightAllow : AllowSet prodLabel - } -> BreakableProduction prodLabel -con BreakablePostfix : all prodLabel. - { label : prodLabel - , leftAllow : AllowSet prodLabel - } -> BreakableProduction prodLabel - -type OpGrouping = {mayGroupLeft : Bool, mayGroupRight : Bool} - -type BreakableGrammar prodLabel = - { productions : [BreakableProduction prodLabel] - , precedences : [((prodLabel, prodLabel), OpGrouping)] - , topAllowed : AllowSet prodLabel - } - --- Each operator is uniquely identifiable by its ID, which is used to --- look up precedence and the like -type OpId = Int - -type BreakableInput lstyle rstyle -con AtomI : - { id : OpId - , allowedTop : Bool - } -> BreakableInput LClosed RClosed -con InfixI : - { id : OpId - , allowedTop : Bool - , leftAllow : AllowSet OpId - , rightAllow : AllowSet OpId - , precWhenThisIsRight : Map OpId OpGrouping - } -> BreakableInput LOpen ROpen -con PrefixI : - { id : OpId - , allowedTop : Bool - , rightAllow : AllowSet OpId - } -> BreakableInput LClosed ROpen -con PostfixI : - { id : OpId - , allowedTop : Bool - , leftAllow : AllowSet OpId - , precWhenThisIsRight : Map OpId OpGrouping - } -> BreakableInput LOpen RClosed - --- This describes a generated breakable grammar that is ready for parsing with -type BreakableGenGrammar prodLabel = - { atoms : Map prodLabel (BreakableInput LClosed RClosed) - , prefixes : Map prodLabel (BreakableInput LClosed ROpen) - , infixes : Map prodLabel (BreakableInput LOpen ROpen) - , postfixes : Map prodLabel (BreakableInput LOpen RClosed) - } - -let _eqOpId : OpId -> OpId -> Bool = eqi -let _cmpOpId : OpId -> OpId -> Int = subi -let _rootID : OpId = negi 1 -let _firstOpId : OpId = 0 -let _nextOpId : OpId -> OpId = addi 1 - -let _opIdI - : all lstyle. all rstyle. BrekableInput lstyle rstyle - -> OpId - = lam input. - switch input - case AtomI x then x.id - case InfixI x then x.id - case PrefixI x then x.id - case PostfixI x then x.id - end -let _allowedTopI - : BreakableInput lstyle rstyle - -> Bool - = lam input. - switch input - case AtomI x then x.allowedTop - case InfixI x then x.allowedTop - case PrefixI x then x.allowedTop - case PostfixI x then x.allowedTop - end -let _allowedLeftI - : BreakableInput lstyle rstyle - -> AllowSet OpId - = lam input. - switch input - case InfixI x then x.leftAllow - case PostfixI x then x.leftAllow - case _ then AllowSet (mapEmpty _cmpOpId) - end -let _allowedRightI - : BreakableInput lstyle rstyle - -> AllowSet OpId - = lam input. - switch input - case InfixI x then x.rightAllow - case PrefixI x then x.rightAllow - case _ then AllowSet (mapEmpty _cmpOpId) - end - -let breakableInAllowSet - : id - -> AllowSet id - -> Bool - = lam id. lam set. - match set with AllowSet s then mapMem id s else - match set with DisallowSet s then not (mapMem id s) else - never - -let breakableInsertAllowSet - : id - -> AllowSet id - -> AllowSet id - = lam id. lam set. - match set with AllowSet s then AllowSet (mapInsert id () s) else - match set with DisallowSet s then DisallowSet (mapRemove id s) else - never - -let breakableRemoveAllowSet - : id - -> AllowSet id - -> AllowSet id - = lam id. lam set. - match set with AllowSet s then AllowSet (mapRemove id s) else - match set with DisallowSet s then DisallowSet (mapInsert id () s) else - never - -let breakableMapAllowSet - : (a -> b) - -> (b -> b -> Int) - -> AllowSet a - -> AllowSet b - = lam f. lam newCmp. lam s. - let convert = lam s. mapFromSeq newCmp (map (lam x: (a, ()). (f x.0, ())) (mapBindings s)) in - match s with AllowSet s then AllowSet (convert s) else - match s with DisallowSet s then DisallowSet (convert s) else - never - -let breakableGenGrammar - : (prodLabel -> prodLabel -> Int) - -> BreakableGrammar prodLabel - -> BreakableGenGrammar prodLabel - = lam cmp. lam grammar. - let nOpId : Ref OpId = ref _firstOpId in - let newOpId : () -> OpId = lam. - let res = deref nOpId in - modref nOpId (_nextOpId res); - res in - - let label - : BreakableProduction prodLabel - -> prodLabel - = lam prod. - match prod with BreakableAtom {label = label} then label else - match prod with BreakablePrefix {label = label} then label else - match prod with BreakableInfix {label = label} then label else - match prod with BreakablePostfix {label = label} then label else - never - in - - let prodLabelToOpId : Map prodLabel OpId = - mapFromSeq cmp (map (lam prod. (label prod, newOpId ())) grammar.productions) in - let toOpId : prodLabel -> OpId = lam label. mapFindExn label prodLabelToOpId in - - -- TODO(vipa, 2021-02-15): This map can contain more entries than - -- required; the inner map should only ever have entries where the - -- key represents a right-open operator, but we here retain all - -- operators from the outside, which could have more (redundant) - -- entries - let groupingByRightOp : Map OpId (Map OpId OpGrouping) = - foldl - (lam acc. lam grouping. - match grouping with ((lplab, rplab), grouping) then - let lid = toOpId lplab in - let rid = toOpId rplab in - let prev = match mapLookup rid acc - with Some prev then prev - else mapEmpty _cmpOpId in - mapInsert rid (mapInsert lid grouping prev) acc - else never) - (mapEmpty _cmpOpId) - grammar.precedences - in - let getGroupingByRight : OpId -> Map OpId OpGrouping = lam opid. - match mapLookup opid groupingByRightOp with Some res then res - else mapEmpty _cmpOpId - in - - let atoms : Ref [(prodLabel, BreakableInput LClosed RClosed)] = ref [] in - let prefixes : Ref [(prodLabel, BreakableInput LClosed ROpen)] = ref [] in - let infixes : Ref [(prodLabel, BreakableInput LOpen ROpen)] = ref [] in - let postfixes : Ref [(prodLabel, BreakableInput LOpen RClosed)] = ref [] in - let updateRef : Ref a -> (a -> a) -> () - = lam ref. lam f. modref ref (f (deref ref)) in - - let isTopAllowed = - let topAllowed = breakableMapAllowSet toOpId _cmpOpId grammar.topAllowed in - lam id. breakableInAllowSet id topAllowed in - - for_ grammar.productions - (lam prod. - let label = label prod in - let id = toOpId label in - match prod with BreakableAtom _ then - updateRef atoms (cons (label, AtomI {id = id, allowedTop = isTopAllowed id})) - else match prod with BreakablePrefix {rightAllow = r} then - let r = breakableMapAllowSet toOpId _cmpOpId r in - updateRef prefixes (cons (label, PrefixI {id = id, allowedTop = isTopAllowed id, rightAllow = r})) - else match prod with BreakableInfix {leftAllow = l, rightAllow = r} then - let l = breakableMapAllowSet toOpId _cmpOpId l in - let r = breakableMapAllowSet toOpId _cmpOpId r in - let p = getGroupingByRight id in - updateRef infixes (cons (label, InfixI {id = id, allowedTop = isTopAllowed id, leftAllow = l, rightAllow = r, precWhenThisIsRight = p})) - else match prod with BreakablePostfix {leftAllow = l} then - let l = breakableMapAllowSet toOpId _cmpOpId l in - let p = getGroupingByRight id in - updateRef postfixes (cons (label, PostfixI {id = id, allowedTop = isTopAllowed id, leftAllow = l, precWhenThisIsRight = p})) - else never); - - { atoms = mapFromSeq cmp (deref atoms) - , prefixes = mapFromSeq cmp (deref prefixes) - , infixes = mapFromSeq cmp (deref infixes) - , postfixes = mapFromSeq cmp (deref postfixes) - } - -type PairedSelf self lstyle rstyle = - { self : self lstyle rstyle - , input : BreakableInput lstyle rstyle - } - -let breakableHelperInterface - : BreakableGenGrammar prodLabel - -> BreakableInput LClosed RClosed - -> { addAtom - : BreakableInput LClosed RClosed - -> self LClosed RClosed - -> State self ROpen - -> State self RClosed - , addPrefix - : BreakableInput LClosed ROpen - -> self LClosed ROpen - -> State self ROpen - -> State self ROpen - , addInfix - : BreakableInput LOpen ROpen - -> self LOpen ROpen - -> State self RClosed - -> Option (State self ROpen) - , addPostfix - : BreakableInput LOpen RClosed - -> self LOpen RClosed - -> State self RClosed - -> Option (State self RClosed) - , finalizeParse - : State self RClosed - -> Option [PermanentNode self] - , reportAmbiguities - : { toTok : all lstyle. all rstyle. Important -> self lstyle rstyle -> [tokish] - , leftPos : all rstyle. self LClosed rstyle -> pos - , rightPos : all lstyle. self lstyle RClosed -> pos - , lpar : tokish - , rpar : tokish } - -> [PermanentNode self] -- NonEmpty - -> [Ambiguity pos tokish] - , constructSimple - : { constructAtom : self LClosed RClosed -> res - , constructInfix : self LOpen ROpen -> res -> res -> res - , constructPrefix : self LClosed ROpen -> res -> res - , constructPostfix : self LOpen RClosed -> res -> res - } - -> [PermanentNode self] -- NonEmpty - -> res - } - = lam gen. lam parInput. - let parId = _opIdI parInput in - let config: Config (PairedSelf self) = - { topAllowed = lam ps: PairedSelf self lstyle rstyle. _allowedTopI ps.input - , leftAllowed = lam x: {parent: PairedSelf self LOpen rstyle, child: PairedSelf self lstyle rstyle2}. breakableInAllowSet (_opIdI x.child.input) (_allowedLeftI x.parent.input) - , rightAllowed = lam x: {parent: PairedSelf self lstyle ROpen, child: PairedSelf self lstyle2 rstyle}. breakableInAllowSet (_opIdI x.child.input) (_allowedRightI x.parent.input) - , parenAllowed = lam x: PairedSelf self lstyle rstyle. - let l = breakableInAllowSet parId (_allowedLeftI x.input) in - let r = breakableInAllowSet parId (_allowedRightI x.input) in - switch (l, r) - case (true, true) then GEither () - case (true, false) then GLeft () - case (false, true) then GRight () - case (false, false) then GNeither () - end - , groupingsAllowed = lam pair: (PairedSelf self lstyle ROpen, PairedSelf self LOpen rstyle). - let map = switch pair .1 .input - case InfixI x then x.precWhenThisIsRight - case PostfixI x then x.precWhenThisIsRight - end in - match mapLookup (_opIdI pair .0 .input) map with Some g then - let g: OpGrouping = g in - switch g - case {mayGroupLeft = true, mayGroupRight = true} then GEither () - case {mayGroupLeft = true, mayGroupRight = false} then GLeft () - case {mayGroupLeft = false, mayGroupRight = true} then GRight () - case {mayGroupLeft = false, mayGroupRight = false} then GNeither () - end - else GEither () - } in - { addAtom = lam input. lam self. lam state. breakableAddAtom config {self = self, input = input} state - , addInfix = lam input. lam self. lam state. breakableAddInfix config {self = self, input = input} state - , addPrefix = lam input. lam self. lam state. breakableAddPrefix config {self = self, input = input} state - , addPostfix = lam input. lam self. lam state. breakableAddPostfix config {self = self, input = input} state - , finalizeParse = lam state. breakableFinalizeParse config state - , reportAmbiguities = - lam reportConfig - : { toTok : all lstyle. all rstyle. Important -> self lstyle rstyle -> [tokish] - , leftPos : all rstyle. self LClosed rstyle -> pos - , rightPos : all lstyle. self lstyle RClosed -> pos - , lpar : tokish - , rpar : tokish }. - let reportConfig = - { topAllowed = config.topAllowed - , parenAllowed = config.parenAllowed - , toTok = lam important. lam self: PairedSelf self lstyle rstyle. reportConfig.toTok important self.self - , leftPos = lam self: PairedSelf self LClosed rstyle. reportConfig.leftPos self.self - , rightPos = lam self: PairedSelf self lstyle RClosed. reportConfig.rightPos self.self - , lpar = reportConfig.lpar - , rpar = reportConfig.rpar - } - in breakableReportAmbiguities reportConfig - , constructSimple = - lam config - : { constructAtom : self LClosed RClosed -> res - , constructInfix : self LOpen ROpen -> res -> res -> res - , constructPrefix : self LClosed ROpen -> res -> res - , constructPostfix : self LOpen RClosed -> res -> res }. - let config = - { constructAtom = lam self: PairedSelf self LClosed RClosed. config.constructAtom self.self - , constructInfix = lam self: PairedSelf self LOpen ROpen. config.constructInfix self.self - , constructPrefix = lam self: PairedSelf self LClosed ROpen. config.constructPrefix self.self - , constructPostfix = lam self: PairedSelf self LOpen RClosed. config.constructPostfix self.self - } - in breakableConstructSimple config - } - -mexpr - -type Ast in -con IntA : {pos: Int, val: Int} -> Ast in -con PlusA : {pos: Int, l: Ast, r: Ast} -> Ast in -con TimesA : {pos: Int, l: Ast, r: Ast} -> Ast in -con DivideA : {pos: Int, l: Ast, r: Ast} -> Ast in -con NegateA : {pos: Int, r: Ast} -> Ast in -con IfA : {pos: Int, r: Ast} -> Ast in -con ElseA : {pos: Int, l: Ast, r: Ast} -> Ast in -con NonZeroA : {pos: Int, l: Ast} -> Ast in -con ParA : {pos: Int} -> Ast in - -type Self lopen ropen = {pos: Int, val: Int, str: String} in - -let allowAllBut = lam xs. DisallowSet (mapFromSeq cmpString (map (lam x. (x, ())) xs)) in -let allowAll = allowAllBut [] in -let allowOnly = lam xs. AllowSet (mapFromSeq cmpString (map (lam x. (x, ())) xs)) in - -let highLowPrec - : [prodLabel] - -> [prodLabel] - -> [((prodLabel, prodLabel), OpGrouping)] - = - let mkGrouping = lam high. lam low. - [ ((high, low), {mayGroupLeft = true, mayGroupRight = false}) - , ((low, high), {mayGroupLeft = false, mayGroupRight = true}) - ] in - lam high. lam low. join (seqLiftA2 mkGrouping high low) -in - -recursive let precTableNoEq - : [[prodLabel]] - -> [((prodLabel, prodLabel), OpGrouping)] - = lam table. - match table with [high] ++ lows then - concat (highLowPrec high (join lows)) (precTableNoEq lows) - else [] -in - -type Self a b = {val : Int, pos : Int, str : String} in - -type TestToken in -con TestAtom : { x : Self RClosed RClosed, input : BreakableInput RClosed RClosed } -> TestToken in -con TestPrefix : { x : Self RClosed ROpen, input : BreakableInput RClosed ROpen } -> TestToken in -con TestInfix : { x : Self ROpen ROpen, input : BreakableInput ROpen ROpen } -> TestToken in -con TestPostfix : { x : Self ROpen RClosed, input : BreakableInput ROpen RClosed } -> TestToken in - -let selfToTok : Important -> Self a b -> [(Bool, String)] = lam important. lam x. [(match important with Important _ then true else false, x.str)] in - -type ParseResult in -con PSuccess : Ast -> ParseResult in -con PFail : () -> ParseResult in -con PAmbiguities : [Ambiguity Self (Bool, String)] -> ParseResult in - -let constructAtom - : Self LClosed RClosed -> Ast - = lam self. IntA {pos = self.pos, val = self.val} in -let constructInfix - : Self LOpen ROpen -> Ast -> Ast -> Ast - = lam self. lam l. lam r. - switch self.str - case "+" then PlusA {pos = self.pos, l = l, r = r} - case "*" then TimesA {pos = self.pos, l = l, r = r} - case "/" then DivideA {pos = self.pos, l = l, r = r} - case "else" then ElseA {pos = self.pos, l = l, r = r} - end in -let constructPrefix - : Self LClosed ROpen -> Ast -> Ast - = lam self. lam r. - switch self.str - case "-" then NegateA {pos = self.pos, r = r} - case "if" then IfA {pos = self.pos, r = r} - end in -let constructPostfix - : Self LOpen RClosed -> Ast -> Ast - = lam self. lam l. - switch self.str - case "?" then NonZeroA {pos = self.pos, l = l} - end in - -let testParse - : BreakableGenGrammar String - -> [Int -> TestToken] - -> ParseResult - = lam gen. - let parInput = mapFindExn "par" gen.atoms in - match breakableHelperInterface gen parInput - with {addAtom = addAtom, addPrefix = addPrefix, addInfix = addInfix, addPostfix = addPostfix, finalizeParse = finalizeParse, reportAmbiguities = reportAmbiguities, constructSimple = constructSimple} in - recursive - let workROpen = lam pos. lam st. lam tokens. - match tokens with [t] ++ tokens then - let t = t pos in - let pos = addi 1 pos in - match t with TestAtom {x = self, input = input} then - workRClosed pos (addAtom input self st) tokens - else match t with TestPrefix {x = self, input = input} then - workROpen pos (addPrefix input self st) tokens - else PFail () - else PFail () - let workRClosed = lam pos. lam st. lam tokens. - match tokens with [t] ++ tokens then - let t = t pos in - let pos = addi 1 pos in - match t with TestInfix {x = self, input = input} then - match addInfix input self st with Some st - then workROpen pos st tokens - else PFail () - else match t with TestPostfix {x = self, input = input} then - match addPostfix input self st with Some st - then workRClosed pos st tokens - else PFail () - else PFail () - else match finalizeParse st with Some tops then - let reportConfig = - { toTok = selfToTok - , leftPos = lam s: Self LClosed rstyle. s.pos - , rightPos = lam s: Self lstyle RClosed. s.pos - , lpar = (true, "(") - , rpar = (true, ")") - } in - let constructConfig = - { constructAtom = constructAtom - , constructInfix = constructInfix - , constructPrefix = constructPrefix - , constructPostfix = constructPostfix - } in - match reportAmbiguities reportConfig tops with ambs & [_] ++ _ then - PAmbiguities ambs - else PSuccess (constructSimple constructConfig tops) - else PFail () - in workROpen 0 (breakableInitState ()) -in - --- TODO(vipa, 2022-02-14): Code generation doesn't see the need to --- generate a function that compares (Bool, String), even though --- they're used and known later in this file, thus this utest is here --- to make the requirement explicit until the bug is fixed. --- See: https://github.com/miking-lang/miking/issues/542 -utest (true, "foo") with (true, "foo") in - -let i : String -> (Bool, String) = lam x. (true, x) in -let u : String -> (Bool, String) = lam x. (false, x) in - -let grammar = - { productions = - [ BreakableAtom {label = "int"} - , BreakableAtom {label = "par"} - , BreakableInfix - { label = "plus" - , leftAllow = allowAll - , rightAllow = allowAll - } - , BreakableInfix - { label = "times" - , leftAllow = allowAll - , rightAllow = allowAll - } - , BreakableInfix - { label = "divide" - , leftAllow = allowAll - , rightAllow = allowAll - } - , BreakablePrefix - { label = "negate" - , rightAllow = allowAll - } - , BreakablePrefix - { label = "if" - , rightAllow = allowAll - } - , BreakableInfix - { label = "else" - , leftAllow = allowOnly ["if"] - , rightAllow = allowAll - } - , BreakablePostfix - { label = "nonZero" - , leftAllow = allowAll - } - ] - , precedences = join - [ precTableNoEq - [ ["negate"] - , ["times", "divide"] - , ["plus"] - , ["if"] - ] - ] - , topAllowed = allowAll - } -in -let genned: BreakableGenGrammar a b c = breakableGenGrammar cmpString grammar in -let atom = lam label. mapFindExn label genned.atoms in -let prefix = lam label. mapFindExn label genned.prefixes in -let infix = lam label. mapFindExn label genned.infixes in -let postfix = lam label. mapFindExn label genned.postfixes in - -let _int = - let input = atom "int" in - lam val. lam pos. TestAtom {x = {val = val, pos = pos, str = int2string val}, input = input} in -let _plus = - let input = infix "plus" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "+"}, input = input} in -let _times = - let input = infix "times" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "*"}, input = input} in -let _divide = - let input = infix "divide" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "/"}, input = input} in -let _negate = - let input = prefix "negate" in - lam pos. TestPrefix {x = {val = 0, pos = pos, str = "-"}, input = input} in -let _if = - let input = prefix "if" in - lam pos. TestPrefix {x = {val = 0, pos = pos, str = "if"}, input = input} in -let _else = - let input = infix "else" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "else"}, input = input} in -let _nonZero = - let input = postfix "nonZero" in - lam pos. TestPostfix {x = {val = 0, pos = pos, str = "?"}, input = input} in - -let test = testParse genned in - -utest test [] -with PFail () -in - -utest test [_int 4] -with PSuccess (IntA {val = 4,pos = 0}) -in - -utest test [_int 4, _plus] -with PFail () -in - -utest test [_int 4, _plus, _int 7] -with PSuccess - (PlusA - { pos = 1 - , l = (IntA {val = 4,pos = 0}) - , r = (IntA {val = 7,pos = 2}) - }) -in - -utest test [_negate, _int 8] -with PSuccess - (NegateA - { pos = 0 - , r = (IntA {val = 8,pos = 1}) - }) -in - -utest test [_negate, _negate, _int 8] -with PSuccess - (NegateA - { pos = 0 - , r = (NegateA - { pos = 1 - , r = (IntA {val = 8,pos = 2}) - }) - }) -in - -utest test [_int 9, _nonZero, _nonZero] -with PSuccess - (NonZeroA - { pos = 2 - , l = (NonZeroA - { pos = 1 - , l = (IntA {val = 9,pos = 0})}) - }) -in - -utest test [_negate, _nonZero] -with PFail () -in - -utest test [_int 1, _plus, _int 2, _times, _int 3] -with PSuccess - (PlusA - { pos = 1 - , l = (IntA {val = 1,pos = 0}) - , r = (TimesA - { pos = 3 - , l = (IntA {val = 2,pos = 2}) - , r = (IntA {val = 3,pos = 4}) - }) - }) -in - -utest test [_int 1, _times, _int 2, _plus, _int 3] -with PSuccess - (PlusA - { pos = 3 - , l = (TimesA - { pos = 1 - , l = (IntA {val = 1,pos = 0}) - , r = (IntA {val = 2,pos = 2}) - }) - , r = (IntA {val = 3,pos = 4}) - }) -in - -utest test [_int 1, _times, _int 2, _divide, _int 3] -with PAmbiguities ( - [ { range = - { first = 0 - , last = 4 - } - , partialResolutions = - [ [u"1", i"*", i"(", u"2", i"/", u"3", i")"] - , [i"(", u"1", i"*", u"2", i")", i"/", u"3"] - ] - } - ]) -in - -utest test [_int 1, _times, _int 2, _divide, _int 3, _plus, _int 4] -with PAmbiguities ( - [ { range = - { first = 0 - , last = 4 - } - , partialResolutions = - [ [u"1",i"*",i"(",u"2",i"/",u"3",i")"] - , [i"(",u"1",i"*",u"2",i")",i"/",u"3"] - ] - } - ]) -in - -utest test [_int 0, _plus, _int 1, _times, _int 2, _divide, _int 3] -with PAmbiguities ( - [ { range = - { first = 2 - , last = 6 } - , partialResolutions = - [ [u"1",i"*",i"(",u"2",i"/",u"3",i")"] - , [i"(",u"1",i"*",u"2",i")",i"/",u"3"] - ] - } - ]) -in - --- TODO(vipa, 2021-02-15): When we compute elisons we can report two ambiguities here, the nested one is independent -utest test [_int 0, _plus, _int 1, _times, _int 2, _divide, _int 3, _plus, _int 4] -with PAmbiguities ( - [ { range = - { first = 0 - , last = 8 - } - , partialResolutions = - [ [u"0",i"+",i"(",u"1",u"*",u"2",u"/",u"3",i"+",u"4",i")"] - , [i"(",u"0",i"+",u"1",u"*",u"2",u"/",u"3",i")",i"+",u"4"] - ] - } - ]) -in - --- TODO(vipa, 2021-02-15): Do we want to specify the order of the returned ambiguities in some way? -utest test [_int 1, _times, _int 2, _divide, _int 3, _plus, _int 4, _divide, _int 5, _times, _int 6] -with PAmbiguities ( - [ { range = - { first = 6 - , last = 10 - } - , partialResolutions = - [ [u"4",i"/",i"(",u"5",i"*",u"6",i")"] - , [i"(",u"4",i"/",u"5",i")",i"*",u"6"] - ] - } - , { range = - { first = 0 - , last = 4 - } - , partialResolutions = - [ [u"1",i"*",i"(",u"2",i"/",u"3",i")"] - , [i"(",u"1",i"*",u"2",i")",i"/",u"3"] - ] - } - ]) -in - -utest test [_if, _int 1] -with PSuccess - (IfA - { pos = 0 - , r = (IntA {val = 1,pos = 1}) - }) -in - -utest test [_if, _int 1, _else, _int 2] -with PSuccess - (ElseA - { pos = 2 - , l = (IfA - { pos = 0 - , r = (IntA {val = 1,pos = 1}) - }) - , r = (IntA {val = 2,pos = 3}) - }) - -in - -utest test [_if, _int 1, _else, _int 2, _else, _int 3] -with PFail () -in - -utest test [_if, _if, _int 1, _else, _int 2] -with PAmbiguities ( - [ { range = - { first = 0 - , last = 4 - } - , partialResolutions = - [ [i"if",i"(",i"if",u"1",i"else",u"2",i")"] - , [i"if",i"(",i"if",u"1",i")",i"else",u"2"] - ] - } - ]) -in - -utest test [_negate, _if, _int 1, _else, _int 2] -with PSuccess - (NegateA - { pos = 0 - , r = (ElseA - { pos = 3 - , l = (IfA - { pos = 1 - , r = (IntA {val = 1,pos = 2}) - }) - , r = (IntA {val = 2,pos = 4}) - }) - }) -in - -utest test [_if, _negate, _if, _int 1, _else, _int 2] -with PAmbiguities ( - [ { range = - { first = 0 - , last = 5 - } - , partialResolutions = - [ [i"if",i"(",u"-",i"if",u"1",i"else",u"2",i")"] - , [i"if",i"(",u"-",i"if",u"1",i")",i"else",u"2"] - ] - } - ]) -in - -utest test [_int 1, _plus, _if, _negate, _if, _int 1, _else, _int 2] -with PAmbiguities ( - [ { range = - { first = 2 - , last = 7 - } - , partialResolutions = - [ [i"if",i"(",u"-",i"if",u"1",i"else",u"2",i")"] - , [i"if",i"(",u"-",i"if",u"1",i")",i"else",u"2"] - ] - } - ]) -in - -utest test [_int 1, _times, _if, _int 7, _else, _int 12] -with PSuccess - (TimesA - { pos = 1 - , l = (IntA {val = 1,pos = 0}) - , r = (ElseA - { pos = 4 - , l = (IfA - { pos = 2 - , r = (IntA {val = 7,pos = 3}) - }) - , r = (IntA {val = 12,pos = 5}) - }) - }) -in - -utest test [_int 7, _else, _int 12] -with PFail () -in - -utest test [_int 1, _plus, _plus, _int 2] -with PFail () -in - -utest test [_int 1, _plus, _nonZero] -with PFail () -in - -utest test [_int 1, _nonZero, _plus, _int 2] -with PSuccess - (PlusA - { pos = 2 - , l = (NonZeroA - { pos = 1 - , l = (IntA {val = 1,pos = 0}) - }) - , r = (IntA {val = 2,pos = 3}) - }) -in - -let grammar = - { productions = - [ BreakableAtom {label = "int"} - , BreakableAtom {label = "par"} - , BreakableInfix - { label = "plus" - , leftAllow = allowAllBut ["else"] - , rightAllow = allowAllBut ["else"] - } - , BreakableInfix - { label = "times" - , leftAllow = allowAllBut ["else"] - , rightAllow = allowAllBut ["else"] - } - , BreakableInfix - { label = "divide" - , leftAllow = allowAllBut ["else"] - , rightAllow = allowAllBut ["else"] - } - , BreakablePrefix - { label = "negate" - , rightAllow = allowAllBut ["else"] - } - , BreakablePrefix - { label = "if" - , rightAllow = allowAll - } - , BreakableInfix - { label = "else" - , leftAllow = allowAllBut ["else"] - , rightAllow = allowAllBut ["else"] - } - , BreakablePostfix - { label = "nonZero" - , leftAllow = allowAllBut ["else"] - } - ] - , precedences = join - [ precTableNoEq - [ ["negate"] - , ["times", "divide"] - , ["plus"] - , ["if"] - ] - ] - , topAllowed = allowAllBut ["else"] - } -in - -let genned: BreakableGenGrammar a b c = breakableGenGrammar cmpString grammar in -let atom = lam label. mapFindExn label genned.atoms in -let prefix = lam label. mapFindExn label genned.prefixes in -let infix = lam label. mapFindExn label genned.infixes in -let postfix = lam label. mapFindExn label genned.postfixes in - -let _int = - let input = atom "int" in - lam val. lam pos. TestAtom {x = {val = val, pos = pos, str = int2string val}, input = input} in -let _plus = - let input = infix "plus" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "+"}, input = input} in -let _times = - let input = infix "times" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "*"}, input = input} in -let _divide = - let input = infix "divide" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "/"}, input = input} in -let _negate = - let input = prefix "negate" in - lam pos. TestPrefix {x = {val = 0, pos = pos, str = "-"}, input = input} in -let _if = - let input = prefix "if" in - lam pos. TestPrefix {x = {val = 0, pos = pos, str = "if"}, input = input} in -let _else = - let input = infix "else" in - lam pos. TestInfix {x = {val = 0, pos = pos, str = "else"}, input = input} in -let _nonZero = - let input = postfix "nonZero" in - lam pos. TestPostfix {x = {val = 0, pos = pos, str = "?"}, input = input} in - -let test = testParse genned in - -utest test [_if, _int 1] -with PSuccess - (IfA - { pos = 0 - , r = (IntA {val = 1,pos = 1}) - }) -in - -utest test [_if, _int 1, _else, _int 2] -with PSuccess - (IfA - { pos = 0 - , r = (ElseA - { pos = 2 - , l = (IntA {val = 1,pos = 1}) - , r = (IntA {val = 2,pos = 3}) - }) - }) - -in - -utest test [_if, _int 1, _else, _int 2, _else, _int 3] -with PFail () -in - -utest test [_if, _if, _int 1, _else, _int 2] -with PAmbiguities ( - [ { range = - { first = 0 - , last = 4 - } - , partialResolutions = - [ [i"if",i"(",i"if",u"1",i")",i"else",u"2"] - , [i"if",i"(",i"if",u"1",i"else",u"2",i")"] - ] - } - ]) -in - -utest test [_negate, _if, _int 1, _else, _int 2] -with PSuccess - (NegateA - { pos = 0 - , r = (IfA - { pos = 1 - , r = (ElseA - { pos = 3 - , l = (IntA {val = 1,pos = 2}) - , r = (IntA {val = 2,pos = 4}) - }) - }) - }) -in - -utest test [_if, _negate, _if, _int 1, _else, _int 2] -with PAmbiguities ( - [ { range = - { first = 0 - , last = 5 - } - , partialResolutions = - [ [i"if",i"(",u"-",i"if",u"1",i")",i"else",u"2"] - , [i"if",i"(",u"-",i"if",u"1",i"else",u"2",i")"] - ] - } - ]) -in - -utest test [_int 1, _plus, _if, _negate, _if, _int 1, _else, _int 2] -with PAmbiguities ( - [ { range = - { first = 2 - , last = 7 - } - , partialResolutions = - [ [i"if",i"(",u"-",i"if",u"1",i")",i"else",u"2"] - , [i"if",i"(",u"-",i"if",u"1",i"else",u"2",i")"] - ] - } - ]) -in - -utest test [_int 1, _times, _if, _int 7, _else, _int 12] -with PSuccess - (TimesA - { pos = 1 - , l = (IntA {val = 1,pos = 0}) - , r = (IfA - { pos = 2 - , r = (ElseA - { pos = 4 - , l = (IntA {val = 7,pos = 3}) - , r = (IntA {val = 12,pos = 5}) - }) - }) - }) -in - -utest test [_int 7, _else, _int 12] -with PFail () -in - -()