├── .gitignore ├── test ├── snapshots │ ├── test.cmds │ ├── test.sml │ ├── append.sml │ ├── curried_app.cmds │ ├── simple_app.cmds │ ├── simple_app.sml │ ├── curried_app.sml │ ├── no_pause_currying.sml │ ├── foldr.cmds │ ├── lem.cmds │ ├── foldr.sml │ ├── infix_printing.sml │ ├── no_pause_currying.cmds │ ├── div_exn.sml │ ├── infix_printing.cmds │ ├── append.cmds │ ├── test.trace │ ├── append.trace │ ├── lem.sml │ ├── simple_app.trace │ ├── curried_app.trace │ ├── no_pause_currying.trace │ ├── div_exn.cmds │ ├── foldr.trace │ ├── lem.trace │ ├── infix_printing.trace │ └── div_exn.trace ├── sources.mlb └── snapshots.sml ├── src ├── .DS_Store ├── cm_parser │ ├── syntax │ │ ├── sources.mlb │ │ └── token.sml │ ├── sources.mlb │ ├── lex │ │ ├── sources.mlb │ │ ├── lexer.cmlex │ │ └── lexer.sml │ └── parse │ │ ├── sources.mlb │ │ ├── parser.cmyacc │ │ ├── parser.sml │ │ └── parser.fun ├── directive_parser │ ├── sources.mlb │ ├── lex │ │ ├── sources.mlb │ │ ├── lexer.cmlex │ │ ├── token.sml │ │ ├── lexer.sml │ │ └── lexer.fun │ └── parse │ │ ├── sources.mlb │ │ ├── directive.sml │ │ ├── parser.cmyacc │ │ ├── parser.sml │ │ └── parser.fun ├── debugger │ └── sources.mlb ├── pretty-print │ └── sources.mlb ├── statics │ ├── sources.mlb │ ├── examples.sml │ ├── common.sml │ └── collect_tyvars.sml ├── top │ ├── sources.mlb │ └── top.sml ├── context │ ├── sources.mlb │ ├── PrettyPrintContext.sml │ ├── location.sml │ └── binding.sml ├── util │ ├── either.sml │ ├── sources.mlb │ ├── io.sml │ ├── fresh_sym.sml │ ├── common.sml │ ├── ref.sml │ ├── cont.sml │ ├── ids.sml │ ├── printf.sml │ ├── ListUtils.sml │ ├── pervasive.sml │ ├── TerminalColors.sml │ ├── PrettySimpleDoc.sml │ ├── test_framework.sml │ └── error.sml ├── syntax │ ├── sources.mlb │ └── sml_syntax_helpers.sml ├── test2.sml └── run │ └── sources.mlb ├── .vscode └── settings.json ├── .gitmodules ├── millet.toml ├── todo.txt ├── .github └── workflows │ ├── tests.yml │ ├── build-osx.yml │ └── build-linux.yml ├── Makefile ├── LICENSE ├── notes.txt └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | mulligan 2 | -------------------------------------------------------------------------------- /test/snapshots/test.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step -------------------------------------------------------------------------------- /test/snapshots/test.sml: -------------------------------------------------------------------------------- 1 | val x = 2 2 | -------------------------------------------------------------------------------- /test/snapshots/append.sml: -------------------------------------------------------------------------------- 1 | val _ = [1, 2] @ [3, 4] -------------------------------------------------------------------------------- /test/snapshots/curried_app.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step 3 | step 4 | step -------------------------------------------------------------------------------- /test/snapshots/simple_app.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step 3 | step 4 | step -------------------------------------------------------------------------------- /src/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brandonspark/mulligan/HEAD/src/.DS_Store -------------------------------------------------------------------------------- /test/snapshots/simple_app.sml: -------------------------------------------------------------------------------- 1 | 2 | val _ = (fn x => 3) 2 3 | 4 | val _ = "done" 5 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "millet.server.diagnostics.moreInfoHint.enable": false 3 | } 4 | -------------------------------------------------------------------------------- /test/snapshots/curried_app.sml: -------------------------------------------------------------------------------- 1 | 2 | val _ = (fn x => fn y => 3) 2 4 3 | 4 | val _ = "done" 5 | -------------------------------------------------------------------------------- /test/snapshots/no_pause_currying.sml: -------------------------------------------------------------------------------- 1 | 2 | val _ = (fn x => fn y => 3) 2 4 3 | 4 | val _ = "done" 5 | -------------------------------------------------------------------------------- /src/cm_parser/syntax/sources.mlb: -------------------------------------------------------------------------------- 1 | local 2 | ../../util/sources.mlb 3 | 4 | token.sml 5 | in 6 | structure CM_Token 7 | end 8 | -------------------------------------------------------------------------------- /src/directive_parser/sources.mlb: -------------------------------------------------------------------------------- 1 | 2 | local 3 | parse/sources.mlb 4 | in 5 | structure Directive 6 | structure DirectiveParser 7 | end 8 | -------------------------------------------------------------------------------- /src/cm_parser/sources.mlb: -------------------------------------------------------------------------------- 1 | local 2 | syntax/sources.mlb 3 | parse/sources.mlb 4 | in 5 | structure CM_Token 6 | structure CM_Parser 7 | end 8 | -------------------------------------------------------------------------------- /test/snapshots/foldr.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step 3 | step 4 | step 5 | step 6 | step 7 | step 8 | step 9 | step 10 | step 11 | step 12 | step 13 | step -------------------------------------------------------------------------------- /test/snapshots/lem.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step 3 | step 4 | step 5 | step 6 | step 7 | step 8 | step 9 | step 10 | step 11 | step 12 | step 13 | step 14 | step -------------------------------------------------------------------------------- /test/snapshots/foldr.sml: -------------------------------------------------------------------------------- 1 | 2 | fun foldr f z [] = z 3 | | foldr f z (x::xs) = 4 | f (x, foldr f z xs) 5 | 6 | val _ = foldr op^ "" (["1", "5", "0"]) 7 | -------------------------------------------------------------------------------- /test/snapshots/infix_printing.sml: -------------------------------------------------------------------------------- 1 | 2 | fun foldr f z [] = z 3 | | foldr f z (x::xs) = 4 | f (x, foldr f z xs) 5 | 6 | val _ = foldr op^ "" (["H", "E", "L", "L", "O"]) 7 | -------------------------------------------------------------------------------- /src/cm_parser/lex/sources.mlb: -------------------------------------------------------------------------------- 1 | local 2 | ../../util/sources.mlb 3 | 4 | ../syntax/sources.mlb 5 | 6 | lexer.fun 7 | lexer.sml 8 | in 9 | structure CM_Lexer 10 | end 11 | -------------------------------------------------------------------------------- /test/snapshots/no_pause_currying.cmds: -------------------------------------------------------------------------------- 1 | set pause_currying = true 2 | step 3 | step 4 | step 5 | step 6 | step 7 | step 8 | step 9 | step 10 | step 11 | step 12 | step 13 | step 14 | step -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "cmlib"] 2 | path = cmlib 3 | url = https://github.com/standardml/cmlib 4 | [submodule "parse-sml"] 5 | path = parse-sml 6 | url = https://github.com/brandonspark/parse-sml.git 7 | -------------------------------------------------------------------------------- /src/cm_parser/parse/sources.mlb: -------------------------------------------------------------------------------- 1 | local 2 | ../../util/sources.mlb 3 | 4 | ../syntax/sources.mlb 5 | ../lex/sources.mlb 6 | 7 | parser.fun 8 | parser.sml 9 | in 10 | structure CM_Parser 11 | end 12 | -------------------------------------------------------------------------------- /src/debugger/sources.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | 3 | ../syntax/sources.mlb 4 | ../context/sources.mlb 5 | ../pretty-print/sources.mlb 6 | ../util/sources.mlb 7 | ../statics/sources.mlb 8 | 9 | debugger.sml 10 | -------------------------------------------------------------------------------- /test/snapshots/div_exn.sml: -------------------------------------------------------------------------------- 1 | 2 | fun f 0 = 1 div 0 3 | | f n = 1 + f (n - 1) 4 | 5 | fun g 0 = 1 mod 0 6 | | g n = 1 + g (n - 1) 7 | 8 | 9 | val _ = SOME (f 4) handle Div => NONE 10 | 11 | val _ = SOME (g 4) handle Div => NONE -------------------------------------------------------------------------------- /src/pretty-print/sources.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | 3 | local 4 | ../util/sources.mlb 5 | ../syntax/sources.mlb 6 | ../context/sources.mlb 7 | 8 | PrettyPrintAst.sml 9 | in 10 | structure PrettyPrintAst 11 | end 12 | -------------------------------------------------------------------------------- /test/sources.mlb: -------------------------------------------------------------------------------- 1 | 2 | ../src/syntax/sources.mlb 3 | ../src/context/sources.mlb 4 | ../src/run/sources.mlb 5 | ../src/pretty-print/sources.mlb 6 | ../src/directive_parser/sources.mlb 7 | ../src/util/sources.mlb 8 | 9 | snapshots.sml 10 | test.sml 11 | -------------------------------------------------------------------------------- /test/snapshots/infix_printing.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step 3 | step 4 | step 5 | step 6 | step 7 | step 8 | step 9 | step 10 | step 11 | step 12 | reveal 0 13 | reveal 1 14 | reveal 2 15 | reveal 3 16 | reveal 4 17 | reveal 5 18 | reveal 6 19 | reveal 7 20 | run -------------------------------------------------------------------------------- /src/directive_parser/lex/sources.mlb: -------------------------------------------------------------------------------- 1 | ../../util/sources.mlb 2 | 3 | local 4 | local 5 | token.sml 6 | in 7 | structure DToken = Token 8 | end 9 | 10 | lexer.fun 11 | lexer.sml 12 | in 13 | structure DToken 14 | structure Lexer 15 | end 16 | -------------------------------------------------------------------------------- /millet.toml: -------------------------------------------------------------------------------- 1 | version = 1 2 | [workspace] 3 | root = "src/top/sources.mlb" 4 | [workspace.path-vars] 5 | COMPAT = { value = "mlton" } 6 | [language] 7 | fixity-across-files = true 8 | [diagnostics] 9 | 4014.severity = "ignore" 10 | 4030.severity = "ignore" 11 | 5034.severity = "ignore" 12 | -------------------------------------------------------------------------------- /test/snapshots/append.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step 3 | step 4 | step 5 | step 6 | step 7 | step 8 | step 9 | step 10 | step 11 | step 12 | step 13 | step 14 | step 15 | step 16 | step 17 | step 18 | step 19 | step 20 | step 21 | step 22 | step 23 | step 24 | step 25 | step 26 | step 27 | step 28 | step -------------------------------------------------------------------------------- /src/statics/sources.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | 4 | ../syntax/sources.mlb 5 | ../context/sources.mlb 6 | ../util/sources.mlb 7 | ../pretty-print/sources.mlb 8 | 9 | 10 | common.sml 11 | collect_tyvars.sml 12 | statics.sml 13 | in 14 | structure Statics 15 | end 16 | -------------------------------------------------------------------------------- /test/snapshots/test.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/test.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | val x = 2 7 | 8 | - ==> 9 | val x = 2 10 | 11 | - Program evaluation finished. 12 | 13 | -------------------------------------------------------------------------------- /src/directive_parser/parse/sources.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 3 | 4 | local 5 | ../../util/sources.mlb 6 | ../lex/sources.mlb 7 | 8 | directive.sml 9 | 10 | parser.fun 11 | parser.sml 12 | in 13 | structure DToken 14 | structure Directive 15 | structure DirectiveParser 16 | end 17 | -------------------------------------------------------------------------------- /src/top/sources.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | 3 | local 4 | ../util/sources.mlb 5 | ../directive_parser/sources.mlb 6 | ../syntax/sources.mlb 7 | ../context/sources.mlb 8 | ../pretty-print/sources.mlb 9 | ../debugger/sources.mlb 10 | ../cm_parser/sources.mlb 11 | ../run/sources.mlb 12 | 13 | top.sml 14 | in 15 | structure Top 16 | end 17 | -------------------------------------------------------------------------------- /test/snapshots/append.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/append.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | val _ = [1, 2] @ [3, 4] 7 | 8 | - ==> 9 | val _ = [1, 2] @ [3, 4] 10 | 11 | - ==> 12 | val _ = [1, 2, 3, 4] 13 | 14 | - Program evaluation finished. 15 | 16 | -------------------------------------------------------------------------------- /src/statics/examples.sml: -------------------------------------------------------------------------------- 1 | 2 | (* does not compile, cannot generalize 3 | fun f x = 4 | let 5 | val y : 'a = x 6 | in 7 | x 8 | end *) 9 | 10 | (* does compile 11 | fun f (x : 'a) = 12 | let 13 | val y : 'a = x 14 | in 15 | x 16 | end *) 17 | 18 | (* does compile *) 19 | fun ('a, 'b) f x y = 20 | let 21 | val x1 = x 22 | val y1 = y 23 | in 24 | x 25 | end 26 | -------------------------------------------------------------------------------- /test/snapshots/lem.sml: -------------------------------------------------------------------------------- 1 | datatype ('a, 'b) either = INL of 'a | INR of 'b 2 | type 'a lem = ('a, 'a Cont.cont) either 3 | 4 | val lem_proof : unit -> 'a lem = 5 | fn () => 6 | Cont.callcc 7 | (fn ret => 8 | INL (Cont.callcc (fn na => 9 | Cont.throw ret (INR na) 10 | )) 11 | ) 12 | 13 | val res = 14 | case lem_proof () of 15 | INL n => n * n 16 | | INR nn => Cont.throw nn 2 17 | -------------------------------------------------------------------------------- /test/snapshots/simple_app.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/simple_app.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | val _ = (fn x => 3) 2 7 | val _ = "done" 8 | 9 | - ==> 10 | val _ = (fn x => 3) 2 11 | 12 | - ==> 13 | val _ = 3 14 | 15 | - ==> 16 | val _ = "done" 17 | 18 | - Program evaluation finished. 19 | 20 | -------------------------------------------------------------------------------- /src/context/sources.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | 3 | local 4 | ../util/sources.mlb 5 | ../syntax/sources.mlb 6 | 7 | PrettyPrintContext.sml 8 | 9 | context.sml 10 | basis.sml 11 | value.sml 12 | binding.sml 13 | 14 | location.sml 15 | in 16 | structure PrettyPrintContext 17 | 18 | structure Context 19 | structure Basis 20 | structure Value 21 | structure Binding 22 | 23 | structure Location 24 | end 25 | -------------------------------------------------------------------------------- /test/snapshots/curried_app.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/curried_app.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | val _ = (fn x => fn y => 3) 2 4 7 | val _ = "done" 8 | 9 | - ==> 10 | val _ = (fn x => fn y => 3) 2 4 11 | 12 | - ==> 13 | val _ = 3 14 | 15 | - ==> 16 | val _ = "done" 17 | 18 | - Program evaluation finished. 19 | 20 | -------------------------------------------------------------------------------- /test/snapshots/no_pause_currying.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/no_pause_currying.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | val _ = (fn x => fn y => 3) 2 4 7 | val _ = "done" 8 | 9 | - - ==> 10 | val _ = (fn x => fn y => 3) 2 4 11 | 12 | - ==> 13 | val _ = (fn y => 3) 4 14 | 15 | - ==> 16 | val _ = 3 17 | 18 | - ==> 19 | val _ = "done" 20 | 21 | - Program evaluation finished. 22 | 23 | -------------------------------------------------------------------------------- /src/statics/common.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | fun union_three s1 s2 s3 = 8 | SymSet.union 9 | (SymSet.union s1 s2) 10 | s3 11 | 12 | fun set_from_list l = 13 | List.foldl 14 | (fn (elem, acc) => 15 | SymSet.insert acc elem 16 | ) 17 | SymSet.empty 18 | l 19 | 20 | fun union_sets l = 21 | List.foldl 22 | (fn (elem, acc) => 23 | SymSet.union acc elem 24 | ) 25 | SymSet.empty 26 | l 27 | -------------------------------------------------------------------------------- /test/snapshots/div_exn.cmds: -------------------------------------------------------------------------------- 1 | step 2 | step 3 | step 4 | step 5 | step 6 | step 7 | step 8 | step 9 | step 10 | step 11 | step 12 | step 13 | step 14 | step 15 | step 16 | step 17 | step 18 | step 19 | step 20 | step 21 | step 22 | step 23 | step 24 | step 25 | step 26 | step 27 | step 28 | step 29 | step 30 | step 31 | step 32 | step 33 | step 34 | step 35 | step 36 | step 37 | step 38 | step 39 | step 40 | step 41 | step 42 | step 43 | step 44 | step 45 | step 46 | step 47 | step 48 | step 49 | step 50 | step 51 | step 52 | step 53 | step 54 | step -------------------------------------------------------------------------------- /todo.txt: -------------------------------------------------------------------------------- 1 | TODO: 2 | - make `value` and `context` types somehow no longer mutually recursive with 3 | other main SMLSyntax types 4 | * split most types in SMLSyntax into a `semantics` folder, such as tyval, 5 | type_scheme, sigval, etc 6 | - fix Ehole by coming up with a better, less hacky solution 7 | * potentially duplicate `exp` type for purely location purposes 8 | - reduce interface bloat of Context module 9 | - move to CM instead of MLton? 10 | * but, lose fixity across files? pervasives.sml? 11 | - update parse-sml version 12 | -------------------------------------------------------------------------------- /.github/workflows/tests.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | jobs: 10 | build: 11 | runs-on: ubuntu-20.04 12 | steps: 13 | - uses: actions/checkout@v3 14 | with: 15 | submodules: recursive 16 | - name: Install dependencies 17 | run: | 18 | eval "$(/home/linuxbrew/.linuxbrew/bin/brew shellenv)" 19 | brew install mlton 20 | - name: Run tests 21 | run: | 22 | eval "$(/home/linuxbrew/.linuxbrew/bin/brew shellenv)" 23 | make test 24 | -------------------------------------------------------------------------------- /.github/workflows/build-osx.yml: -------------------------------------------------------------------------------- 1 | name: build-osx 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | jobs: 10 | build: 11 | runs-on: macos-latest 12 | steps: 13 | - uses: actions/checkout@v3 14 | with: 15 | submodules: recursive 16 | - name: Install dependencies 17 | run: | 18 | brew install mlton 19 | - name: Try to compile 20 | run: | 21 | make 22 | - name: Update binary 23 | uses: actions/upload-artifact@v3 24 | with: 25 | name: mulligan-osx 26 | path: ./mulligan 27 | -------------------------------------------------------------------------------- /src/util/either.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* Just a library for an either type. 11 | *) 12 | 13 | (*****************************************************************************) 14 | (* Implementation *) 15 | (*****************************************************************************) 16 | 17 | structure Either = 18 | struct 19 | datatype ('a, 'b) t = INL of 'a | INR of 'b 20 | end 21 | -------------------------------------------------------------------------------- /src/syntax/sources.mlb: -------------------------------------------------------------------------------- 1 | ann "milletDiagnosticsIgnore all" in 2 | local 3 | ../../parse-sml/src/base/sources.mlb 4 | ../../parse-sml/src/ast/sources.mlb 5 | ../../parse-sml/src/ast/AstType.sml 6 | ../../parse-sml/src/parse/sources.mlb 7 | in 8 | structure Ast 9 | structure Seq 10 | structure Token 11 | structure MaybeLongToken 12 | end 13 | end 14 | 15 | $(SML_LIB)/basis/basis.mlb 16 | 17 | ../util/sources.mlb 18 | 19 | local 20 | sml_syntax.sml 21 | sml_syntax_helpers.sml 22 | elaborate.sml 23 | in 24 | structure SymDict 25 | structure SymSet 26 | 27 | structure SMLSyntax 28 | structure SMLSyntaxHelpers 29 | structure Elaborate 30 | end 31 | -------------------------------------------------------------------------------- /.github/workflows/build-linux.yml: -------------------------------------------------------------------------------- 1 | name: build-linux 2 | 3 | on: 4 | push: 5 | branches: [ "master" ] 6 | pull_request: 7 | branches: [ "master" ] 8 | 9 | jobs: 10 | build: 11 | runs-on: ubuntu-20.04 12 | steps: 13 | - uses: actions/checkout@v3 14 | with: 15 | submodules: recursive 16 | - name: Install dependencies 17 | run: | 18 | eval "$(/home/linuxbrew/.linuxbrew/bin/brew shellenv)" 19 | brew install mlton 20 | - name: Try to compile 21 | run: | 22 | eval "$(/home/linuxbrew/.linuxbrew/bin/brew shellenv)" 23 | make 24 | - name: Update binary 25 | uses: actions/upload-artifact@v3 26 | with: 27 | name: mulligan-linux 28 | path: ./mulligan 29 | -------------------------------------------------------------------------------- /src/test2.sml: -------------------------------------------------------------------------------- 1 | signature FOO = 2 | sig 3 | structure A : 4 | sig 5 | type t = int 6 | type t2 7 | end 8 | 9 | structure B : 10 | sig 11 | type t2 12 | type t3 13 | end 14 | 15 | structure C : 16 | sig 17 | type t = int 18 | type t3 19 | end 20 | sharing A = B = C 21 | end 22 | 23 | structure Foo : FOO = 24 | struct 25 | structure A = 26 | struct 27 | type t = int 28 | type t2 = string 29 | end 30 | 31 | structure B = 32 | struct 33 | type t2 = string 34 | type t3 = real 35 | 36 | end 37 | structure C = 38 | struct 39 | type t = int 40 | type t3 = real 41 | end 42 | end 43 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | shell = /bin/sh 2 | SOURCES = $(shell find src -iname '*.sml' -o -iname '*.mlb' -o -iname '*.sig' -o -iname '*.fun') 3 | TEST_SOURCES = $(shell find src -iname '*.sml' -o -iname '*.mlb' -o -iname '*.sig' -o -iname '*.fun') $(shell find test -iname '*.sml' -o -iname '*.mlb' -o -iname '*.sig' -o -iname '*.fun') 4 | 5 | mulligan: $(SOURCES) 6 | mlton -mlb-path-var 'COMPAT mlton' -const 'Exn.keepHistory true' -default-ann 'allowOrPats true' -output mulligan src/top/sources.mlb 7 | 8 | test: $(TEST_SOURCES) 9 | mlton -mlb-path-var 'COMPAT mlton' -const 'Exn.keepHistory true' -default-ann 'allowOrPats true' -output mulligan_test test/sources.mlb 10 | ./mulligan_test 11 | @rm -f mulligan_test 12 | 13 | 14 | .PHONY: clean test 15 | clean: 16 | rm -f mulligan 17 | rm -f mulligan_test 18 | -------------------------------------------------------------------------------- /src/run/sources.mlb: -------------------------------------------------------------------------------- 1 | $(SML_LIB)/basis/basis.mlb 2 | 3 | ann "milletDiagnosticsIgnore all" in 4 | local 5 | ../../parse-sml/src/base/sources.mlb 6 | ../../parse-sml/src/parse/sources.mlb 7 | ../../parse-sml/src/syntax-highlighting/sources.mlb 8 | in 9 | structure ParseSMLError = Error 10 | structure Parser 11 | structure FilePath 12 | structure Source 13 | structure TCS = TerminalColorString 14 | structure SyntaxHighlighter 15 | structure CommandLineArgs 16 | 17 | end 18 | 19 | local 20 | ../util/sources.mlb 21 | ../directive_parser/sources.mlb 22 | ../syntax/sources.mlb 23 | ../context/sources.mlb 24 | ../pretty-print/sources.mlb 25 | ../debugger/sources.mlb 26 | 27 | run.sml 28 | in 29 | structure Run 30 | end 31 | end 32 | -------------------------------------------------------------------------------- /src/cm_parser/parse/parser.cmyacc: -------------------------------------------------------------------------------- 1 | sml 2 | name ParserFun 3 | 4 | terminal ELEM of elem 5 | 6 | terminal LIBRARY 7 | terminal GROUP 8 | terminal STRUCTURE 9 | terminal SIGNATURE 10 | terminal FUNCTOR 11 | terminal IDENT of symbol 12 | terminal IS 13 | 14 | terminal EOF 15 | 16 | nonterminal Files : files = 17 | EOF => nil_files 18 | 1:ELEM 2:Files => cons_files 19 | 20 | nonterminal Export : export = 21 | STRUCTURE 1:IDENT => structure_export 22 | SIGNATURE 1:IDENT => signature_export 23 | FUNCTOR 1:IDENT => functor_export 24 | 25 | nonterminal Exports : exports = 26 | /* epsilon */ => nil_exports 27 | 1:Export 2:Exports => cons_exports 28 | 29 | 30 | nonterminal Main : main = 31 | GROUP 1:Exports IS 2:Files => main_prog 32 | LIBRARY 1:Exports IS 2:Files => main_prog 33 | 34 | start Main 35 | -------------------------------------------------------------------------------- /src/directive_parser/lex/lexer.cmlex: -------------------------------------------------------------------------------- 1 | sml 2 | name LexMainFun 3 | alphabet 256 4 | 5 | set whitespace = (or 32 9 13 10) 6 | 7 | set letter = (range 'A 'Z 'a 'z) 8 | set lowercase = (range 'a 'z) 9 | set digit = (range '0 '9) 10 | 11 | set symbol = (or '! '# '$ '% '& '' '* '+ '- '. ': '< '= '> '? '@ '^ '| '~ '` '/) 12 | 13 | set printable = (range 32 126) 14 | set stringelem = (- printable '" '\) 15 | set hexadecimal = (range '0 '9 'A 'F 'a 'f) 16 | set alphanumeric = (or letter digit '_ '') 17 | 18 | regexp ident = (seq letter (* alphanumeric)) 19 | regexp bindable = (or ident (+ symbol)) 20 | regexp longident = (seq (+ (seq ident '.)) bindable) 21 | 22 | function primary : t = 23 | (+ whitespace) => skip 24 | 25 | ident => enter_main 26 | 27 | eos => eof 28 | epsilon => error 29 | 30 | function main : t = 31 | (+ whitespace) => skip 32 | 33 | (+ digit) => lex_number 34 | 35 | '= => equal 36 | 37 | longident => lex_longident 38 | bindable => lex_bindable 39 | 40 | eos => eof 41 | epsilon => error 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | MIT License 3 | 4 | Copyright (c) 2022 Brandon Wu 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | -------------------------------------------------------------------------------- /src/util/sources.mlb: -------------------------------------------------------------------------------- 1 | ann "milletDiagnosticsIgnore all" in 2 | ../../cmlib/cmlib.mlb 3 | end 4 | $(SML_LIB)/basis/basis.mlb 5 | $(SML_LIB)/basis/mlton.mlb 6 | 7 | (* This has to be up here first cause `printf` needs it. 8 | *) 9 | local 10 | TerminalColors.sml 11 | in 12 | structure TerminalColors 13 | end 14 | 15 | (* Here are any files which have contents that we would like 16 | * to open to the top-level scope. 17 | *) 18 | either.sml 19 | printf.sml 20 | pervasive.sml 21 | 22 | local 23 | ListUtils.sml 24 | TerminalColors.sml 25 | PrettySimpleDoc.sml 26 | fresh_sym.sml 27 | cont.sml 28 | ids.sml 29 | io.sml 30 | ref.sml 31 | test_framework.sml 32 | error.sml 33 | common.sml 34 | in 35 | structure ListUtils 36 | structure PrettySimpleDoc 37 | structure FreshSym 38 | structure Cont 39 | structure Either 40 | structure IO 41 | 42 | functor MkTemp 43 | structure TyId 44 | structure ExnId 45 | structure AbsId 46 | structure ContId 47 | 48 | structure TyIdDict 49 | structure AbsIdDict 50 | structure ContIdDict 51 | 52 | structure Ref 53 | structure TestFramework 54 | structure Error 55 | 56 | structure Common 57 | end 58 | -------------------------------------------------------------------------------- /src/util/io.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* IO helper functions. 11 | *) 12 | 13 | (*****************************************************************************) 14 | (* Signature *) 15 | (*****************************************************************************) 16 | 17 | signature IO_SIG = 18 | sig 19 | val cat : string -> string list 20 | end 21 | 22 | (*****************************************************************************) 23 | (* Implementation *) 24 | (*****************************************************************************) 25 | 26 | structure IO : IO_SIG = 27 | struct 28 | fun cat filename = 29 | let 30 | val instream = TextIO.openIn filename 31 | 32 | fun read_lines () = 33 | case TextIO.inputLine instream of 34 | NONE => [] 35 | | SOME line => line :: read_lines () 36 | in 37 | read_lines () 38 | end 39 | end 40 | -------------------------------------------------------------------------------- /src/util/fresh_sym.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* Generate fresh symbols. 11 | *) 12 | 13 | (*****************************************************************************) 14 | (* Signature *) 15 | (*****************************************************************************) 16 | 17 | signature FRESHSYM = 18 | sig 19 | val new : unit -> Symbol.symbol 20 | 21 | val reset : unit -> unit 22 | end 23 | 24 | (*****************************************************************************) 25 | (* Implementation *) 26 | (*****************************************************************************) 27 | 28 | structure FreshSym : FRESHSYM = 29 | struct 30 | val counter = ref 0 31 | 32 | fun new () = 33 | let 34 | val cur = !counter 35 | in 36 | counter := !counter + 1; 37 | Symbol.fromValue ("t" ^ Int.toString cur) 38 | end 39 | 40 | fun reset () = counter := 0 41 | end 42 | -------------------------------------------------------------------------------- /src/directive_parser/parse/directive.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* The type of debugger commands. 11 | *) 12 | 13 | (*****************************************************************************) 14 | (* Implementation *) 15 | (*****************************************************************************) 16 | 17 | structure Directive = 18 | struct 19 | type longid = Symbol.symbol list 20 | 21 | datatype value = 22 | NUM of int 23 | | VALUE of Symbol.symbol 24 | 25 | datatype t = 26 | Step 27 | | Evaluate 28 | | Reveal of int option 29 | | Stop 30 | | Prev of int option 31 | | BreakFn of longid 32 | | BreakBind of Symbol.symbol 33 | | Run 34 | | Clear of longid option 35 | | Print of longid 36 | | Set of Symbol.symbol * value 37 | | Report of Symbol.symbol 38 | | Last of int option 39 | | Help 40 | | TypeOf of longid 41 | end 42 | -------------------------------------------------------------------------------- /src/directive_parser/parse/parser.cmyacc: -------------------------------------------------------------------------------- 1 | sml 2 | name ParserFun 3 | 4 | terminal NUM of int 5 | terminal IDENT of longid 6 | terminal STEP 7 | terminal EVALUATE 8 | terminal REVEAL 9 | terminal STOP 10 | terminal EQUAL 11 | terminal SET 12 | terminal PREV 13 | terminal BREAKBIND 14 | terminal BREAKFN 15 | terminal RUN 16 | terminal CLEAR 17 | terminal PRINT 18 | terminal REPORT 19 | terminal LAST 20 | terminal HELP 21 | terminal TYPEOF 22 | terminal EOF 23 | 24 | nonterminal Value : value = 25 | 1:IDENT => value_ident 26 | 1:NUM => value_num 27 | 28 | nonterminal Directive : directive = 29 | STEP => step 30 | EVALUATE => evaluate 31 | STOP => stop 32 | PREV => prev 33 | PREV 1:NUM => num_prev 34 | REVEAL => bare_reveal 35 | REVEAL 1:NUM => num_reveal 36 | CLEAR => bare_clear 37 | CLEAR 1:IDENT => sym_clear 38 | PRINT 1:IDENT => sym_print 39 | BREAKBIND 1:IDENT => break_bind 40 | BREAKFN 1:IDENT => break_fn 41 | SET 1:IDENT EQUAL 2:Value => change_setting 42 | REPORT 1:IDENT => report 43 | LAST => bare_last 44 | LAST 1:NUM => num_last 45 | HELP => do_help 46 | TYPEOF 1:IDENT => typeof_id 47 | RUN => run 48 | 49 | nonterminal Main : directive = 50 | 1:Directive EOF => main 51 | 52 | start Main 53 | -------------------------------------------------------------------------------- /src/util/common.sml: -------------------------------------------------------------------------------- 1 | 2 | structure Common = 3 | struct 4 | fun println s = print (s ^ "\n") 5 | fun suspend x = fn () => x 6 | 7 | fun with_refval r v f = 8 | let 9 | val old_val = !r 10 | val () = r := v 11 | val res = f () 12 | val () = r := old_val 13 | in 14 | res 15 | end 16 | 17 | fun with_file filename (contents : string) f = 18 | let 19 | val file = 20 | Posix.FileSys.createf 21 | ( filename 22 | , Posix.FileSys.O_RDWR 23 | , Posix.FileSys.O.flags [] 24 | , Posix.FileSys.S.irwxu ) 25 | 26 | val () = Posix.FileSys.ftruncate (file, 0) 27 | val () = Posix.FileSys.ftruncate (file, Position.fromInt 0) 28 | 29 | (* reset length of file in case it already existed *) 30 | val () = Posix.FileSys.ftruncate (file, 0) 31 | val _ = Posix.IO.writeVec 32 | (file, 33 | (Word8VectorSlice.slice (Byte.stringToBytes contents, 0, NONE)) 34 | ) 35 | 36 | val _ = Posix.IO.close file 37 | 38 | val res = f file 39 | in 40 | res 41 | end 42 | 43 | fun subset l1 l2 eq = 44 | List.foldl 45 | (fn (x, acc) => 46 | acc andalso 47 | List.exists (fn y => 48 | eq (x, y) 49 | ) l2 50 | ) 51 | true 52 | l1 53 | end -------------------------------------------------------------------------------- /src/cm_parser/syntax/token.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | structure CM_Token = 8 | struct 9 | type symbol = Symbol.symbol 10 | 11 | datatype elem = 12 | PATH of symbol 13 | | STRING of string 14 | 15 | datatype token = 16 | ELEM of elem 17 | 18 | | LIBRARY 19 | | GROUP 20 | | STRUCTURE 21 | | SIGNATURE 22 | | FUNCTOR 23 | | IDENT of symbol 24 | | IS 25 | 26 | | EOF 27 | 28 | fun insensitive_compare token1 token2 = 29 | case (token1, token2) of 30 | (ELEM (PATH sym1), ELEM (PATH sym2)) => Symbol.eq (sym1, sym2) 31 | 32 | | (ELEM (STRING s1), ELEM (STRING s2)) => s1 = s2 33 | 34 | | (STRUCTURE, STRUCTURE) => true 35 | | (SIGNATURE, SIGNATURE) => true 36 | | (FUNCTOR, FUNCTOR) => true 37 | | (IDENT s1, IDENT s2) => Symbol.toValue s1 = Symbol.toValue s2 38 | 39 | | (EOF, EOF) => true 40 | | _ => false 41 | 42 | fun elem_to_string elem = 43 | case elem of 44 | PATH node => Symbol.toValue node 45 | | STRING s => s 46 | 47 | fun token_to_string tok = 48 | case tok of 49 | ELEM elem => elem_to_string elem 50 | 51 | | LIBRARY => "Library" 52 | | GROUP => "Group" 53 | | STRUCTURE => "structure" 54 | | SIGNATURE => "signature" 55 | | FUNCTOR => "functor" 56 | | IDENT s => Symbol.toValue s 57 | | IS => "Is" 58 | 59 | | EOF => "eof" 60 | 61 | end 62 | -------------------------------------------------------------------------------- /test/snapshots/foldr.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/foldr.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | fun foldr f z [] = z 7 | | foldr f z (x :: xs) = f (x, foldr f z xs) 8 | val _ = foldr (op ^) "" ["1", "5", "0"] 9 | 10 | - ==> 11 | val _ = foldr (op ^) "" ["1", "5", "0"] 12 | 13 | - ==> 14 | val _ = 15 | case (^, "", ["1", "5", "0"]) of 16 | (f, z, []) => z 17 | | (f, z, (x :: xs)) => 18 | f (x, foldr f z xs) 19 | 20 | - ==> 21 | val _ = "1" ^ foldr ^ "" ["5", "0"] 22 | 23 | - ==> 24 | val _ = 25 | "1" ^ case (^, "", ["5", "0"]) of 26 | (f, z, []) => z 27 | | (f, z, (x :: xs)) => 28 | f (x, foldr f z xs) 29 | 30 | - ==> 31 | val _ = "1" ^ "5" ^ foldr ^ "" ["0"] 32 | 33 | - ==> 34 | val _ = 35 | "1" ^ "5" ^ case (^, "", ["0"]) of 36 | (f, z, []) => z 37 | | (f, z, (x :: xs)) => 38 | f (x, foldr f z xs) 39 | 40 | - ==> 41 | val _ = "1" ^ "5" ^ "0" ^ foldr ^ "" [] 42 | 43 | - ==> 44 | val _ = 45 | "1" ^ "5" ^ "0" ^ case (^, "", []) of 46 | (f, z, []) => z 47 | | (f, z, (x :: xs)) => 48 | f (x, foldr f z xs) 49 | 50 | - ==> 51 | val _ = "1" ^ "5" ^ "0" ^ "" 52 | 53 | - ==> 54 | val _ = "1" ^ "5" ^ "0" 55 | 56 | - ==> 57 | val _ = "1" ^ "50" 58 | 59 | - ==> 60 | val _ = "150" 61 | 62 | - Program evaluation finished. 63 | 64 | -------------------------------------------------------------------------------- /src/util/ref.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* A wrapper around the `ref` type, with some additional helpful helper 11 | * functions. 12 | *) 13 | 14 | (*****************************************************************************) 15 | (* Signature *) 16 | (*****************************************************************************) 17 | 18 | signature REF = 19 | sig 20 | type 'a t 21 | 22 | val new : 'a -> 'a t 23 | val assign : 'a t -> 'a -> unit 24 | val force : 'a t -> 'a 25 | 26 | val compare : 'a t * 'a t -> order 27 | val eq : 'a t * 'a t -> bool 28 | 29 | val show : 'a t -> string 30 | end 31 | 32 | (*****************************************************************************) 33 | (* Signature *) 34 | (*****************************************************************************) 35 | 36 | structure Ref : REF = 37 | struct 38 | type 'a t = int * 'a ref 39 | 40 | val counter = ref 0 41 | fun new x = 42 | ( counter := !counter + 1 43 | ; (!counter, ref x) 44 | ) 45 | fun assign (_, r) x = r := x 46 | fun force (_, r) = !r 47 | 48 | fun compare ((i1, _), (i2, _)) = Int.compare (i1, i2) 49 | fun eq (r1, r2) = 50 | case compare (r1, r2) of 51 | EQUAL => true 52 | | _ => false 53 | 54 | fun show (i, _) = "t" ^ Int.toString i 55 | end 56 | -------------------------------------------------------------------------------- /src/directive_parser/lex/token.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* Tokens for the directive lexer. 11 | *) 12 | 13 | (*****************************************************************************) 14 | (* Implementation *) 15 | (*****************************************************************************) 16 | 17 | structure Token = 18 | struct 19 | datatype t = 20 | NUM of int 21 | | IDENT of Symbol.symbol list 22 | | STEP 23 | | EVALUATE 24 | | REVEAL 25 | | STOP 26 | | PREV 27 | | BREAKBIND 28 | | BREAKFN 29 | | RUN 30 | | CLEAR 31 | | PRINT 32 | | REPORT 33 | | LAST 34 | | HELP 35 | | TYPEOF 36 | 37 | | EQUAL 38 | | SET 39 | 40 | | EOF 41 | 42 | fun to_string t = 43 | case t of 44 | NUM i => "NUM " ^ Int.toString i 45 | | IDENT syms => 46 | String.concatWith "." (List.map Symbol.toValue syms) 47 | | STEP => "STEP" 48 | | EVALUATE => "EVALUATE" 49 | | REVEAL => "REVEAL" 50 | | STOP => "STOP" 51 | | EQUAL => "EQUAL" 52 | | SET => "SET" 53 | | PREV => "PREV" 54 | | BREAKFN => "BREAKFN" 55 | | BREAKBIND => "BREAKBIND" 56 | | RUN => "RUN" 57 | | CLEAR => "CLEAR" 58 | | PRINT => "PRINT" 59 | | REPORT => "REPORT" 60 | | LAST => "LAST" 61 | | HELP => "HELP" 62 | | TYPEOF => "TYPEOF" 63 | | EOF => "EOF" 64 | 65 | end 66 | -------------------------------------------------------------------------------- /src/util/cont.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* This library includes a wrapper over an abstract type which represents a 11 | * first-class continuation. 12 | * 13 | * First-class continuations are used liberally throughout mulligan to be able 14 | * to facilitate a smooth interaction between the interactive top-level and the 15 | * code running the debugger. 16 | * 17 | * First-class continuations are notoriously tricky to work with, however, so 18 | * we wrap it in an abstract type so that we can allow easy refactoring if we 19 | * want to augment these continuations with any other additional metadata. 20 | *) 21 | 22 | (*****************************************************************************) 23 | (* Signature *) 24 | (*****************************************************************************) 25 | 26 | signature CONT = 27 | sig 28 | type 'a t 29 | 30 | val callcc : ('a t -> 'a) -> 'a 31 | 32 | val throw : 'a t -> 'a -> 'b 33 | 34 | val do_after : 'a t -> ('a -> 'a) -> 'a t 35 | 36 | val get_id : 'a t -> int 37 | end 38 | 39 | (*****************************************************************************) 40 | (* Implementation *) 41 | (*****************************************************************************) 42 | 43 | structure Cont :> CONT 44 | = 45 | struct 46 | type 'a t = int * ('a -> 'a) * 'a MLton.Cont.t 47 | 48 | val counter = ref 0 49 | fun new () = 50 | ( counter := !counter + 1 51 | ; !counter 52 | ) 53 | 54 | fun callcc f = 55 | let 56 | val num = new () 57 | in 58 | MLton.Cont.callcc (fn cont => 59 | f (num, fn x => x, cont) 60 | ) 61 | end 62 | 63 | fun do_after ((i, _, cont) : 'a t) f = (i, f, cont) 64 | 65 | fun throw ((_, f, cont) : 'a t) v = 66 | MLton.Cont.throw (cont, f v) 67 | 68 | fun get_id ((i, _, _) : 'a t) = i 69 | end 70 | -------------------------------------------------------------------------------- /test/snapshots/lem.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/lem.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | datatype ('a, 'b) either = INL of 'a | INR of 'b 7 | type 'a lem = ('a, 'a Cont.cont) either 8 | val lem_proof : unit -> 'a lem = 9 | fn () => 10 | callcc 11 | ( fn ret => 12 | INL (callcc (fn na => throw ret (INR na))) 13 | ) 14 | val res = 15 | case lem_proof () of 16 | INL n => n * n 17 | | INR nn => 18 | throw nn 2 19 | 20 | - ==> 21 | val lem_proof : unit -> 'a lem = 22 | fn () => 23 | callcc 24 | ( fn ret => 25 | INL (callcc (fn na => throw ret (INR na))) 26 | ) 27 | 28 | - ==> 29 | val res = 30 | case 31 | ( fn () => 32 | callcc 33 | ( fn ret => 34 | INL (callcc (fn na => throw ret (INR na))) 35 | ) 36 | ) 37 | () 38 | of 39 | INL n => n * n 40 | | INR nn => 41 | throw nn 2 42 | 43 | - ==> 44 | val res = 45 | case 46 | callcc 47 | ( fn ret => 48 | INL (callcc (fn na => throw ret (INR na))) 49 | ) 50 | of 51 | INL n => n * n 52 | | INR nn => 53 | throw nn 2 54 | 55 | - ==> 56 | val res = 57 | case INL (callcc (fn na => throw cont6 (INR na))) of 58 | INL n => n * n 59 | | INR nn => 60 | throw nn 2 61 | 62 | - ==> 63 | val res = 64 | case INL (throw cont6 (INR cont7)) of 65 | INL n => n * n 66 | | INR nn => 67 | throw nn 2 68 | 69 | - ==> 70 | val res = 71 | case INL (throw[cont6] (INR cont7)) of 72 | INL n => n * n 73 | | INR nn => 74 | throw nn 2 75 | 76 | - ==> 77 | val res = 78 | case INR cont7 of INL n => n * n | INR nn => throw nn 2 79 | 80 | - ==> 81 | val res = throw cont7 2 82 | 83 | - ==> 84 | val res = throw[cont7] 2 85 | 86 | - ==> 87 | val res = 88 | case INL 2 of INL n => n * n | INR nn => throw nn 2 89 | 90 | - ==> 91 | val res = 2 * 2 92 | 93 | - ==> 94 | val res = 4 95 | 96 | - Program evaluation finished. 97 | 98 | -------------------------------------------------------------------------------- /src/util/ids.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* Unique identifiers which can be freshly generated to not clash with any 11 | * previously existing values. 12 | * 13 | * Because of generative functors, these can be freshly minted to create brand 14 | * new types which are statically distinct. 15 | *) 16 | 17 | (*****************************************************************************) 18 | (* Functor *) 19 | (*****************************************************************************) 20 | 21 | functor MkTemp (val prefix : string) :> 22 | sig 23 | type t 24 | type key = t 25 | 26 | val new : Symbol.symbol option -> t 27 | val eq : t * t -> bool 28 | val compare : t * t -> order 29 | 30 | val show : t -> string 31 | end = 32 | struct 33 | type t = int * Symbol.symbol option 34 | type key = t 35 | 36 | val counter = ref 0 37 | 38 | fun new opt = 39 | ( counter := !counter + 1 40 | ; (!counter, opt) 41 | ) 42 | 43 | 44 | fun eq ((n, _), (n', _)) = n = n' 45 | 46 | fun compare ((n, _), (n', _)) = Int.compare (n, n') 47 | 48 | fun show (i, opt) = 49 | case opt of 50 | NONE => prefix ^ Int.toString i 51 | | SOME s => Symbol.toValue s 52 | end 53 | 54 | (*****************************************************************************) 55 | (* Identifiers *) 56 | (*****************************************************************************) 57 | 58 | structure TyId = MkTemp (val prefix = "ty") 59 | structure ExnId = MkTemp (val prefix = "exn") 60 | structure AbsId = MkTemp (val prefix = "abs") 61 | structure ContId = MkTemp (val prefix = "cont") 62 | 63 | (*****************************************************************************) 64 | (* Dictionaries *) 65 | (*****************************************************************************) 66 | 67 | structure TyIdDict = RedBlackDict (structure Key = TyId) 68 | structure AbsIdDict = RedBlackDict (structure Key = AbsId) 69 | structure ContIdDict = RedBlackDict (structure Key = ContId) 70 | -------------------------------------------------------------------------------- /test/snapshots/infix_printing.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/infix_printing.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | fun foldr f z [] = z 7 | | foldr f z (x :: xs) = f (x, foldr f z xs) 8 | val _ = foldr (op ^) "" ["H", "E", "L", "L", "O"] 9 | 10 | - ==> 11 | val _ = foldr (op ^) "" ["H", "E", "L", "L", "O"] 12 | 13 | - ==> 14 | val _ = 15 | case (^, "", ["H", "E", "L", "L", "O"]) of 16 | (f, z, []) => z 17 | | (f, z, (x :: xs)) => 18 | f (x, foldr f z xs) 19 | 20 | - ==> 21 | val _ = "H" ^ foldr ^ "" ["E", "L", "L", "O"] 22 | 23 | - ==> 24 | val _ = 25 | "H" ^ case (^, "", ["E", "L", "L", "O"]) of 26 | (f, z, []) => z 27 | | (f, z, (x :: xs)) => 28 | f (x, foldr f z xs) 29 | 30 | - ==> 31 | val _ = "H" ^ "E" ^ foldr ^ "" ["L", "L", "O"] 32 | 33 | - ==> 34 | val _ = 35 | "H" ^ "E" ^ case (^, "", ["L", "L", "O"]) of 36 | (f, z, []) => z 37 | | (f, z, (x :: xs)) => 38 | f (x, foldr f z xs) 39 | 40 | - ==> 41 | val _ = "H" ^ "E" ^ "L" ^ foldr ^ "" ["L", "O"] 42 | 43 | - ==> 44 | val _ = 45 | "H" ^ "E" ^ "L" ^ case (^, "", ["L", "O"]) of 46 | (f, z, []) => z 47 | | (f, z, (x :: xs)) => 48 | f (x, foldr f z xs) 49 | 50 | - ==> 51 | val _ = "H" ^ "E" ^ "L" ^ "L" ^ foldr ^ "" ["O"] 52 | 53 | - ==> 54 | val _ = 55 | "H" ^ "E" ^ "L" ^ "L" ^ case (^, "", ["O"]) of 56 | (f, z, []) => z 57 | | (f, z, (x :: xs)) => 58 | f (x, foldr f z xs) 59 | 60 | - ==> 61 | val _ = "H" ^ "E" ^ "L" ^ "L" ^ "O" ^ foldr ^ "" [] 62 | 63 | - Revealing: 64 | "O" ^ foldr ^ "" [] 65 | 66 | - Revealing: 67 | ("L", "O" ^ foldr ^ "" []) 68 | 69 | - Revealing: 70 | "L" ^ "O" ^ foldr ^ "" [] 71 | 72 | - Revealing: 73 | ("L", "L" ^ "O" ^ foldr ^ "" []) 74 | 75 | - Revealing: 76 | "L" ^ "L" ^ "O" ^ foldr ^ "" [] 77 | 78 | - Revealing: 79 | ("E", "L" ^ "L" ^ "O" ^ foldr ^ "" []) 80 | 81 | - Revealing: 82 | "E" ^ "L" ^ "L" ^ "O" ^ foldr ^ "" [] 83 | 84 | - Revealing: 85 | ("H", "E" ^ "L" ^ "L" ^ "O" ^ foldr ^ "" []) 86 | 87 | - Program evaluation finished. 88 | 89 | -------------------------------------------------------------------------------- /src/context/PrettyPrintContext.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* The pretty-printer is contextual, meaning that it contains a lot of 11 | * identifiers which are populated by equipping our print functions 12 | * with a context of bindings. 13 | * 14 | * We call these "markers", which is a simple type which separates these 15 | * bindings by their namespaces (modules, values, etc). 16 | * 17 | * This is important because we need to know, when traveling out of the debugger's 18 | * specific one-hole context, which bindings start being and cease being valid. 19 | * We store that information in a data structure called a MarkerSet. 20 | *) 21 | 22 | (*****************************************************************************) 23 | (* Implementation *) 24 | (*****************************************************************************) 25 | 26 | structure PrettyPrintContext = 27 | struct 28 | type symbol = SMLSyntax.symbol 29 | 30 | datatype marker = 31 | MOD of symbol 32 | | VAL of symbol 33 | 34 | structure MarkerOrdered = 35 | struct 36 | type t = marker 37 | 38 | fun enum marker = 39 | case marker of 40 | MOD _ => 0 41 | | VAL _ => 1 42 | 43 | fun eq (m1, m2) = 44 | case (m1, m2) of 45 | (MOD s1, MOD s2) => Symbol.eq (s1, s2) 46 | | (VAL s1, VAL s2) => Symbol.eq (s1, s2) 47 | | _ => false 48 | 49 | fun compare (m1, m2) = 50 | case Int.compare (enum m1, enum m2) of 51 | LESS => LESS 52 | | GREATER => GREATER 53 | | EQUAL => 54 | (case (m1, m2) of 55 | (MOD s1, MOD s2) => Symbol.compare (s1, s2) 56 | | (VAL s1, VAL s2) => Symbol.compare (s1, s2) 57 | | _ => raise Fail "shouldn't happen" 58 | ) 59 | end 60 | 61 | structure MarkerSet = RedBlackSet (structure Elem = MarkerOrdered) 62 | 63 | type t = MarkerSet.set 64 | 65 | fun union_sets l = 66 | List.foldl 67 | (fn (set, acc) => 68 | MarkerSet.union set acc 69 | ) 70 | MarkerSet.empty 71 | l 72 | end 73 | -------------------------------------------------------------------------------- /src/util/printf.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | 11 | signature PRINTF = 12 | sig 13 | type ('a, 'b, 'state) t 14 | 15 | val ` : string -> ('a, 'a, 'state) t 16 | val newFormat: 17 | ('state -> 'a -> string) 18 | -> ('a -> 'b, 'c, 'state) t * string 19 | -> ('b, 'c, 'state) t 20 | 21 | val spf: (string, 'a, unit) t -> 'a 22 | val cprintf: 'state -> (string, 'a, 'state) t -> 'a 23 | 24 | (* CAUTION: If you add a format flag, don't forget to add its infixity! *) 25 | val fd : (int -> 'a, 'b, 'state) t * string -> ('a, 'b, 'state) t 26 | val fs : (string -> 'a, 'b, 'state) t * string -> ('a, 'b, 'state) t 27 | val fi : (Symbol.symbol -> 'a, 'b, 'state) t * string -> ('a, 'b, 'state) t 28 | val fli : (Symbol.symbol list -> 'a, 'b, 'state) t * string -> ('a, 'b, 'state) t 29 | end 30 | 31 | (*****************************************************************************) 32 | (* Prelude *) 33 | (*****************************************************************************) 34 | 35 | structure Printf : PRINTF = 36 | struct 37 | datatype ('a, 'b, 'state) t = 38 | T of ('state * string -> 'a) -> 'state * string -> 'b 39 | 40 | fun cprintf state (T f) = f (fn (_, s) => s) (state, "") 41 | fun spf (T f) = f (fn (_, s) => s) ((), "") 42 | 43 | fun ` s = T (fn f => fn (state, s') => f (state, s' ^ s)) 44 | 45 | fun newFormat toString (T f, s) = 46 | T (fn th => 47 | f (fn (state, s') => fn a => 48 | (th ( state, s' ^ toString state a ^ s ) 49 | ) 50 | ) 51 | ) 52 | 53 | fun promote f = 54 | (* unused context parameter *) 55 | fn _ => fn x => f x 56 | 57 | structure TC = TerminalColors 58 | 59 | fun longid_to_str syms = 60 | String.concatWith "." (List.map Symbol.toValue syms) 61 | 62 | fun lightblue s = TC.foreground TC.lightblue ^ s ^ TC.reset 63 | 64 | val fd = fn acc => newFormat (promote (fn i => Int.toString i)) acc 65 | val fs = fn acc => newFormat (promote (fn s => s)) acc 66 | val fi = fn acc => newFormat (promote (lightblue o Symbol.toValue)) acc 67 | val fli = fn acc => newFormat (promote (lightblue o longid_to_str)) acc 68 | end 69 | -------------------------------------------------------------------------------- /src/cm_parser/lex/lexer.cmlex: -------------------------------------------------------------------------------- 1 | sml 2 | name LexMainFun 3 | alphabet 256 4 | 5 | set whitespace = (or 32 9 13 10) 6 | 7 | set letter = (range 'A 'Z 'a 'z) 8 | set lowercase = (range 'a 'z) 9 | set digit = (range '0 '9) 10 | 11 | set symbol = (or '! '# '$ '% '& '' '* '+ '- '. ': '< '= '> '? '@ '^ '| '~ '` '/) 12 | 13 | set printable = (range 32 126) 14 | set stringelem = (- printable '" '\) 15 | set hexadecimal = (range '0 '9 'A 'F 'a 'f) 16 | 17 | set alphanumeric = (or letter digit '_ '') 18 | 19 | regexp ident = (seq letter (* alphanumeric)) 20 | 21 | set path_part_no_dot = 22 | (or '` '_ '; ', '! '% '& '$ '+ '< '= '> '? '@ '~ '| '# '* '- '^ letter digit) 23 | set path_part = (or path_part_no_dot '.) 24 | 25 | regexp elem = (+ path_part) 26 | regexp elem_no_dot = (+ path_part_no_dot) 27 | regexp end = (seq path_part_no_dot (* path_part) '. (+ path_part_no_dot)) 28 | regexp path_no_abs = (seq (* (seq elem '/)) end) 29 | regexp path = (or path_no_abs (seq '/ path_no_abs)) 30 | 31 | function main : t = 32 | (+ whitespace) => skip_main 33 | 34 | (or "group" "Group" "GROUP") => 35 | enter_group 36 | 37 | (or "library" "Library" "LIBRARY") => 38 | enter_library 39 | 40 | "(*" => enter_comment 41 | 42 | eos => unfinished 43 | epsilon => error 44 | 45 | set not_whitespace = (~ whitespace) 46 | 47 | function group_or_library : t = 48 | (+ whitespace) => skip_gl 49 | 50 | "is" => enter_is 51 | 52 | ident => ident 53 | 54 | "(*" => enter_comment 55 | 56 | (+ not_whitespace) => analyze_gl 57 | 58 | eos => unfinished 59 | epsilon => error 60 | 61 | function ifmode : u = 62 | (+ whitespace) => skip_if 63 | 64 | "#endif" => exit_if 65 | 66 | (+ not_whitespace) => skip_if 67 | 68 | eos => unfinished_if 69 | epsilon => error_if 70 | 71 | 72 | function is : t = 73 | (+ whitespace) => skip_is 74 | 75 | path => is_stdpn 76 | 77 | "#if" => enter_if 78 | 79 | "(*" => enter_comment 80 | '" => enter_string 81 | 82 | eos => eof 83 | epsilon => error 84 | 85 | function string : v = 86 | (+ stringelem) => string_elem 87 | 88 | "\n" => string_newline 89 | "\\" => string_backslash 90 | (seq '\ '") => string_quote 91 | (seq "\x" (= 2 hexadecimal)) => string_hex2 92 | (seq '\ (+ whitespace) '\) => string_skip 93 | 94 | '" => exit_string 95 | 96 | eos => unclosed_string 97 | epsilon => string_error 98 | 99 | set comment_normal = (~ '( '*) 100 | 101 | function comment : u = 102 | "(*" => reenter_comment 103 | "*)" => exit_comment 104 | 105 | '( => comment_skip 106 | '* => comment_skip 107 | 108 | (+ comment_normal) => comment_skip 109 | 110 | eos => unclosed_comment 111 | epsilon => comment_error 112 | -------------------------------------------------------------------------------- /src/util/ListUtils.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* Utility functions on lists. 11 | *) 12 | 13 | (*****************************************************************************) 14 | (* Signature *) 15 | (*****************************************************************************) 16 | 17 | signature LISTUTILS = 18 | sig 19 | val last : 'a list -> 'a 20 | val snoc : 'a list -> 'a list * 'a 21 | val enum : 'a list -> (int * 'a) list 22 | val up_to_last : 'a list -> 'a list 23 | val map_last : ('a -> 'b) -> 'a list -> 'b 24 | val map_cons : ('a -> 'b) -> ('a -> 'b) -> 'a list -> 'b list 25 | val cons_rev : 'a list -> 'a -> 'a list 26 | val concat_map : ('a -> 'b list) -> 'a list -> 'b list 27 | 28 | val mapi : ('a * int -> 'b) -> 'a list -> 'b list 29 | 30 | val fold_with_tail : ('a * 'a list * 'b -> 'b) -> 'b -> 'a list -> 'b 31 | 32 | val flatten : 'a list list -> 'a list 33 | end 34 | 35 | (*****************************************************************************) 36 | (* Implementation *) 37 | (*****************************************************************************) 38 | 39 | structure ListUtils : LISTUTILS = 40 | struct 41 | fun last [] = raise Fail "finding last of empty list" 42 | | last l = List.nth (l, List.length l - 1) 43 | 44 | fun snoc l = 45 | ( List.take (l, List.length l - 1) 46 | , List.nth (l, List.length l - 1) 47 | ) 48 | 49 | fun enum l = 50 | List.foldl 51 | (fn (elem, (i, acc)) => 52 | (i + 1, (i, elem) :: acc) 53 | ) 54 | (0, []) 55 | l 56 | |> (fn (_, l) => List.rev l) 57 | 58 | fun up_to_last l = 59 | List.take (l, List.length l - 1) 60 | 61 | fun map_last f l = f (last l) 62 | 63 | fun map_cons _ _ [] = [] 64 | | map_cons f g (x::xs) = f x :: List.map g xs 65 | 66 | fun mapi f l = 67 | List.foldl 68 | (fn (x, (i, acc)) => 69 | (i + 1, f (x, i) :: acc) 70 | ) 71 | (0, []) 72 | l 73 | |> (fn l => List.rev (#2 l)) 74 | 75 | fun fold_with_tail f z l = 76 | case l of 77 | [] => z 78 | | x::xs => 79 | fold_with_tail f (f (x, xs, z)) xs 80 | 81 | fun cons_rev L x = x::L 82 | (* I could instead write `Fn.curry (Fn.flip op::)`, but then I get value 83 | * restricted. Sad! *) 84 | 85 | fun concat_map f = List.concat o List.map f 86 | 87 | fun flatten [] = [] 88 | | flatten ([]::xss) = flatten xss 89 | | flatten ((x::xs)::xss) = x::(flatten (xs::xss)) 90 | end 91 | -------------------------------------------------------------------------------- /notes.txt: -------------------------------------------------------------------------------- 1 | 2 | to compile: 3 | mlton -mlb-path-var 'COMPAT mlton' -default-ann 'allowOrPats true' sources.mlb 4 | 5 | IMPORTANT: The pretty printer is contextual. 6 | 7 | This means that substitution never actually needs to happen. We know that it's 8 | equivalent to either eagerly substitute values, or to keep them around as a 9 | lookup table with an expression with free variables. 10 | 11 | The problem is that substitution is hard, and you can't go back. So the pretty 12 | printer can just take in an un-substituted expression, equipped with its 13 | closure, and then generate the text as needed. 14 | 15 | So we never have to actually do substitution, we can just alter the context. 16 | 17 | users will be able to enter non-typechecking inputs if we have no type 18 | information... 19 | 20 | The first pass (elaboration) is supposed to be contextual, but this duplicates a 21 | lot of annoying code, so I've decided to make it non-contextual. 22 | 23 | This means we can't do things like put the context into the Efn, change Eidents 24 | to Econstrs, etc, but this can be done in a later pass. 25 | 26 | All function values come equipped with their own reference cell for whether or 27 | not they have been broken. Then, upon breaking a function, that flag will be set 28 | for every copy, including the recursive copies within the special closures for 29 | mutually recursive functions. 30 | 31 | This means that breaking functions persists beyond names, but are attached to 32 | the exact function value. 33 | 34 | ABSTRACT TYPES 35 | 36 | A key issue with abstract types is that the debugger steps into the code of a 37 | function upon invocation. 38 | 39 | The code of a function within a module which binds an abstract type has full 40 | knowledge of what the type is, but at the later step in the program, upon 41 | stepping that expression, the type-checker will operate on the premise that it 42 | does not know the implementation of the abstract type, and thus type err. 43 | 44 | Normally, problems like this are fixed with the fact that function values 45 | contain their own contexts. However, contexts are not powerful enough to recover 46 | types from opaque ascription. This is because, at function-declaration time, the 47 | program has no idea what types in the scope are later going to be made abstract. 48 | That is something which is only known at ascription time. 49 | 50 | So the solution is to modify each valspec to store the known abstract types at 51 | its binding time, and then cause ascription to percolate that information to the 52 | function value itself. So then we can have full knowledge of the proper type, 53 | within the function value itself. 54 | 55 | The downside is that we're gonna have to make sure we call a contextual `norm_tyval` 56 | anywhere that might actually rely on what a tyval is. 57 | 58 | 59 | KNOWN ISSUES: 60 | - It looks like shit 61 | - should probably stop before entering a Let body 62 | - Sources in CM files are processed in linear order, which may not be correct. 63 | For full correctness, they should be processed to determine the dependency 64 | graph, and then an ordering selected from there. 65 | - No support for .mlb files 66 | - Substitution does not work properly for referring to bindings in a module that 67 | is currently being evaluated 68 | - equality types 69 | - update prettysimpledoc 70 | - error handling is not complete (CouldNotFind, Mismatch?) 71 | -------------------------------------------------------------------------------- /src/util/pervasive.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* Top-level globally-available values. 11 | * 12 | * This file should contain only things which are frequently used in many 13 | * places, which we are OK with polluting the namespace with. 14 | *) 15 | 16 | (*****************************************************************************) 17 | (* Global helpers *) 18 | (*****************************************************************************) 19 | 20 | (* So we have slightly more precedence than `<|`. 21 | *) 22 | infix 1 |> 23 | fun x |> f = f x 24 | 25 | fun fst (x, _) = x 26 | fun snd (_, y) = y 27 | 28 | (* A typical use case is something like: 29 | * 30 | * print <| spf (`"a number is "fs"\n.") (Int.toString i) 31 | * 32 | * With low precedence, we won't have to put parentheses, and the `print` 33 | * is understood to go last. 34 | *) 35 | infixr 0 <| 36 | fun f <| x = f x 37 | 38 | fun ignore _ = () 39 | 40 | (* a unit test!!!! *) 41 | val _ : string = (fn _ => "") <| 2 |> (fn _ => 4) 42 | 43 | fun orange s = TerminalColors.text TerminalColors.orange s 44 | fun red s = TerminalColors.text TerminalColors.red s 45 | fun lightblue s = TerminalColors.text TerminalColors.lightblue s 46 | 47 | fun opt_all l = 48 | List.foldr (fn (x, acc) => 49 | case (x, acc) of 50 | (_, NONE) => NONE 51 | | (NONE, _) => NONE 52 | | (SOME x, SOME acc) => SOME (x :: acc) 53 | ) (SOME []) l 54 | 55 | fun push x r = r := x :: (!r) 56 | 57 | (* returns absolute paths *) 58 | fun files_of_directory path = 59 | let 60 | val stream = OS.FileSys.openDir path 61 | val files : string list ref = ref [] 62 | 63 | fun aux () = 64 | case OS.FileSys.readDir stream of 65 | NONE => () 66 | | SOME file => 67 | ( aux () 68 | ; push (OS.Path.joinDirFile {dir = path, file = file}) files 69 | ) 70 | in 71 | ( aux (); 72 | !files 73 | ) 74 | end 75 | 76 | fun file_exists path = Posix.FileSys.access (path, []) 77 | 78 | datatype either = datatype Either.t 79 | 80 | infix fd fs fi fli ftv fe fv fp fl 81 | open Printf 82 | 83 | (* TODO: a thought of "modifiers"? 84 | * lots of patterns atm are smth like 85 | * 86 | * spf ... (lightblue s) 87 | * 88 | * kinda annoying to write `(lightblue s)` so many times though, 89 | * esp since the `lightblue` is the first thing you see. 90 | * 91 | * maybe make this a postfix thing, could be... 92 | * 93 | * print <| spf (`"The rain in "fs" falls on the "fs"") 94 | (s1 st [lightblue]) 95 | * 96 | * understood as "s1 such that it is lightblue" 97 | * can change to something that isn't `st` if it's tough to read though 98 | *) 99 | 100 | fun with_time_str f = 101 | let 102 | val timer = Timer.startRealTimer () 103 | val res = f () 104 | val elapsed_time = 105 | Time.toReal (Timer.checkRealTimer timer) 106 | |> Real.fromLarge IEEEReal.TO_NEAREST 107 | 108 | val time_str = Real.fmt (StringCvt.FIX (SOME 2)) elapsed_time 109 | in 110 | (res, time_str) 111 | end 112 | -------------------------------------------------------------------------------- /src/util/TerminalColors.sml: -------------------------------------------------------------------------------- 1 | (** Copyright (c) 2020 Sam Westrick 2 | * 3 | * See the file LICENSE for details. 4 | *) 5 | 6 | structure TerminalColors: 7 | sig 8 | 9 | type color 10 | val white: color 11 | val black: color 12 | val red: color 13 | val green: color 14 | val blue: color 15 | val lightblue: color 16 | val softred: color 17 | val softgreen: color 18 | val orange: color 19 | val purple: color 20 | val yellow: color 21 | 22 | val text : color -> string -> string 23 | 24 | (* channel values 0 to 1 *) 25 | val rgb: {red: real, green: real, blue: real} -> color 26 | 27 | (* hue in [0, 360) and sat/value in [0,1] *) 28 | val hsv: {h: real, s: real, v: real} -> color 29 | 30 | val background: color -> string 31 | val foreground: color -> string 32 | val bold: string 33 | val italic: string 34 | val underline: string 35 | val reset: string 36 | 37 | val decolorify : string -> string 38 | end = 39 | struct 40 | 41 | type color = {red: real, green: real, blue: real} 42 | fun rgb x = x 43 | 44 | val white = {red=1.0, green=1.0, blue=1.0} 45 | val black = {red=0.0, green=0.0, blue=0.0} 46 | val red = {red=1.0, green=0.0, blue=0.0} 47 | val green = {red=0.0, green=1.0, blue=0.0} 48 | val blue = {red=0.0, green=0.0, blue=1.0} 49 | 50 | fun hsv {h, s, v} = 51 | let 52 | val H = h 53 | val S = s 54 | val V = v 55 | 56 | (* from https://en.wikipedia.org/wiki/HSL_and_HSV#HSV_to_RGB *) 57 | val C = V * S 58 | val H' = H / 60.0 59 | val X = C * (1.0 - Real.abs (Real.rem (H', 2.0) - 1.0)) 60 | 61 | val (R1, G1, B1) = 62 | if H' < 1.0 then (C, X, 0.0) 63 | else if H' < 2.0 then (X, C, 0.0) 64 | else if H' < 3.0 then (0.0, C, X) 65 | else if H' < 4.0 then (0.0, X, C) 66 | else if H' < 5.0 then (X, 0.0, C) 67 | else (C, 0.0, X) 68 | 69 | val m = V - C 70 | in 71 | {red = R1 + m, green = G1 + m, blue = B1 + m} 72 | end 73 | 74 | val lightblue = hsv {h = 199.0, s = 0.8, v = 0.99} 75 | val softred = hsv {h = 0.0, s = 0.66, v = 0.83} 76 | val softgreen = hsv {h = 129.0, s = 0.82, v = 1.0} 77 | val orange = hsv {h = 35.0, s = 0.85, v = 0.84} 78 | val purple = hsv {h=283.0,s=0.87,v=0.87} 79 | val yellow = hsv {h =59.0, s=0.74, v = 0.95} 80 | 81 | fun to256 channel = 82 | Real.ceil (channel * 255.0) 83 | 84 | val esc = "\027[" 85 | 86 | fun background {red, green, blue} = 87 | esc ^ "48;2;" ^ 88 | Int.toString (to256 red) ^ ";" ^ 89 | Int.toString (to256 green) ^ ";" ^ 90 | Int.toString (to256 blue) ^ 91 | "m" 92 | 93 | fun foreground {red, green, blue} = 94 | esc ^ "38;2;" ^ 95 | Int.toString (to256 red) ^ ";" ^ 96 | Int.toString (to256 green) ^ ";" ^ 97 | Int.toString (to256 blue) ^ 98 | "m" 99 | 100 | val bold = esc ^ "1m" 101 | 102 | val italic = esc ^ "3m" 103 | 104 | val underline = esc ^ "4m" 105 | 106 | val reset = esc ^ "0m" 107 | 108 | fun text color s = foreground color ^ s ^ reset 109 | 110 | fun decolorify s = 111 | let 112 | fun remove_code cs = 113 | case cs of 114 | [] => raise Fail "pretty sure this shouldn't happen" 115 | | #"m" :: rest => rest 116 | | _ :: rest => remove_code rest 117 | 118 | fun aux cs = 119 | case cs of 120 | [] => [] 121 | | #"\027" :: _ => 122 | aux (remove_code cs) 123 | | x :: rest => 124 | x :: aux rest 125 | in 126 | String.implode (aux (String.explode s)) 127 | end 128 | 129 | end 130 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mulligan 2 | 3 | `mulligan` is an interpreter-style debugger for the Standard ML language, aiming to implement 4 | the semantics of SML at a fine granularity for inspection purposes. 5 | 6 | Has rudimentary support for SML/NJ CM files, allowing analysis of entire SML/NJ 7 | projects. 8 | 9 |

10 | 11 |

12 | 13 | ## Usage 14 | 15 | To use `mulligan`, you must first build it by running `make`. Then, you can pass 16 | in the desired file for evaluation via the commandline. 17 | ``` 18 | $ make 19 | $ ./mulligan test.sml 20 | ``` 21 | 22 | This will take you into the `mulligan` interactive loop. 23 | 24 | `mulligan` may accept both `.sml`, `.sig`, `.fun` files, and `.cm` files, upon 25 | which it will traverse the sources, exporting the correct bindings on conclusion. 26 | `mulligan` does not currently support computing a dependency graph for CM dependencies, 27 | and thus always evaluates the source files _in order of listing_. 28 | 29 | ## Features 30 | 31 | Upon evaluating a particular program, `mulligan` takes the user into an 32 | interactive loop, in which the user can take a variety of actions to manipulate 33 | the program state. 34 | 35 | ![image](https://user-images.githubusercontent.com/49291449/173886267-d956cfea-6aa0-4db8-ad3d-5b8fde1905ec.png) 36 | 37 | The commands `step` and `prev` allow the user to step through execution, until 38 | the next "significant event". Significant events include stepping of a 39 | sub-expression, function application, and binding to an identifier, among 40 | others. Some of these may be adjusted in the loop. 41 | 42 | By default, while stepping `mulligan` will display the surrounding context until the 43 | nearest declaration site. This can make it confusing which expression is currently being focused, 44 | so the `reveal ` command allows one to see the surrounding context for the currently 45 | evaluated expresison, up to `` layers deep. 46 | 47 | `mulligan` also allows you to print the value bound to a particular identifier, 48 | via the command `print `. 49 | 50 | There are some internal settings which control the pretty-printer, primarily, 51 | which can be changed via `set = `. These are explained in more detail 52 | via `mulligan --help`. 53 | 54 | ## Breakpoints 55 | 56 | `mulligan` allows one to set _breakpoints_, which are particular events that 57 | should be skipped to, instead of needing to be stepped to manually. 58 | 59 | The command `break ` sets a breakpoint on the function value bound to the 60 | identifier ``, which will be triggered upon entering that function's body. 61 | It is worth noting that this is truly a breakpoint on that function _value_, as 62 | even if it is bound to another identifier and invoked, execution will be 63 | stopped. 64 | 65 | The command `break bind ` sets a breakpoint on binding values to the identifier 66 | ``. This will be triggered upon encountering a val declaration to that 67 | identifier. 68 | 69 | The command `run` allows one to skip to the end of program execution, or to the 70 | first breakpoint. The command `last` allows one to skip to the beginning of 71 | program execution, or to the last breakpoint that was tripped. 72 | 73 | The command `clear` clears all breakpoints. 74 | 75 | # Naming 76 | 77 | Naming has followed the same spirit as another SML project, [millet](https://github.com/azdavis/millet). 78 | 79 | `mulligan` has the letters "m" and "l" in it, in that order. So does "Standard 80 | ML". 81 | 82 | Also, this debugger allows you to rewind and redo evaluation of a program, and a 83 | mulligan is a term for redoing an action in a game. 84 | 85 | # License 86 | 87 | The included LICENSE file is the license for this project. 88 | -------------------------------------------------------------------------------- /src/cm_parser/parse/parser.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | type symbol = Symbol.symbol 8 | type result = ((symbol list * symbol list * symbol list) * CM_Token.elem list) * CM_Token.token list 9 | signature PARSER = 10 | sig 11 | val parse : char StreamStreamable.t -> (string list, result) Either.t 12 | 13 | val parse_string : string -> (string list, result) Either.t 14 | 15 | val parse_file : string -> (string list, result) Either.t 16 | 17 | val parse_file_to_string : string -> string 18 | end 19 | 20 | structure CM_Parser :> PARSER = 21 | struct 22 | structure S = Stream 23 | 24 | type symbol = Symbol.symbol 25 | 26 | fun identity x = x 27 | fun null () = [] 28 | fun sing x = [x] 29 | fun pair (x, y) = [x, y] 30 | 31 | val option_to_bool = fn 32 | SOME _ => true 33 | | NONE => false 34 | 35 | fun nyi () = () 36 | fun assert_fvalbinds_valid _ = nyi () 37 | fun assert_valbinds_valid _ _ = nyi () 38 | fun assert_valid_precedence _ = nyi () 39 | 40 | structure Arg = 41 | struct 42 | datatype terminal = datatype CM_Token.token 43 | 44 | datatype elem = datatype CM_Token.elem 45 | 46 | type files = elem list 47 | type symbol = symbol 48 | 49 | datatype export = 50 | STRUCT of symbol | SIG of symbol | FUN of symbol 51 | 52 | type exports = symbol list * symbol list * symbol list 53 | 54 | val functor_export = FUN 55 | val signature_export = SIG 56 | val structure_export = STRUCT 57 | 58 | fun nil_exports () = ([], [], []) 59 | fun cons_exports (export, (l1, l2, l3)) = 60 | case export of 61 | STRUCT s => (s :: l1, l2, l3) 62 | | SIG s => (l1, s :: l2, l3) 63 | | FUN s => (l1, l2, s :: l3) 64 | 65 | val nil_files = null 66 | val cons_files = op:: 67 | 68 | type main = (symbol list * symbol list * symbol list) * files 69 | val main_prog = identity 70 | 71 | exception Error of CM_Token.token StreamStreamable.t 72 | fun error x = Error x 73 | end 74 | 75 | (* Sidestepping the NJ extension so it can parse itself. *) 76 | structure Input = 77 | struct 78 | structure Streamable = StreamStreamable 79 | structure Arg = Arg 80 | end 81 | 82 | structure ParseMain = 83 | ParserFun (Input) 84 | 85 | fun parse cs = 86 | let 87 | val (elems, stream) = ParseMain.parse (CM_Lexer.lex cs) 88 | in 89 | Either.INR (elems, Stream.toList stream) 90 | end 91 | handle Arg.Error x => Either.INL (List.map CM_Token.token_to_string 92 | (Stream.toList x)) 93 | 94 | fun parse_string s = parse (Stream.fromList (String.explode s)) 95 | 96 | fun parse_file s = 97 | let 98 | val instream = TextIO.openIn s 99 | val input = TextIO.inputAll instream 100 | in 101 | parse_string input 102 | end 103 | 104 | fun parse_file_to_string s = 105 | case parse_file s of 106 | Either.INL _ => raise Fail "Failed to parse!" 107 | | Either.INR (((l1, l2, l3), elems), _) => 108 | String.concatWith ", " 109 | (List.map (fn s => "structure " ^ s) (List.map Symbol.toValue l1)) ^ "\n" 110 | ^ String.concatWith ", " 111 | (List.map (fn s => "signature " ^ s) (List.map Symbol.toValue l2)) ^ "\n" 112 | ^ String.concatWith ", " 113 | (List.map (fn s => "functor " ^ s) (List.map Symbol.toValue l3)) ^ "\n" 114 | ^ String.concatWith " " (List.map CM_Token.elem_to_string elems) 115 | end 116 | -------------------------------------------------------------------------------- /src/directive_parser/parse/parser.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | open Directive 8 | structure S = Stream 9 | 10 | (*****************************************************************************) 11 | (* Prelude *) 12 | (*****************************************************************************) 13 | (* A parser for "directives", which are commands that the debugger top-level 14 | recognizes. 15 | *) 16 | 17 | (*****************************************************************************) 18 | (* Types *) 19 | (*****************************************************************************) 20 | 21 | type result = Directive.t * DToken.t list 22 | 23 | (*****************************************************************************) 24 | (* Exceptions *) 25 | (*****************************************************************************) 26 | 27 | exception ParseFail of string 28 | 29 | (*****************************************************************************) 30 | (* Signature *) 31 | (*****************************************************************************) 32 | 33 | signature PARSER = 34 | sig 35 | val parse : char StreamStreamable.t -> (string list, result) either 36 | 37 | val parse_string : string -> (string list, result) either 38 | 39 | val parse_file : string -> (string list, result) either 40 | 41 | val parse_exn : string -> Directive.t 42 | val parse_opt : string -> Directive.t option 43 | end 44 | 45 | (*****************************************************************************) 46 | (* Parser actions *) 47 | (*****************************************************************************) 48 | 49 | structure Arg = 50 | struct 51 | open Directive 52 | 53 | type symbol = Symbol.symbol 54 | 55 | fun identity x = x 56 | fun null x = fn () => x 57 | fun sing x = [x] 58 | fun pair (x, y) = [x, y] 59 | 60 | datatype terminal = datatype DToken.t 61 | 62 | type int = int 63 | type symbol = symbol 64 | type longid = symbol list 65 | type directive = Directive.t 66 | 67 | val main = identity 68 | 69 | fun num_reveal i = Reveal (SOME i) 70 | fun num_prev i = Prev (SOME i) 71 | val bare_reveal = null (Reveal NONE) 72 | val stop = null Stop 73 | val step = null Step 74 | val evaluate = null Evaluate 75 | val run = null Run 76 | val prev = null (Prev NONE) 77 | fun break_fn s = BreakFn s 78 | fun bare_clear () = Clear NONE 79 | fun sym_clear s = Clear (SOME s) 80 | fun sym_print s = Print s 81 | fun break_bind s = 82 | case s of 83 | [s] => BreakBind s 84 | | _ => raise ParseFail "Cannot break bind on longid." 85 | fun value_ident longid = 86 | case longid of 87 | [s] => Directive.VALUE s 88 | | _ => raise ParseFail "Value cannot be empty or long identifier." 89 | fun value_num num = Directive.NUM num 90 | fun change_setting (s, v) = 91 | case s of 92 | [s] => Set (s, v) 93 | | _ => raise ParseFail "Setting cannot be empty or long identifier." 94 | fun report s = 95 | case s of 96 | [s] => Report s 97 | | _ => raise ParseFail "Cannot report on longid." 98 | fun bare_last () = Last NONE 99 | fun num_last i = Last (SOME i) 100 | val do_help = null Help 101 | val typeof_id = TypeOf 102 | 103 | exception Error of DToken.t StreamStreamable.t 104 | fun error x = Error x 105 | end 106 | 107 | (*****************************************************************************) 108 | (* Entry point *) 109 | (*****************************************************************************) 110 | 111 | structure DirectiveParser :> PARSER = 112 | struct 113 | structure ParseMain = 114 | ParserFun (structure Streamable = StreamStreamable structure Arg = Arg) 115 | 116 | fun parse cs = 117 | let 118 | val (elems, stream) = ParseMain.parse (Lexer.lex cs) 119 | in 120 | INR (elems, Stream.toList stream) 121 | end 122 | handle Arg.Error x => INL (List.map DToken.to_string 123 | (Stream.toList x)) 124 | 125 | fun parse_string s = parse (Stream.fromList (String.explode s)) 126 | 127 | fun parse_file s = 128 | let 129 | val instream = TextIO.openIn s 130 | val input = TextIO.inputAll instream 131 | in 132 | parse_string input 133 | end 134 | 135 | fun parse_opt cs = 136 | ( case parse (Stream.fromList (String.explode cs)) of 137 | INL _ => NONE 138 | | INR (elems, []) => SOME elems 139 | | INR _ => NONE 140 | ) handle ParseFail s => 141 | ( print ("Parse failure: " ^ s ^ "\n") 142 | ; NONE 143 | ) 144 | 145 | fun parse_exn cs = 146 | case parse_opt cs of 147 | NONE => raise Fail "failed to parse" 148 | | SOME ans => ans 149 | end 150 | -------------------------------------------------------------------------------- /test/snapshots.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | open Printf 8 | structure TF = TestFramework 9 | structure TC = TerminalColors 10 | 11 | (*****************************************************************************) 12 | (* Prelude *) 13 | (*****************************************************************************) 14 | (* Snapshot testing for `mulligan`. 15 | It's best to have a testing framework that can enforce that evaluation 16 | traces stay the same. 17 | This way, we'll know if a bug induces some unwanted behavior that isn't 18 | purely extensional. 19 | *) 20 | 21 | val cmd_ext = "cmds" 22 | val trace_ext = "trace" 23 | val sml_ext = "sml" (* who would have guessed *) 24 | val snapshot_dir = "test/snapshots" 25 | 26 | (*****************************************************************************) 27 | (* Helpers *) 28 | (*****************************************************************************) 29 | 30 | (* This function lets us run a thunk with stdout and stderr 31 | * redirected to another file. 32 | * If that file doesn't exist, it's created. 33 | * In particular, we can use this to pipe the debugger's output to a trace file. 34 | *) 35 | fun redirect_to_file file f = 36 | let 37 | (* these duplicate stdout and stderr's file descriptors, so that we 38 | * can set back to them once we change the real stdout and stderr 39 | *) 40 | val stdout_fd = Posix.IO.dup Posix.FileSys.stdout 41 | val stderr_fd = Posix.IO.dup Posix.FileSys.stderr 42 | 43 | 44 | val file_fd = 45 | Posix.FileSys.createf 46 | ( file 47 | , Posix.FileSys.O_WRONLY 48 | , Posix.FileSys.O.flags [Posix.FileSys.O.trunc] 49 | , Posix.FileSys.S.flags [Posix.FileSys.S.irwxu] 50 | ) 51 | in 52 | ( Posix.IO.dup2 { old = file_fd, new = Posix.FileSys.stdout } 53 | ; Posix.IO.dup2 { old = file_fd, new = Posix.FileSys.stderr } 54 | ; f () 55 | ; Posix.IO.dup2 { old = stdout_fd, new = Posix.FileSys.stdout } 56 | ; Posix.IO.dup2 { old = stderr_fd, new = Posix.FileSys.stderr } 57 | ) 58 | end 59 | 60 | fun parse_commands_file cmd_file = 61 | IO.cat cmd_file 62 | |> List.map DirectiveParser.parse_opt 63 | |> opt_all 64 | 65 | fun diff_strings s1 s2 = 66 | Common.with_file "diff1.txt" s1 (fn fd1 => 67 | Common.with_file "diff2.txt" s2 (fn fd2 => 68 | let 69 | val () = redirect_to_file "diff_output.txt" (fn () => 70 | OS.Process.system "diff diff1.txt diff2.txt" 71 | ) 72 | 73 | val instream = TextIO.openIn "diff_output.txt" 74 | in 75 | TextIO.inputAll instream 76 | end 77 | ) 78 | ) 79 | 80 | (*****************************************************************************) 81 | (* Implementation *) 82 | (*****************************************************************************) 83 | 84 | structure Snapshots = 85 | struct 86 | 87 | fun test_of_file cmd_file = 88 | let 89 | val trace_file = OS.Path.base cmd_file ^ "." ^ trace_ext 90 | val prog_file = OS.Path.base cmd_file ^ "." ^ sml_ext 91 | 92 | val commands = parse_commands_file cmd_file 93 | 94 | val trace_contents = 95 | if file_exists trace_file then 96 | String.concat (IO.cat trace_file) 97 | else 98 | "" 99 | 100 | fun test_fn _ = 101 | case commands of 102 | NONE => 103 | TF.assert_failure 104 | <| spf (`"Failed to parse command file "fs"") (OS.Path.file cmd_file) 105 | | SOME commands => 106 | let 107 | (* reset state between tests! *) 108 | val () = FreshSym.reset () 109 | 110 | val config = 111 | { test_mode = true 112 | , skipping = false 113 | , print_flag = true 114 | (* Snapshot output should be uncolored, so that the trace 115 | * files are actually human-readable. 116 | *) 117 | , colored_output = false 118 | , commands = commands 119 | } 120 | 121 | (* This will overwrite the existing trace file. 122 | * It would be nice to not be side-effecting, and instead 123 | * merely inform that the tests have changed, but in all honesty 124 | * I usually just use version control to reset the files anyways. 125 | * It's more convenient to me to just alter by default. 126 | *) 127 | val () = 128 | redirect_to_file trace_file (fn () => 129 | Run.run config 130 | (Source.loadFromFile (FilePath.fromUnixPath prog_file)) 131 | (Basis.initial ()) 132 | ) 133 | 134 | val new_trace_contents = String.concat (IO.cat trace_file) 135 | 136 | val diff = diff_strings trace_contents new_trace_contents 137 | in 138 | if trace_contents = new_trace_contents then 139 | () 140 | else 141 | TF.assert_failure 142 | <| spf (`"Trace contents have changed -- was:\n"fs"\nnow:\n"fs"\ndiff:\n"fs"") 143 | trace_contents 144 | new_trace_contents 145 | diff 146 | end 147 | in 148 | TF.mk_test (OS.Path.file cmd_file, test_fn) 149 | end 150 | 151 | (* Runs from the `mulligan` directory. 152 | *) 153 | fun run () = 154 | let 155 | val cmd_files = 156 | files_of_directory snapshot_dir 157 | |> List.filter (fn path => OS.Path.ext path = SOME cmd_ext) 158 | in 159 | cmd_files 160 | |> List.map test_of_file 161 | |> (fn test => TF.mk_suite ("snapshots", test)) 162 | |> TF.run 163 | end 164 | end 165 | -------------------------------------------------------------------------------- /src/util/PrettySimpleDoc.sml: -------------------------------------------------------------------------------- 1 | (** Copyright (c) 2020 Sam Westrick 2 | * 3 | * See the file LICENSE for details. 4 | *) 5 | 6 | structure PrettySimpleDoc :> 7 | sig 8 | type doc 9 | type t = doc 10 | 11 | val empty: doc 12 | val text: TerminalColors.color -> string -> doc 13 | 14 | val bold: doc -> doc 15 | 16 | val beside: doc * doc -> doc 17 | val aboveOrSpace: doc * doc -> doc 18 | val aboveOrBeside: doc * doc -> doc 19 | 20 | val space: doc 21 | val softspace: doc 22 | val group: doc -> doc 23 | 24 | val pretty: bool -> {ribbonFrac: real, maxWidth: int} -> doc -> string 25 | val toString: bool -> doc -> string 26 | end = 27 | struct 28 | 29 | structure TC = TerminalColors 30 | 31 | (** for Space and Above, the boolean indicates whether or not to 32 | * keep space when undone by group. 33 | *) 34 | datatype doc = 35 | Empty 36 | | Space of bool 37 | | Text of string * TerminalColors.color * bool 38 | | Beside of doc * doc 39 | | Above of bool * doc * doc 40 | | Choice of {flattened: (bool * doc * int * bool), normal: doc} 41 | 42 | 43 | type t = doc 44 | 45 | 46 | val empty = Empty 47 | val space = Space true 48 | val softspace = Space false 49 | val text = fn color => fn s => Text (s, color, false) 50 | 51 | fun bold doc = 52 | case doc of 53 | Empty => doc 54 | | Space _ => doc 55 | | Text (s, c1, _) => Text (s, c1, true) 56 | | Beside (d1, d2) => 57 | Beside (bold d1, bold d2) 58 | | Above (b, d1, d2) => 59 | Above (b, bold d1, bold d2) 60 | | Choice {flattened = (b, d, i, b2), normal} => 61 | Choice { flattened = (b, bold d, i, b2) 62 | , normal = bold normal 63 | } 64 | 65 | fun beside (doc1, doc2) = 66 | case (doc1, doc2) of 67 | (Empty, _) => doc2 68 | | (_, Empty) => doc1 69 | | _ => Beside (doc1, doc2) 70 | 71 | 72 | fun above' withSpace (doc1, doc2) = 73 | case (doc1, doc2) of 74 | (Empty, _) => doc2 75 | | (_, Empty) => doc1 76 | | _ => Above (withSpace, doc1, doc2) 77 | 78 | val aboveOrSpace = above' true 79 | val aboveOrBeside = above' false 80 | 81 | fun flatten doc = 82 | let 83 | (** Returns (space-before?, flattened, flattened size, space-after?) *) 84 | fun loop doc = 85 | case doc of 86 | Empty => 87 | (false, Empty, 0, false) 88 | | Space keepSpace => 89 | (keepSpace, Empty, 0, keepSpace) 90 | | Text (str, color, color2) => 91 | (false, Text (str, color, color2), String.size str, false) 92 | | Beside (d1, d2) => 93 | loopBeside (d1, d2) 94 | | Above (withSpace, d1, d2) => 95 | if withSpace then 96 | loopBeside (d1, Beside (Space true, d2)) 97 | else 98 | loopBeside (d1, d2) 99 | | Choice {flattened, ...} => 100 | flattened 101 | 102 | and loopBeside (d1, d2) = 103 | let 104 | val (l1, flat1, sz1, r1) = loop d1 105 | val (l2, flat2, sz2, r2) = loop d2 106 | 107 | (** Beside(flat1, flat2), but put a space between if 108 | * necessary, and compute the size too. This might result in 109 | * spaces l or r on either side, if flat1 or flat2 is Empty 110 | *) 111 | val (l, m, sz, r) = 112 | case (flat1, r1 orelse l2, flat2) of 113 | (Empty, b, _) => 114 | (b, flat2, sz2, false) 115 | | (_, b, Empty) => 116 | (false, flat1, sz1, b) 117 | | (_, false, _) => 118 | (false, Beside (flat1, flat2), sz1+sz2, false) 119 | | _ => 120 | (false, Beside (flat1, Beside (Space true, flat2)), sz1+sz2+1, false) 121 | in 122 | ( l1 orelse l 123 | , m 124 | , sz 125 | , r2 orelse r 126 | ) 127 | end 128 | 129 | in 130 | loop doc 131 | end 132 | 133 | 134 | fun group doc = 135 | Choice {flattened = flatten doc, normal = doc} 136 | 137 | 138 | fun spaces count = 139 | CharVector.tabulate (count, fn _ => #" ") 140 | 141 | 142 | fun pretty b {ribbonFrac, maxWidth} inputDoc = 143 | let 144 | val ribbonWidth = 145 | Int.max (0, Int.min (maxWidth, 146 | Real.round (ribbonFrac * Real.fromInt maxWidth))) 147 | 148 | fun layout (lnStart, col, acc) doc : int * int * (string list) = 149 | case doc of 150 | Empty => (lnStart, col, acc) 151 | | Space _ => 152 | ( if lnStart = col then lnStart + 1 else lnStart 153 | , col + 1 154 | , " " :: acc 155 | ) 156 | | Text (str, color, b2) => 157 | ( lnStart 158 | , col + String.size str 159 | , if b then 160 | (if b2 then TC.bold else "") ^ TC.foreground color ^ str ^ TC.reset :: acc 161 | else 162 | str :: acc 163 | ) 164 | | Beside (doc1, doc2) => 165 | layout (layout (lnStart, col, acc) doc1) doc2 166 | | Above (_, doc1, doc2) => 167 | let 168 | val (_, _, acc) = layout (lnStart, col, acc) doc1 169 | val acc = spaces col :: "\n" :: acc 170 | in 171 | layout (lnStart, col, acc) doc2 172 | end 173 | | Choice {flattened = (_, flat, sz, _), normal} => 174 | let 175 | val widthOkay = col + sz <= maxWidth 176 | val ribbonOkay = (col - lnStart) + sz <= ribbonWidth 177 | in 178 | if widthOkay andalso ribbonOkay then 179 | layout (lnStart, col, acc) flat 180 | else 181 | layout (lnStart, col, acc) normal 182 | end 183 | 184 | val (_, _, strs) = layout (0, 0, []) inputDoc 185 | in 186 | String.concat (List.rev strs) 187 | end 188 | 189 | 190 | fun toString b t = pretty b {ribbonFrac = 0.5, maxWidth = 120} t 191 | 192 | end 193 | -------------------------------------------------------------------------------- /src/directive_parser/lex/lexer.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | open DToken 8 | open Error 9 | open Stream 10 | structure Table = SymbolHashTable 11 | 12 | (*****************************************************************************) 13 | (* Prelude *) 14 | (*****************************************************************************) 15 | (* A lexer for debugger commands, or "directives". 16 | *) 17 | 18 | (*****************************************************************************) 19 | (* Helpers *) 20 | (*****************************************************************************) 21 | 22 | fun revappend l1 l2 = 23 | (case l1 of 24 | x :: rest => 25 | revappend rest (x :: l2) 26 | | [] => l2) 27 | 28 | (*****************************************************************************) 29 | (* Signature *) 30 | (*****************************************************************************) 31 | 32 | signature LEXER = 33 | sig 34 | val lex : char Stream.stream -> DToken.t Stream.stream 35 | val lex_string : string -> DToken.t list 36 | val lex_file : string -> DToken.t list 37 | end 38 | 39 | (*****************************************************************************) 40 | (* Lexer actions *) 41 | (*****************************************************************************) 42 | 43 | structure Arg = 44 | struct 45 | structure Streamable = StreamStreamable 46 | 47 | type symbol = char 48 | val ord = Char.ord 49 | 50 | datatype tlex = LEX of char stream -> t 51 | withtype t = tlex -> int -> DToken.t front 52 | 53 | type self = { main : symbol Streamable.t -> t 54 | , primary : symbol Streamable.t -> t 55 | } 56 | type info = { match : symbol list, 57 | len : int, 58 | start : symbol Streamable.t, 59 | follow : symbol Streamable.t, 60 | self : self } 61 | 62 | val keywords_list = 63 | [ ("step", STEP) 64 | , ("s", STEP) 65 | , ("eval", EVALUATE) 66 | , ("evaluate", EVALUATE) 67 | , ("reveal", REVEAL) 68 | , ("stop", STOP) 69 | , ("set", SET) 70 | , ("prev", PREV) 71 | , ("breakbind", BREAKBIND) 72 | , ("breakfn", BREAKFN) 73 | , ("run", RUN) 74 | , ("r", RUN) 75 | , ("clear", CLEAR) 76 | , ("print", PRINT) 77 | , ("report", REPORT) 78 | , ("last", LAST) 79 | , ("help", HELP) 80 | , ("typeof", TYPEOF) 81 | ] 82 | 83 | val keywords : DToken.t Table.table = 84 | let 85 | val table : DToken.t Table.table = Table.table 60 86 | 87 | val () = 88 | List.app 89 | (fn (str, token) => Table.insert table (Symbol.fromValue str) token) 90 | keywords_list 91 | in 92 | table 93 | end 94 | 95 | fun identify table str = 96 | let 97 | val sym = Symbol.fromValue str 98 | in 99 | (case Table.find table sym of 100 | NONE => IDENT [sym] 101 | | SOME tok => tok 102 | ) 103 | end 104 | 105 | fun action f ({ match, len, follow, ...}: info) (k as LEX cont) pos = 106 | Cons (f (match, len, follow, pos), lazy (fn () => cont follow k (pos + len))) 107 | 108 | fun simple tok ({ follow, len, ...}: info) (k as LEX cont) 109 | pos = 110 | Cons (tok, lazy (fn () => cont follow k (pos + len))) 111 | 112 | fun enter_main ({ match, len, follow, self, ...}: info) (k as LEX _) pos = 113 | Cons (identify keywords (implode match), lazy (fn () => #main self follow k (pos + len))) 114 | 115 | val lex_bindable = 116 | action 117 | (fn (match, _, _, _) => IDENT [Symbol.fromValue (implode match)]) 118 | 119 | fun longidentify curr store match = 120 | let 121 | fun process chars = 122 | Symbol.fromValue (String.implode (List.rev chars)) 123 | in 124 | case match of 125 | [] => 126 | (case curr of 127 | [] => IDENT (List.rev store) 128 | | _ => IDENT (List.rev (process curr :: store)) 129 | ) 130 | | #"." :: rest => 131 | longidentify [] (process curr :: store) rest 132 | | ch :: rest => 133 | longidentify (ch :: curr) store rest 134 | end 135 | 136 | val lex_longident = 137 | action 138 | (fn (match, _, _, _) => longidentify [] [] match) 139 | 140 | val lex_number = 141 | action 142 | (fn (match, _, follow, pos) => 143 | (case Int.fromString (implode match) of 144 | SOME n => NUM n 145 | | NONE => 146 | err 147 | (LexError 148 | { reason = "failed to lex number" 149 | , pos = pos 150 | , rest = Stream.toList follow 151 | } 152 | ) 153 | ) 154 | ) 155 | 156 | val equal = simple EQUAL 157 | 158 | fun skip ({ len, follow, self, ...} : info) (k as LEX _) pos = 159 | #main self follow k (pos + len) 160 | 161 | fun eof _ _ _ = 162 | Cons (EOF, eager Nil) 163 | 164 | fun error ({follow, ...}: info) _ pos = 165 | err 166 | (LexError 167 | { reason = "illegal lexeme" 168 | , pos = pos 169 | , rest = Stream.toList follow 170 | } 171 | ) 172 | end 173 | 174 | (*****************************************************************************) 175 | (* Implementation *) 176 | (*****************************************************************************) 177 | 178 | structure Lexer :> LEXER = 179 | struct 180 | structure LexMain = 181 | LexMainFun (structure Streamable = StreamStreamable structure Arg = Arg) 182 | 183 | fun doLex f s = lazy (fn () => f s (Arg.LEX f) 0) 184 | 185 | fun lex s = doLex LexMain.primary s 186 | 187 | fun lex_string s = Stream.toList (lex (Stream.fromList (String.explode s))) 188 | 189 | fun lex_file s = lex_string (TextIO.inputAll (TextIO.openIn s)) 190 | end 191 | -------------------------------------------------------------------------------- /test/snapshots/div_exn.trace: -------------------------------------------------------------------------------- 1 | ========================================================== 2 | Evaluating file test/snapshots/div_exn.sml... 3 | ---------------------------------------------------------- 4 | 5 | Loaded program: 6 | fun f 0 = 1 div 0 | f n = 1 + f (n - 1) 7 | fun g 0 = 1 mod 0 | g n = 1 + g (n - 1) 8 | val _ = (SOME (f 4)) handle Div => NONE 9 | val _ = (SOME (g 4)) handle Div => NONE 10 | 11 | - ==> 12 | val _ = (SOME (f 4)) handle Div => NONE 13 | 14 | - ==> 15 | val _ = 16 | (SOME (case 4 of 0 => 1 div 0 | n => 1 + f (n - 1))) handle 17 | Div => NONE 18 | 19 | - ==> 20 | val _ = (SOME (1 + f (4 - 1))) handle Div => NONE 21 | 22 | - ==> 23 | val _ = 24 | ( SOME 25 | ( 1 + ( fn t0 => 26 | case t0 of 27 | 0 => 1 div 0 28 | | n => 29 | 1 + f (n - 1) 30 | ) 31 | 3 32 | ) 33 | ) handle 34 | Div => NONE 35 | 36 | - ==> 37 | val _ = 38 | (SOME (1 + case 3 of 0 => 1 div 0 | n => 1 + f (n - 1))) handle 39 | Div => NONE 40 | 41 | - ==> 42 | val _ = (SOME (1 + 1 + f (3 - 1))) handle Div => NONE 43 | 44 | - ==> 45 | val _ = 46 | ( SOME 47 | ( 1 + 1 + ( fn t0 => 48 | case t0 of 49 | 0 => 1 div 0 50 | | n => 51 | 1 + f (n - 1) 52 | ) 53 | 2 54 | ) 55 | ) handle 56 | Div => NONE 57 | 58 | - ==> 59 | val _ = 60 | ( SOME 61 | ( 1 + 1 + case 2 of 62 | 0 => 1 div 0 63 | | n => 64 | 1 + f (n - 1) 65 | ) 66 | ) handle 67 | Div => NONE 68 | 69 | - ==> 70 | val _ = (SOME (1 + 1 + 1 + f (2 - 1))) handle Div => NONE 71 | 72 | - ==> 73 | val _ = 74 | ( SOME 75 | ( 1 + 1 + 1 + ( fn t0 => 76 | case t0 of 77 | 0 => 1 div 0 78 | | n => 79 | 1 + f (n - 1) 80 | ) 81 | 1 82 | ) 83 | ) handle 84 | Div => NONE 85 | 86 | - ==> 87 | val _ = 88 | ( SOME 89 | ( 1 + 1 + 1 + case 1 of 90 | 0 => 1 div 0 91 | | n => 92 | 1 + f (n - 1) 93 | ) 94 | ) handle 95 | Div => NONE 96 | 97 | - ==> 98 | val _ = 99 | (SOME (1 + 1 + 1 + 1 + f (1 - 1))) handle 100 | Div => NONE 101 | 102 | - ==> 103 | val _ = 104 | ( SOME 105 | ( 1 + 1 + 1 + 1 + ( fn t0 => 106 | case t0 of 107 | 0 => 1 div 0 108 | | n => 109 | 1 + f (n - 1) 110 | ) 111 | 0 112 | ) 113 | ) handle 114 | Div => NONE 115 | 116 | - ==> 117 | val _ = 118 | ( SOME 119 | ( 1 + 1 + 1 + 1 + case 0 of 120 | 0 => 1 div 0 121 | | n => 122 | 1 + f (n - 1) 123 | ) 124 | ) handle 125 | Div => NONE 126 | 127 | - ==> 128 | val _ = (SOME (1 + 1 + 1 + 1 + 1 div 0)) handle Div => NONE 129 | 130 | - ==> 131 | val _ = NONE 132 | 133 | - ==> 134 | val _ = (SOME (g 4)) handle Div => NONE 135 | 136 | - ==> 137 | val _ = 138 | (SOME (case 4 of 0 => 1 mod 0 | n => 1 + g (n - 1))) handle 139 | Div => NONE 140 | 141 | - ==> 142 | val _ = (SOME (1 + g (4 - 1))) handle Div => NONE 143 | 144 | - ==> 145 | val _ = 146 | ( SOME 147 | ( 1 + ( fn t1 => 148 | case t1 of 149 | 0 => 1 mod 0 150 | | n => 151 | 1 + g (n - 1) 152 | ) 153 | 3 154 | ) 155 | ) handle 156 | Div => NONE 157 | 158 | - ==> 159 | val _ = 160 | (SOME (1 + case 3 of 0 => 1 mod 0 | n => 1 + g (n - 1))) handle 161 | Div => NONE 162 | 163 | - ==> 164 | val _ = (SOME (1 + 1 + g (3 - 1))) handle Div => NONE 165 | 166 | - ==> 167 | val _ = 168 | ( SOME 169 | ( 1 + 1 + ( fn t1 => 170 | case t1 of 171 | 0 => 1 mod 0 172 | | n => 173 | 1 + g (n - 1) 174 | ) 175 | 2 176 | ) 177 | ) handle 178 | Div => NONE 179 | 180 | - ==> 181 | val _ = 182 | ( SOME 183 | ( 1 + 1 + case 2 of 184 | 0 => 1 mod 0 185 | | n => 186 | 1 + g (n - 1) 187 | ) 188 | ) handle 189 | Div => NONE 190 | 191 | - ==> 192 | val _ = (SOME (1 + 1 + 1 + g (2 - 1))) handle Div => NONE 193 | 194 | - ==> 195 | val _ = 196 | ( SOME 197 | ( 1 + 1 + 1 + ( fn t1 => 198 | case t1 of 199 | 0 => 1 mod 0 200 | | n => 201 | 1 + g (n - 1) 202 | ) 203 | 1 204 | ) 205 | ) handle 206 | Div => NONE 207 | 208 | - ==> 209 | val _ = 210 | ( SOME 211 | ( 1 + 1 + 1 + case 1 of 212 | 0 => 1 mod 0 213 | | n => 214 | 1 + g (n - 1) 215 | ) 216 | ) handle 217 | Div => NONE 218 | 219 | - ==> 220 | val _ = 221 | (SOME (1 + 1 + 1 + 1 + g (1 - 1))) handle 222 | Div => NONE 223 | 224 | - ==> 225 | val _ = 226 | ( SOME 227 | ( 1 + 1 + 1 + 1 + ( fn t1 => 228 | case t1 of 229 | 0 => 1 mod 0 230 | | n => 231 | 1 + g (n - 1) 232 | ) 233 | 0 234 | ) 235 | ) handle 236 | Div => NONE 237 | 238 | - ==> 239 | val _ = 240 | ( SOME 241 | ( 1 + 1 + 1 + 1 + case 0 of 242 | 0 => 1 mod 0 243 | | n => 244 | 1 + g (n - 1) 245 | ) 246 | ) handle 247 | Div => NONE 248 | 249 | - ==> 250 | val _ = (SOME (1 + 1 + 1 + 1 + 1 mod 0)) handle Div => NONE 251 | 252 | - ==> 253 | val _ = NONE 254 | 255 | - Program evaluation finished. 256 | 257 | -------------------------------------------------------------------------------- /src/top/top.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | open Error 8 | structure TC = TerminalColors 9 | 10 | (*****************************************************************************) 11 | (* Prelude *) 12 | (*****************************************************************************) 13 | (* The top-level entry point for the `mulligan` program. 14 | * 15 | * This is where everything starts. 16 | * 17 | * Here, we first handle all the command-line arguments before dispatching to 18 | * the actual interactive loop. 19 | *) 20 | 21 | (*****************************************************************************) 22 | (* File-handling logic *) 23 | (*****************************************************************************) 24 | 25 | (* This function deals with recursing into all the dependencies of a CM 26 | * file, or actually evaluating the source text of an SML program. 27 | *) 28 | fun handle_file config cur_path filename ctx = 29 | let 30 | val filename = 31 | if OS.Path.isAbsolute filename then 32 | filename 33 | else 34 | OS.Path.mkCanonical (OS.Path.concat (cur_path, filename)) 35 | 36 | val dir = OS.Path.dir filename 37 | in 38 | ( case (String.sub (filename, 0), OS.Path.ext filename) of 39 | (_, NONE) => 40 | warn ctx (InvalidExt filename) 41 | | (#"$", _) => 42 | warn ctx (GeneralWarning { filename = filename 43 | , reason = "Anchors not yet supported." 44 | , span = NONE 45 | } 46 | ) 47 | (* Given an `sml`, `sig`, or `fun` file, then we run the debugger! 48 | *) 49 | | (_, SOME ("sml" | "sig" | "fun")) => 50 | Run.run config 51 | (Source.loadFromFile (FilePath.fromUnixPath filename)) 52 | ctx 53 | (* On a `cm` file, we transitively parse the dependencies, and handle 54 | * the files described within. 55 | *) 56 | | (_, SOME "cm") => 57 | (case CM_Parser.parse_file filename of 58 | INL rest => err (ParseError (filename, rest)) 59 | | INR (((structs, sigs, functors), sources), []) => 60 | let 61 | val ctx' = 62 | List.foldl 63 | (fn (source, ctx) => 64 | handle_file config dir 65 | ( case source of 66 | CM_Token.PATH sym => Symbol.toValue sym 67 | | CM_Token.STRING s => s 68 | ) 69 | ctx 70 | ) 71 | ctx 72 | sources 73 | in 74 | Context.cm_export filename ctx ctx' 75 | {structs=structs, sigs=sigs, functors=functors} 76 | end 77 | | Either.INR (_, rest) => 78 | err (ParseError (filename, List.map CM_Token.token_to_string rest)) 79 | ) 80 | | _ => warn ctx (InvalidExt filename) 81 | ) 82 | handle exn => file_error_handler filename exn 83 | end 84 | 85 | and file_error_handler path exn = 86 | case exn of 87 | Signal (SigError error) => 88 | let 89 | val error_msg = 90 | surround TC.softred <| 91 | (case error of 92 | ParseError (filename, rest) => 93 | "Parse failure\n" 94 | ^ lightblue filename ^ ": Cannot parse evaluated file\n" 95 | ^ "Remaining tokens: " ^ lightblue (String.concatWith " " (List.take (rest, 20))) ^ "\n" 96 | (* TODO: why do I not use the reason here? *) 97 | | LexError {reason = _, pos = _, rest} => 98 | "Lex failure\n" 99 | ^ lightblue path ^ ": Cannot lex evaluated file\n" 100 | ^ "Remaining tokens: " 101 | ^ lightblue (String.concatWith " " (List.map Char.toString (List.take (rest, 20)))) ^ "\n" 102 | | EvalError reason => 103 | "Evaluation error\n" 104 | ^ mk_reason reason 105 | | UserError reason => 106 | "User-induced error\n" 107 | ^ mk_reason reason 108 | | InvalidProgramError reason => 109 | "Invalid program\n" 110 | ^ lightblue path ^ ": Error handling file\n" 111 | ^ mk_reason reason 112 | | TypeError {reason} => 113 | "Type error\n" 114 | ^ mk_reason reason 115 | ) 116 | in 117 | ( print <| red "Error" ^ ": " ^ error_msg 118 | ; OS.Process.exit OS.Process.failure 119 | ) 120 | end 121 | (* I copy pasted this code. 122 | * Hopefully it doesn't happen. If it does, then I may have to update the parser. 123 | *) 124 | | ParseSMLError.Error e => 125 | ( TCS.print 126 | (ParseSMLError.show {highlighter = SOME SyntaxHighlighter.fuzzyHighlight} e) 127 | ; if List.null (MLton.Exn.history exn) then () else 128 | print ("\n" ^ String.concat (List.map (fn ln => ln ^ "\n") (MLton.Exn.history exn))) 129 | ; OS.Process.exit OS.Process.failure 130 | ) 131 | | _ => raise exn 132 | 133 | (*****************************************************************************) 134 | (* Implementation *) 135 | (*****************************************************************************) 136 | 137 | structure Top = 138 | struct 139 | fun run () = 140 | let 141 | val args = CommandLineArgs.positional () 142 | val doHelp = CommandLineArgs.parseFlag "help" 143 | val no_color = CommandLineArgs.parseBool "no-color" false 144 | 145 | val config = 146 | { test_mode = false 147 | , skipping = false 148 | , print_flag = true 149 | , colored_output = not no_color 150 | , commands = [] : Directive.t list 151 | } 152 | in 153 | if doHelp orelse List.null args then 154 | ( print Run.help_message 155 | ; OS.Process.exit OS.Process.success 156 | ) 157 | else 158 | ( List.foldl 159 | (fn (filename, ctx) => 160 | handle_file config "" filename ctx 161 | ) 162 | (Basis.initial ()) 163 | args 164 | ; OS.Process.exit OS.Process.success 165 | ) 166 | end 167 | 168 | end 169 | 170 | (*****************************************************************************) 171 | (* Entry point *) 172 | (*****************************************************************************) 173 | 174 | (* let's go! *) 175 | val _ = Top.run () 176 | -------------------------------------------------------------------------------- /src/util/test_framework.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | structure TC = TerminalColors 8 | 9 | (*****************************************************************************) 10 | (* Prelude *) 11 | (*****************************************************************************) 12 | (* This is a test framework for generalized tests. 13 | *) 14 | 15 | (*****************************************************************************) 16 | (* Types *) 17 | (*****************************************************************************) 18 | 19 | (* This context type is meant to include anything that should be visible from 20 | * within the relevant tests. 21 | *) 22 | type context = 23 | { path : string 24 | , test_name : string 25 | } 26 | 27 | type test_modifier = 28 | (* A function to be called after the test, depending on failure or success. 29 | *) 30 | { after_fn : bool -> unit 31 | } 32 | 33 | datatype test = 34 | Test of string * (context -> unit) * test_modifier option 35 | | Suite of string * test list 36 | 37 | (*****************************************************************************) 38 | (* Helpers *) 39 | (*****************************************************************************) 40 | 41 | val border = "============================================" 42 | val border2 = "--------------------------------------------" 43 | 44 | val base_context = 45 | { path = "" 46 | , test_name = "" 47 | } 48 | 49 | fun set_test_name (ctx : context) new = 50 | { path = #path ctx 51 | , test_name = new 52 | } 53 | 54 | infix ++ 55 | fun (x, y) ++ (a, b) = (x + a, y + b) 56 | 57 | fun red s = TC.foreground TC.softred ^ s ^ TC.reset 58 | fun lightblue s = TC.foreground TC.lightblue ^ s ^ TC.reset 59 | fun green s = TC.foreground TC.softgreen ^ s ^ TC.reset 60 | 61 | (*****************************************************************************) 62 | (* Signature *) 63 | (*****************************************************************************) 64 | 65 | signature TESTFRAMEWORK = 66 | sig 67 | type context 68 | type test 69 | 70 | val mk_test : string * (context -> unit) -> test 71 | val mk_suite : string * test list -> test 72 | 73 | val >:: : string * (context -> unit) -> test 74 | val >::: : string * test list -> test 75 | 76 | val modify_test : test_modifier -> test -> test 77 | 78 | val get_test_name : context -> string 79 | 80 | val assert_equal : ('a -> string) option -> ('a * 'a -> bool) -> 'a * 'a -> unit 81 | val assert_failure : string -> 'a 82 | val assert_bool : string -> bool -> unit 83 | 84 | val run : test -> unit 85 | end 86 | 87 | (*****************************************************************************) 88 | (* Implementation *) 89 | (*****************************************************************************) 90 | 91 | structure TestFramework : TESTFRAMEWORK = 92 | struct 93 | exception TestFail of string 94 | 95 | type context = context 96 | 97 | datatype test = datatype test 98 | 99 | fun mk_test (s, test) = Test (s, test, NONE) 100 | val mk_suite = Suite 101 | 102 | val >:: = mk_test 103 | val >::: = mk_suite 104 | 105 | (* Modify a test or test suite with a modifier. 106 | * A use case for this, for instance, is snapshot testing, when you may need 107 | * to side-effectively update the snapshots on failure. 108 | *) 109 | fun modify_test modifier test = 110 | case test of 111 | Test (s, test, _) => Test (s, test, SOME modifier) 112 | | Suite (s, tests) => Suite (s, List.map (fn test => modify_test modifier test) tests) 113 | 114 | fun get_test_name (ctx : context) = #test_name ctx 115 | 116 | fun assert_equal print_fn eq_fn (x, y) = 117 | if eq_fn (x, y) then 118 | () 119 | else 120 | raise TestFail 121 | ( case print_fn of 122 | NONE => "Expected equality" 123 | | SOME print_fn => 124 | spf (`"Expected equality: got "fs" and "fs"") (print_fn x) (print_fn y) 125 | ) 126 | 127 | fun assert_failure s = 128 | raise TestFail s 129 | 130 | fun assert_bool s b = 131 | if b then () 132 | else 133 | raise TestFail s 134 | 135 | fun run test = 136 | let 137 | fun handle_test ctx (test_name, test_fn, modifier) = 138 | let 139 | val ctx = set_test_name ctx test_name 140 | val passed = 141 | ( print ("Running test (" ^ lightblue test_name ^ ") ... ") 142 | ; test_fn ctx 143 | ; print (green "[PASS]\n") 144 | ; true 145 | ) 146 | handle TestFail s => 147 | ( print (red "[FAIL]\n") 148 | ; print (border ^ "\n") 149 | ; print (red "Failure: " ^ lightblue test_name ^ "\n\n") 150 | ; print (s ^ "\n") 151 | ; false 152 | ) 153 | in 154 | ( case modifier of 155 | NONE => () 156 | | SOME { after_fn } => after_fn passed 157 | ; if passed then 158 | (1, 0) 159 | else 160 | (0, 1) 161 | ) 162 | end 163 | 164 | fun run' ctx test = 165 | case test of 166 | Test test => handle_test ctx test 167 | | Suite (name, tests) => 168 | #1 169 | ( List.foldl 170 | (fn (test, (acc, num)) => 171 | let 172 | val ctx = 173 | { path = #path ctx ^ Int.toString num ^ ":" ^ name ^ "/" 174 | , test_name = "ERR" 175 | } 176 | in 177 | ( run' ctx test ++ acc 178 | , num + 1 179 | ) 180 | end 181 | ) 182 | ((0, 0), 0) 183 | tests 184 | ) 185 | 186 | (* !! here we run the tests !! 187 | *) 188 | val ((passed, failed), time) = 189 | with_time_str (fn () => run' base_context test) 190 | 191 | val test_name = 192 | case test of 193 | Test (s, _, _) => s 194 | | Suite (s, _) => s 195 | in 196 | ( print (border2 ^ "\n") 197 | ; print <| spf (`"Test: "fs"\n") (orange test_name) 198 | ; print <| spf (`"Ran: "fs" "fs" in: "fs" seconds.\n") 199 | (lightblue (Int.toString (passed + failed))) 200 | (if (passed + failed) = 1 then "test" else "tests") 201 | (lightblue time) 202 | ; if failed = 0 then 203 | print (green "All tests passed.\n") 204 | else 205 | ( print <| spf (`""fs": "fs" test cases.\n") (red "FAILED") (Int.toString failed) 206 | ; OS.Process.exit OS.Process.failure 207 | ) 208 | ) 209 | end 210 | end 211 | -------------------------------------------------------------------------------- /src/util/error.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | structure TC = TerminalColors 8 | 9 | (*****************************************************************************) 10 | (* Prelude *) 11 | (*****************************************************************************) 12 | (* Errors that may arise during execution. 13 | * 14 | * These include errors which occur during the static analyzing of the given 15 | * program, structural errors like invalid file targeting, and errors which 16 | * may arise due to invalid states of the dynamics. 17 | * 18 | * These are collected here, and should be handled gracefully by the top-level 19 | * runner. 20 | *) 21 | 22 | (*****************************************************************************) 23 | (* Types *) 24 | (*****************************************************************************) 25 | 26 | datatype warning = 27 | ParseWarning of (string * string list) 28 | | InvalidExt of string 29 | | InvalidFile of string 30 | | LexWarning of 31 | {filename : string, reason : string, pos : int, rest : char list} 32 | | GeneralWarning of 33 | { filename : string 34 | , reason : string 35 | , span : (int * int) option 36 | } 37 | 38 | datatype error = 39 | ParseError of (string * string list) 40 | | LexError of {reason : string, pos : int, rest : char list} 41 | | TypeError of {reason : string} 42 | | EvalError of string 43 | | UserError of string 44 | | InvalidProgramError of string 45 | 46 | datatype signal = SigError of error 47 | 48 | (*****************************************************************************) 49 | (* Helpers *) 50 | (*****************************************************************************) 51 | 52 | val border = "==========================================================\n" 53 | val border2 = "----------------------------------------------------------\n\n" 54 | 55 | fun relative_pos_of_charpos filename pos = 56 | let 57 | val instream = TextIO.openIn filename 58 | 59 | fun iterate line_num pos = 60 | case (TextIO.inputLine instream, pos) of 61 | (NONE, 0) => (line_num, 0) 62 | | (NONE, _) => raise Fail "error" 63 | | (SOME line, _) => 64 | let val length = String.size line in 65 | if pos - length < 0 then 66 | (line_num, pos) 67 | else 68 | iterate (line_num + 1) (pos - length) 69 | end 70 | val (line_num, pos) = iterate 1 pos 71 | in 72 | (TextIO.closeIn instream; (line_num, pos)) 73 | end 74 | 75 | (*****************************************************************************) 76 | (* Signature *) 77 | (*****************************************************************************) 78 | 79 | signature ERROR = 80 | sig 81 | 82 | datatype warning = datatype warning 83 | datatype error = datatype error 84 | datatype signal = datatype signal 85 | 86 | exception Signal of signal 87 | 88 | val warn : 'a -> warning -> 'a 89 | 90 | val err : (error -> 'a) 91 | 92 | val error_eq : (error * error) -> bool 93 | val show_error : error -> string 94 | 95 | val eval_err : string -> 'a 96 | val user_err : string -> 'a 97 | val prog_err : string -> 'a 98 | val type_err : string -> 'a 99 | 100 | val mk_reason : string -> string 101 | 102 | val surround : TerminalColors.color -> string -> string 103 | end 104 | 105 | (*****************************************************************************) 106 | (* Implementation *) 107 | (*****************************************************************************) 108 | 109 | structure Error :> ERROR = 110 | struct 111 | datatype warning = datatype warning 112 | datatype error = datatype error 113 | datatype signal = datatype signal 114 | 115 | exception Signal of signal 116 | 117 | fun source (filename, pos) = 118 | let 119 | val (line_num, offset) = relative_pos_of_charpos filename pos 120 | in 121 | spf (`""fs":"fs":"fs"") 122 | (lightblue filename) 123 | (lightblue (Int.toString line_num)) 124 | (lightblue (Int.toString offset)) 125 | end 126 | 127 | fun surround color s = TC.text color border ^ s ^ TC.text color border2 128 | 129 | fun warn x warning = 130 | let 131 | val warning_msg = 132 | case warning of 133 | ParseWarning (filename, rest) => 134 | spf (`"Parse error\n" 135 | fs": Failure to produce derived file, skipping...\nRemaining filestream: "fs"\n") 136 | (lightblue filename) 137 | (lightblue 138 | (String.substring 139 | (String.concatWith " " rest, 0, 25)) 140 | ) 141 | | (InvalidExt filename) => 142 | "Invalid extension\n" 143 | ^ lightblue filename 144 | ^ ": Expected .sml, .sig, .fun, or .cm extension instead.\n" 145 | 146 | | (InvalidFile filename) => 147 | spf (`"Invalid file\n" 148 | fs": Expected an extension to this file.\n") 149 | (lightblue filename) 150 | 151 | | (LexWarning {filename, reason, pos, rest}) => 152 | spf (`"Lex error\n" 153 | fs": "fs 154 | "\nRemaining token stream: "fs"\n") 155 | (source (filename, pos)) 156 | reason 157 | (String.concatWith " " 158 | (List.map Char.toString 159 | (List.take (rest, 25))) 160 | ) 161 | | GeneralWarning {filename, reason, span} => 162 | spf (`"\n"fs": "fs"\n") 163 | (case span of 164 | NONE => "" 165 | | SOME span => source (filename, # 1 span)) 166 | reason 167 | in 168 | ( print (surround TC.yellow (orange "Warning: " ^ warning_msg)) 169 | ; x 170 | ) 171 | end 172 | 173 | fun error_eq (error1, error2) = 174 | case (error1, error2) of 175 | (ParseError (s, strs), ParseError (s', strs')) => 176 | s = s' andalso ListPair.allEq (op=) (strs, strs') 177 | | ( LexError {reason, pos, rest} 178 | , LexError {reason = reason', pos = pos', rest = rest'} 179 | ) => 180 | reason = reason' andalso pos = pos' andalso ListPair.allEq (op=) 181 | (rest, rest') 182 | | (TypeError {reason}, TypeError {reason = reason'}) => 183 | reason = reason' 184 | | (EvalError s, EvalError s') 185 | | (UserError s, UserError s') 186 | | (InvalidProgramError s, InvalidProgramError s') => 187 | s = s' 188 | | _ => false 189 | 190 | fun show_error error = 191 | case error of 192 | LexError {reason, pos, ...} => lightblue (Int.toString pos) ^ ": " ^ reason 193 | | TypeError {reason, ...} => reason 194 | | ParseError (s, _) => s 195 | | EvalError s 196 | | UserError s 197 | | InvalidProgramError s => s 198 | 199 | 200 | fun err error = raise Signal (SigError error) 201 | 202 | fun eval_err s = raise Signal (SigError (EvalError s)) 203 | fun user_err s = raise Signal (SigError (UserError s)) 204 | fun prog_err s = raise Signal (SigError (InvalidProgramError s)) 205 | fun type_err s = raise Signal (SigError (TypeError {reason = s})) 206 | 207 | fun mk_reason s = lightblue "Reason" ^ ": " ^ s ^ "\n" 208 | end 209 | -------------------------------------------------------------------------------- /src/context/location.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* A location is how the debugger knows to pretty-print the AST while we are 11 | * evaluating it. 12 | * Because we use algebraic effects to carry out the evaluation of the AST, 13 | * we are never actually holding a value which corresponds to the in-progress 14 | * state of the AST during a given big step. 15 | 16 | * Because we want to print this intermediate state anyways, we store a stack 17 | * which contains the closest "layers" of the AST, from inside-out, which lets 18 | * us iterate over it while traversing our way to the outside of the program 19 | * in order to print the correct AST. 20 | 21 | * This does mean that we need to provide "holes" which signify where we 22 | * currently are in the AST, so we know where our current text fits into the 23 | * larger context. 24 | 25 | * Hence, the location type below, which re-lists some of the structures of 26 | * the AST, but in a one-hole context. 27 | *) 28 | 29 | (*****************************************************************************) 30 | (* Implementation *) 31 | (*****************************************************************************) 32 | 33 | structure Location = 34 | struct 35 | datatype location = 36 | (* EXP hole *) 37 | EHOLE of SMLSyntax.exp 38 | | CLOSURE of Context.t 39 | (* When you enter a function application, your entire context changes 40 | * to the closure of the function. 41 | * To prevent the pretty printer from applying this new context 42 | * backwards when reporting the greater context, we need to restore 43 | * this context once we exit the closrue. 44 | *) 45 | | DVALBINDS of 46 | bool 47 | * SMLSyntax.symbol list 48 | * SMLSyntax.pat 49 | * { recc : bool, pat : SMLSyntax.pat, exp : SMLSyntax.exp } list 50 | (* DEC hole *) 51 | | ELET of SMLSyntax.exp list 52 | | DLOCAL of SMLSyntax.dec list * SMLSyntax.dec 53 | | DSEQ of SMLSyntax.dec list 54 | (* STRDEC hole *) 55 | | DMLOCAL of SMLSyntax.strdec list * SMLSyntax.strdec 56 | | DMSEQ of SMLSyntax.strdec list 57 | | MLET of SMLSyntax.module 58 | (* MODULE hole *) 59 | | MSTRUCT 60 | | MSEAL of { opacity : SMLSyntax.opacity, signat : SMLSyntax.signat } 61 | | MAPP of SMLSyntax.symbol 62 | | STRUCTS of 63 | SMLSyntax.symbol 64 | * { opacity : SMLSyntax.opacity, signat : SMLSyntax.signat } option 65 | * { id : SMLSyntax.symbol 66 | , seal : {opacity : SMLSyntax.opacity, signat : SMLSyntax.signat } option 67 | , module : SMLSyntax.module 68 | } list 69 | (* special: just meant to say wtf is going on *) 70 | | FBODY of SMLSyntax.symbol 71 | (* TOPDEC hole *) 72 | | PROG of SMLSyntax.topdec list 73 | 74 | local 75 | open SMLSyntax 76 | in 77 | fun plug_dec_hole v dec_hole = 78 | case dec_hole of 79 | Dval {tyvars, valbinds} => 80 | Dval { tyvars = tyvars 81 | , valbinds = 82 | List.map (fn {recc, pat, exp} => { recc = recc 83 | , pat = pat 84 | , exp = plug_exp_hole v exp 85 | } 86 | ) valbinds 87 | } 88 | | Dlocal {left_dec, right_dec} => 89 | Dlocal { left_dec = plug_dec_hole v left_dec 90 | , right_dec = plug_dec_hole v right_dec 91 | } 92 | | Dseq decs => 93 | Dseq (List.map (plug_dec_hole v) decs) 94 | | ( Dfun _ 95 | | Dtype _ 96 | | Ddatdec _ 97 | | Ddatrepl _ 98 | | Dabstype _ 99 | | Dexception _ 100 | | Dopen _ 101 | | Dinfix _ 102 | | Dinfixr _ 103 | | Dnonfix _ 104 | | Dhole ) => dec_hole 105 | 106 | and plug_hole v location = 107 | case location of 108 | (EHOLE exp_hole :: rest) => (plug_exp_hole v exp_hole, rest) 109 | (* THINK: I no longer understand what this does. *) 110 | | (DVALBINDS _ :: _) => (Value.value_to_exp v, location) 111 | | (CLOSURE _ :: rest) => plug_hole v rest 112 | | ( ELET _ 113 | | DLOCAL _ 114 | | DSEQ _ 115 | | DMLOCAL _ 116 | | DMSEQ _ 117 | | MLET _ 118 | | MSTRUCT 119 | | MSEAL _ 120 | | MAPP _ 121 | | STRUCTS _ 122 | | FBODY _ 123 | | PROG _ ) :: _ => raise Fail "invalid value hole" 124 | | [] => raise Fail "invalid value hole" 125 | 126 | and plug_exp_hole v exp_hole = 127 | ( case exp_hole of 128 | ( Enumber _ 129 | | Estring _ 130 | | Echar _ 131 | | Eselect _ 132 | | Eunit 133 | | Eident _ 134 | ) => exp_hole 135 | | Erecord fields => 136 | Erecord 137 | (List.map (fn {lab, exp} => {lab = lab, exp = plug_exp_hole v exp}) fields) 138 | | Etuple exps => 139 | Etuple (List.map (plug_exp_hole v) exps) 140 | | Elist exps => 141 | Elist (List.map (plug_exp_hole v) exps) 142 | | Eseq exps => 143 | Eseq (List.map (plug_exp_hole v) exps) 144 | | Elet {dec, exps} => 145 | (* Shouldn't be any holes in exps. *) 146 | Elet { dec = plug_dec_hole v dec 147 | , exps = exps 148 | } 149 | | Eparens exp => Eparens (plug_exp_hole v exp) 150 | | Eapp {left, right} => 151 | Eapp { left = plug_exp_hole v left 152 | , right = plug_exp_hole v right 153 | } 154 | | Einfix {left, id, right} => 155 | Einfix { left = plug_exp_hole v left 156 | , id = id 157 | , right = plug_exp_hole v right 158 | } 159 | | Etyped {exp, ty} => 160 | Etyped { exp = plug_exp_hole v exp, ty = ty } 161 | | Eandalso {left, right} => 162 | Eandalso { left = plug_exp_hole v left 163 | , right = plug_exp_hole v right 164 | } 165 | | Eorelse {left, right} => 166 | Eorelse { left = plug_exp_hole v left 167 | , right = plug_exp_hole v right 168 | } 169 | | Ehandle {exp, matches} => 170 | (* Shouldn't be any holes in matches. *) 171 | Ehandle { exp = plug_exp_hole v exp 172 | , matches = matches 173 | } 174 | | Eraise exp => Eraise (plug_exp_hole v exp) 175 | | Eif {exp1, exp2, exp3} => 176 | (* Shouldn't be any holes in exp2 or exp3. *) 177 | Eif { exp1 = plug_exp_hole v exp1, exp2 = exp2, exp3 = exp3 } 178 | | Ewhile {exp1, exp2} => 179 | (* Shouldn't be any holes in exp2. *) 180 | Ewhile { exp1 = plug_exp_hole v exp1, exp2 = exp2} 181 | | Ecase {exp, matches} => 182 | (* Shouldn't be any holes in matches. *) 183 | Ecase { exp = plug_exp_hole v exp, matches = matches } 184 | | Efn _ => (* Shouldn't be any in a function. *) exp_hole 185 | | Ehole => Value.value_to_exp v 186 | ) 187 | end 188 | 189 | fun is_val_dec location = 190 | case location of 191 | (DVALBINDS _ :: _) => true 192 | | (CLOSURE _ :: rest) => is_val_dec rest 193 | | _ => false 194 | end 195 | -------------------------------------------------------------------------------- /src/syntax/sml_syntax_helpers.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | open SMLSyntax 8 | 9 | (*****************************************************************************) 10 | (* Prelude *) 11 | (*****************************************************************************) 12 | (* Helpers to go along with the types from `SMLSyntax` 13 | *) 14 | 15 | (*****************************************************************************) 16 | (* Signature *) 17 | (*****************************************************************************) 18 | 19 | signature SMLSYNTAXHELPERS = 20 | sig 21 | val map_sym : symbol -> (string -> string) -> symbol 22 | val longid_eq : longid * longid -> bool 23 | val longid_to_str : longid -> string 24 | val tyvar_eq : tyvar * tyvar -> bool 25 | val guard_tyscheme : type_scheme -> type_scheme 26 | val concrete_tyscheme : tyval -> type_scheme 27 | val number_eq : number * number -> bool 28 | 29 | val sym : string -> symbol 30 | 31 | val sym_true : symbol 32 | val sym_false : symbol 33 | val tyval_of_instantiated_synonym : 34 | SMLSyntax.tyval list 35 | -> SMLSyntax.synonym 36 | -> SMLSyntax.tyval 37 | end 38 | 39 | (*****************************************************************************) 40 | (* Implementation *) 41 | (*****************************************************************************) 42 | 43 | structure SMLSyntaxHelpers = 44 | struct 45 | type symbol = symbol 46 | type longid = symbol list 47 | 48 | fun map_sym sym f = 49 | Symbol.fromValue (f (Symbol.toValue sym)) 50 | fun longid_eq (l1, l2) = 51 | ListPair.allEq Symbol.eq (l1, l2) 52 | fun longid_to_str longid = 53 | String.concatWith "." (List.map Symbol.toValue longid) 54 | 55 | fun tyvar_eq (t1, t2) = 56 | case (t1, t2) of 57 | (Proper s1, Proper s2) => Symbol.eq (s1, s2) 58 | | (Unconstrained r1, Unconstrained r2) => r1 = r2 59 | | _ => false 60 | 61 | fun guard_tyscheme (n, ty_fn) = 62 | ( n 63 | , fn tyvals => 64 | if List.length tyvals <> n then 65 | raise Fail "Instantiated type scheme with incorrect number of tyargs" 66 | else 67 | ty_fn tyvals 68 | ) 69 | fun concrete_tyscheme tyval = 70 | guard_tyscheme (0, fn _ => tyval) 71 | 72 | fun number_eq (n1, n2) = 73 | case (n1, n2) of 74 | (Int i1, Int i2) => i1 = i2 75 | | (Real _, Real _) => raise Fail "comparing reals for equality" 76 | | (Word w1, Word w2) => w1 = w2 77 | | _ => false 78 | 79 | val sym = Symbol.fromValue 80 | 81 | val sym_true = sym "true" 82 | val sym_false = sym "false" 83 | 84 | fun tyval_of_instantiated_synonym tyvals synonym = 85 | case synonym of 86 | Datatype tyid => 87 | TVapp (tyvals, tyid) 88 | | Abs absid => 89 | TVabs (tyvals, absid) 90 | | Scheme (_, ty_fn) => ty_fn tyvals 91 | 92 | (* 93 | fun make_maps f_exp f_dec = 94 | let 95 | fun map_exp exp = 96 | ( case exp of 97 | ( Enumber _ 98 | | Estring _ 99 | | Echar _ 100 | | Eunit 101 | | Eselect _ 102 | | Eident _ 103 | | Ehole 104 | ) => exp 105 | | Erecord fields => 106 | List.map 107 | (fn {lab, exp} => {lab = lab, map_exp exp}) 108 | fields 109 | |> Erecord 110 | | Etuple exps => 111 | List.map map_exp exps 112 | |> Etuple 113 | | Elist exps => 114 | List.map map_exp exps 115 | |> Elist 116 | | Eseq exps => 117 | List.map map_exp exps 118 | |> Elist 119 | | Elet {dec, exps} => 120 | { dec = map_dec dec 121 | , exps = List.map map_exp exps 122 | } 123 | |> Elet 124 | | Eparens exp => 125 | Eparens (map_exp exp) 126 | | Eapp {left, right} => 127 | Eapp {left = map_exp left, right = map_exp right} 128 | | Einfix {left, id, right} => 129 | Einfix { left = map_exp left, id = id, right = map_exp right } 130 | | Etyped {exp, ty} => 131 | Etyped {exp = map_exp exp, ty = map_ty ty} 132 | | Eandalso {left, right} = 133 | Eandalso {left = map_exp left, right = map_exp right} 134 | | Eorelse {left, right} = 135 | Eorelse {left = map_exp left, right = map_exp right} 136 | | Ehandle {exp, matches} => 137 | Ehandle {exp = map_exp exp, matches = map_matches matches} 138 | | Eraise exp => 139 | Eraise (map_exp exp) 140 | | Eif {exp1, exp2, exp3} => 141 | Eif { exp1 = map_exp exp1 142 | , exp2 = map_exp exp2 143 | , exp3 = map_exp exp3 144 | } 145 | | Ewhile {exp1, exp2} => 146 | Ewhile { exp1 = map_exp exp1 147 | , exp2 = map_exp exp2 148 | } 149 | | Ecase {exp, matches} => 150 | Ecase {exp = map_exp exp, matches = map_matches matches} 151 | | Efn (matches, ctxopt) => 152 | Efn (map_matches matches, ctxopt) 153 | ) |> f_exp 154 | 155 | and map_dec f_exp dec = 156 | ( case dec of 157 | Dval {tyvars, valbinds} => 158 | Dval { tyvars = tyvars 159 | , valbinds = 160 | List.map 161 | (fn {recc, pat, exp} => 162 | { recc = recc 163 | , pat = map_pat pat 164 | , exp = map_exp exp 165 | } 166 | ) 167 | valbinds 168 | } 169 | | Dfun {tyvars, fvalbinds} => 170 | Dfun { tyvars = tyvars 171 | , fvalbinds = 172 | List.map 173 | (List.map 174 | (fn {fname_args, ty, exp} => 175 | { fname_args = map_fname_args fname_args 176 | , ty = Option.map map_ty ty 177 | } 178 | ) 179 | ) 180 | fvalbinds 181 | } 182 | | Dtype typbinds => 183 | Dtype ( 184 | List.map 185 | (fn {tyvars, tycon, ty} => {tyvars = tyvars, tycon = tycon, ty = map_ty ty}) 186 | typbinds 187 | ) 188 | | Ddatdec {datbinds, withtypee} => 189 | Ddatdec 190 | { datbinds = List.map map_datbind datbinds 191 | , withtypee = Option.map (List.map map_typbind) withtypee 192 | } 193 | | Dabstype {datbinds, withtypee, withh} => 194 | Dabstype 195 | { datbinds = List.map map_datbind datbinds 196 | , withtypee = Option.map (List.map map_typbind) withtypee 197 | , withh = map_dec withh 198 | } 199 | | Dexception exbinds => 200 | Dexception 201 | (List.map 202 | (fn Xnew {opp, id, ty} => 203 | Xnew {opp = opp, id = id, ty = Option.map map_ty ty} 204 | | other as Xrepl _ => other 205 | ) 206 | exbinds 207 | ) 208 | | Dlocal {left_dec, right_dec} => 209 | Dlocal { left_dec = map_dec left_dec, right_dec = map_dec } 210 | | Dseq decs => 211 | Dseq (List.map map_dec decs) 212 | | ( Dopen _ 213 | | Ddatrepl _ 214 | | Dinfix 215 | | Dinfixr 216 | | Dnonfix 217 | | Dhole _ ) => dec 218 | ) |> f_dec 219 | 220 | and map_ty ty = 221 | case ty of 222 | ( Tident _ 223 | | Ttyvar _ 224 | ) => ty 225 | | Tapp (tys, longid) => Tapp (List.map map_ty tys, longid) 226 | | Tprod tys => Tprod (List.map map_ty tys) 227 | | Tarrow (ty1, ty2) => Tarrow (map_ty ty1, map_ty ty2) 228 | | Trecord fields => 229 | 230 | in 231 | 232 | end 233 | *) 234 | end 235 | -------------------------------------------------------------------------------- /src/statics/collect_tyvars.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | (*****************************************************************************) 8 | (* Prelude *) 9 | (*****************************************************************************) 10 | (* Collecting information about both formal type variables in the concrete 11 | * syntax of the program, as well as unification variables spawned over the 12 | * course of the program's execution. 13 | * 14 | * This information is useful for the statics, where we may need to occasionally 15 | * figure out which type variables are in scope. 16 | *) 17 | 18 | (*****************************************************************************) 19 | (* Implementation *) 20 | (*****************************************************************************) 21 | 22 | structure CollectTyvars = 23 | struct 24 | open SMLSyntax 25 | 26 | fun collect_tyvars_ty ty = 27 | case ty of 28 | Tident _ => SymSet.empty 29 | | Ttyvar sym => SymSet.singleton sym 30 | | ( Tapp (tys, _) 31 | | Tprod tys ) => List.map collect_tyvars_ty tys |> union_sets 32 | | Tarrow (t1, t2) => 33 | SymSet.union (collect_tyvars_ty t1) (collect_tyvars_ty t2) 34 | | Trecord fields => 35 | List.map (fn {ty, ...} => collect_tyvars_ty ty) fields |> union_sets 36 | | Tparens ty => collect_tyvars_ty ty 37 | 38 | fun collect_tyvars_tyval tyval = 39 | case tyval of 40 | TVtyvar sym => [Proper sym] 41 | | ( TVapp (tyvals, _) 42 | | TVabs (tyvals, _) ) => 43 | (List.concat o List.map collect_tyvars_tyval) tyvals 44 | | TVprod tyvals => 45 | (List.concat o List.map collect_tyvars_tyval) tyvals 46 | | TVarrow (tyval1, tyval2) => 47 | collect_tyvars_tyval tyval1 @ collect_tyvars_tyval tyval2 48 | | TVrecord fields => 49 | (List.concat o List.map (fn {lab = _, tyval} => collect_tyvars_tyval tyval)) fields 50 | | TVvar (i, r as ref NONE) => [Unconstrained (i, r)] 51 | | TVvar (_, ref (SOME (Ty tyval))) => 52 | collect_tyvars_tyval tyval 53 | | TVvar (_, ref (SOME (Rows fields))) => 54 | (List.concat o List.map (fn {lab = _, tyval} => collect_tyvars_tyval tyval)) fields 55 | 56 | fun collect_tyvars_patrow patrow = 57 | case patrow of 58 | PRellipsis => SymSet.empty 59 | | PRlab {pat, ...} => collect_tyvars_pat pat 60 | | PRas {ty, aspat, ...} => 61 | (case (ty, aspat) of 62 | (SOME ty, NONE) => collect_tyvars_ty ty 63 | | (NONE, SOME pat) => collect_tyvars_pat pat 64 | | (NONE, NONE) => SymSet.empty 65 | | (SOME ty, SOME pat) => 66 | SymSet.union (collect_tyvars_ty ty) (collect_tyvars_pat pat) 67 | ) 68 | 69 | and collect_tyvars_pat pat = 70 | case pat of 71 | ( Pnumber _ 72 | | Pword _ 73 | | Pstring _ 74 | | Pchar _ 75 | | Pwild 76 | | Pident _ 77 | | Punit ) => SymSet.empty 78 | | Precord patrows => 79 | List.map collect_tyvars_patrow patrows |> union_sets 80 | | Pparens pat => collect_tyvars_pat pat 81 | | Ptuple pats => List.map collect_tyvars_pat pats |> union_sets 82 | | (Por pats | Plist pats) => List.map collect_tyvars_pat pats |> union_sets 83 | | Papp {atpat, ...} => collect_tyvars_pat atpat 84 | | Pinfix {left, right, ...} => 85 | SymSet.union 86 | (collect_tyvars_pat left) 87 | (collect_tyvars_pat right) 88 | | Ptyped {pat, ty} => 89 | SymSet.union 90 | (collect_tyvars_pat pat) 91 | (collect_tyvars_ty ty) 92 | | Playered {ty, aspat, ...} => 93 | SymSet.union 94 | (collect_tyvars_pat aspat) 95 | (case ty of 96 | NONE => SymSet.empty 97 | | SOME ty => collect_tyvars_ty ty 98 | ) 99 | 100 | fun collect_tyvars exp = 101 | case exp of 102 | ( Enumber _ 103 | | Estring _ 104 | | Echar _ 105 | | Eunit 106 | | Eident _ 107 | | Eselect _ ) => SymSet.empty 108 | | Erecord fields => 109 | List.map 110 | (fn {lab = _, exp} => collect_tyvars exp) 111 | fields 112 | |> union_sets 113 | | Etuple exps => 114 | List.map collect_tyvars exps |> union_sets 115 | | Elist exps => 116 | List.map collect_tyvars exps |> union_sets 117 | | Eseq exps => 118 | List.map collect_tyvars exps |> union_sets 119 | | Elet {dec, exps} => 120 | SymSet.union 121 | (collect_tyvars_dec dec) 122 | (union_sets (List.map collect_tyvars exps)) 123 | | Eparens exp => collect_tyvars exp 124 | | ( Eapp {left, right} 125 | | Einfix {left, right, ...} 126 | | Eandalso {left, right} 127 | | Eorelse {left, right} ) => 128 | SymSet.union 129 | (collect_tyvars left) 130 | (collect_tyvars right) 131 | | Etyped {exp, ty} => 132 | SymSet.union 133 | (collect_tyvars exp) 134 | (collect_tyvars_ty ty) 135 | | Ehandle {exp, matches} => 136 | SymSet.union 137 | (collect_tyvars exp) 138 | (collect_tyvars_matches matches) 139 | | Eraise exp => collect_tyvars exp 140 | | Eif {exp1, exp2, exp3} => 141 | union_three 142 | (collect_tyvars exp1) 143 | (collect_tyvars exp2) 144 | (collect_tyvars exp3) 145 | | Ewhile {exp1, exp2} => 146 | SymSet.union 147 | (collect_tyvars exp1) 148 | (collect_tyvars exp2) 149 | | Ecase {exp, matches} => 150 | SymSet.union 151 | (collect_tyvars exp) 152 | (collect_tyvars_matches matches) 153 | | Efn (matches, _) => 154 | collect_tyvars_matches matches 155 | | Ehole => raise Fail "shouldn't happen" 156 | 157 | and collect_tyvars_matches matches = 158 | List.foldl 159 | (fn ({pat, exp}, acc) => 160 | union_three 161 | (collect_tyvars exp) 162 | (collect_tyvars_pat pat) 163 | acc 164 | ) 165 | SymSet.empty 166 | matches 167 | 168 | and collect_tyvars_typbinds typbinds = 169 | List.map 170 | (fn {tyvars, ty, ...} => 171 | SymSet.difference 172 | (collect_tyvars_ty ty) 173 | (set_from_list tyvars) 174 | ) 175 | typbinds 176 | |> union_sets 177 | 178 | and collect_tyvars_datbinds datbinds = 179 | List.map 180 | (fn {tyvars, conbinds, ...} => 181 | SymSet.difference 182 | (List.map (fn {ty, ...} => 183 | case ty of 184 | NONE => SymSet.empty 185 | | SOME ty => collect_tyvars_ty ty 186 | ) conbinds |> union_sets 187 | ) 188 | (set_from_list tyvars) 189 | ) 190 | datbinds 191 | |> union_sets 192 | 193 | and collect_tyvars_fname_args fname_args = 194 | case fname_args of 195 | Fprefix {args, ...} => 196 | union_sets (List.map collect_tyvars_pat args) 197 | | Finfix {left, right, ...} => 198 | SymSet.union 199 | (collect_tyvars_pat left) 200 | (collect_tyvars_pat right) 201 | | Fcurried_infix {left, right, args, ...} => 202 | union_three 203 | (collect_tyvars_pat left) 204 | (collect_tyvars_pat right) 205 | (union_sets (List.map collect_tyvars_pat args)) 206 | 207 | (* We're looking for unguarded tyvars, meaning that we should not descend 208 | * into smaller val declarations. 209 | * 210 | * We technically want both unguarded and implicitly scoped, meaning not 211 | * scoped by a farther up val declaration, but we will take care of that 212 | * with the call stack. 213 | *) 214 | and collect_tyvars_dec dec = 215 | case dec of 216 | ( Dval _ 217 | | Dfun _ 218 | | Ddatrepl _ 219 | | Dopen _ 220 | | Dinfix _ 221 | | Dinfixr _ 222 | | Dnonfix _ ) => SymSet.empty 223 | | Dtype typbinds => 224 | collect_tyvars_typbinds typbinds 225 | | Ddatdec {datbinds, withtypee} => 226 | SymSet.union 227 | (collect_tyvars_datbinds datbinds) 228 | (case withtypee of 229 | NONE => SymSet.empty 230 | | SOME typbinds => collect_tyvars_typbinds typbinds 231 | ) 232 | | Dabstype {datbinds, withtypee, withh} => 233 | union_three 234 | (collect_tyvars_datbinds datbinds) 235 | (collect_tyvars_dec withh) 236 | (case withtypee of 237 | NONE => SymSet.empty 238 | | SOME typbinds => collect_tyvars_typbinds typbinds 239 | ) 240 | | Dexception exbinds => 241 | (List.map 242 | (fn Xnew {ty, ...} => 243 | (case ty of 244 | NONE => SymSet.empty 245 | | SOME ty => collect_tyvars_ty ty 246 | ) 247 | | Xrepl _ => SymSet.empty 248 | ) 249 | exbinds 250 | |> union_sets 251 | ) 252 | | Dlocal {left_dec, right_dec} => 253 | SymSet.union 254 | (collect_tyvars_dec left_dec) 255 | (collect_tyvars_dec right_dec) 256 | | Dseq decs => 257 | List.map 258 | collect_tyvars_dec 259 | decs 260 | |> union_sets 261 | | Dhole => raise Fail "should not happen" 262 | end 263 | -------------------------------------------------------------------------------- /src/context/binding.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | structure SH = SMLSyntaxHelpers 8 | open PrettyPrintContext 9 | open Context 10 | open SMLSyntax 11 | open Error 12 | 13 | (*****************************************************************************) 14 | (* Prelude *) 15 | (*****************************************************************************) 16 | (* This file deals with "bindings", which are the bindings present in the context 17 | * at the time of pretty-printing the AST. 18 | * 19 | * The basic problem has to do with the fact that the pretty-printer is contextual. 20 | * If you wanted to print out the following program: 21 | * 22 | * val _ = x + x 23 | * val x = 2 24 | * val y = 3 + x 25 | * 26 | * with an environment of { x -> 1 } 27 | * 28 | * you would want to print out `val _ = 1 + 1`, but NOT `val y = 3 + 1`. 29 | * This is because the `x` mentioned in the second case is actually a different 30 | * `x` than the one in our environment! 31 | * 32 | * To deal with this, we have some logic which removes identifiers from our context 33 | * based on when we crawl forward or backward in the AST. 34 | * 35 | * Essentially, we are doing naming here, but in a dictionary instead of within 36 | * the AST nodes themselves. 37 | *) 38 | 39 | (*****************************************************************************) 40 | (* Signature *) 41 | (*****************************************************************************) 42 | 43 | signature BINDING = 44 | sig 45 | type t = SMLSyntax.context 46 | type bindings = PrettyPrintContext.MarkerSet.set 47 | 48 | val of_pat : t -> SMLSyntax.pat -> bindings 49 | val ids_of_pat : t -> SMLSyntax.pat -> SMLSyntax.symbol list 50 | val of_fname_args : 51 | t -> SMLSyntax.fname_args -> bindings 52 | 53 | val remove_bindings : t -> bindings -> t 54 | val of_modname : t -> SMLSyntax.longid -> bindings 55 | val of_funarg : t -> SMLSyntax.funarg -> bindings 56 | end 57 | 58 | (*****************************************************************************) 59 | (* Helpers *) 60 | (*****************************************************************************) 61 | 62 | fun marker_set_of_list l = 63 | List.foldl 64 | (fn (x, acc) => 65 | MarkerSet.insert acc x 66 | ) 67 | MarkerSet.empty 68 | l 69 | 70 | (*****************************************************************************) 71 | (* Implementation *) 72 | (*****************************************************************************) 73 | 74 | structure Binding : BINDING = 75 | struct 76 | type t = SMLSyntax.context 77 | type bindings = PrettyPrintContext.MarkerSet.set 78 | 79 | fun get_patrow_bindings ctx patrow = 80 | case patrow of 81 | PRellipsis => MarkerSet.empty 82 | | PRlab {pat, ...} => of_pat ctx pat 83 | | PRas {id, aspat, ...} => 84 | MarkerSet.union 85 | (MarkerSet.singleton (VAL id)) 86 | (case aspat of 87 | NONE => MarkerSet.empty 88 | | SOME pat => of_pat ctx pat 89 | ) 90 | 91 | and of_pat ctx pat = 92 | case pat of 93 | ( Pnumber _ 94 | | Pword _ 95 | | Pstring _ 96 | | Pchar _ 97 | | Pwild 98 | | Punit ) => MarkerSet.empty 99 | | Pident {id, ...} => 100 | if is_con ctx id then 101 | MarkerSet.empty 102 | else 103 | (case id of 104 | [id] => MarkerSet.singleton (VAL id) 105 | | _ => eval_err ("Cannot find constructor " ^ TerminalColors.text 106 | TerminalColors.lightblue (SH.longid_to_str id)) 107 | ) 108 | | Precord patrows => List.map (get_patrow_bindings ctx) patrows |> union_sets 109 | | Pparens pat => of_pat ctx pat 110 | | Ptuple pats => List.map (of_pat ctx) pats |> union_sets 111 | | Plist pats => List.map (of_pat ctx) pats |> union_sets 112 | | Por pats => List.map (of_pat ctx) pats |> union_sets 113 | | Papp {id, atpat, ...} => 114 | if is_con ctx id then 115 | of_pat ctx atpat 116 | else 117 | (case id of 118 | [id] => 119 | MarkerSet.union 120 | (MarkerSet.singleton (VAL id)) 121 | (of_pat ctx atpat) 122 | | _ => 123 | eval_err ("Cannot find constructor " ^ TerminalColors.text 124 | TerminalColors.lightblue (SH.longid_to_str id)) 125 | ) 126 | | Pinfix {left, id, right} => 127 | if is_con ctx [id] then 128 | MarkerSet.union 129 | (of_pat ctx left) 130 | (of_pat ctx right) 131 | else 132 | union_sets 133 | [ MarkerSet.singleton (VAL id) 134 | , of_pat ctx left 135 | , of_pat ctx right 136 | ] 137 | | Ptyped {pat, ...} => of_pat ctx pat 138 | | Playered {id, aspat, ...} => 139 | MarkerSet.union 140 | (MarkerSet.singleton (VAL id)) 141 | (of_pat ctx aspat) 142 | 143 | fun ids_of_pat ctx pat = 144 | List.map (fn VAL id => id | _ => raise Fail "shouldn't happen") 145 | (MarkerSet.toList (of_pat ctx pat)) 146 | 147 | fun of_fname_args ctx fname_args = 148 | case fname_args of 149 | Fprefix {id, args, ...} => 150 | union_sets 151 | ( MarkerSet.singleton (VAL id) 152 | :: List.map (of_pat ctx) args 153 | ) 154 | | Finfix {left, id, right} => 155 | union_sets 156 | [ of_pat ctx left 157 | , MarkerSet.singleton (VAL id) 158 | , of_pat ctx right 159 | ] 160 | | Fcurried_infix {left, id, right, args} => 161 | union_sets 162 | ( [ of_pat ctx left 163 | , MarkerSet.singleton (VAL id) 164 | , of_pat ctx right 165 | ] 166 | @ List.map (of_pat ctx) args 167 | ) 168 | 169 | (* We should not be able to do this for a constructor or exception, because 170 | * they will be interpreted as matching against their patterns. 171 | *) 172 | fun remove_val_scope_bound_id scope id = 173 | let 174 | val identdict = scope_identdict scope 175 | in 176 | case SymDict.find identdict id of 177 | NONE => scope 178 | | SOME (E _ | C _) => prog_err "trying to remove val bound id of constructor or exception" 179 | | SOME (V _) => scope_set_identdict scope (SymDict.remove identdict id) 180 | end 181 | 182 | fun remove_mod_scope_bound_id scope id = 183 | let 184 | val moddict = scope_moddict scope 185 | in 186 | scope_set_moddict scope (SymDict.remove moddict id) 187 | end 188 | 189 | fun remove_bound_id_base f {scope, outer_scopes, dtydict, sigdict, functordict, 190 | tyvars, hole_print_fn, settings, abstys} id = 191 | let 192 | val scope = f scope id 193 | val outer_scopes = 194 | List.map 195 | (fn scope => f scope id) 196 | outer_scopes 197 | in 198 | { scope = scope 199 | , outer_scopes = outer_scopes 200 | , dtydict = dtydict 201 | , sigdict = sigdict 202 | , functordict = functordict 203 | , tyvars = tyvars 204 | , hole_print_fn = hole_print_fn 205 | , settings = settings 206 | , abstys = abstys 207 | } 208 | end 209 | 210 | fun remove_bindings ctx ids = 211 | MarkerSet.foldl 212 | (fn (VAL id, ctx) => 213 | remove_bound_id_base remove_val_scope_bound_id ctx id 214 | | (MOD id, ctx) => 215 | remove_bound_id_base remove_mod_scope_bound_id ctx id 216 | ) 217 | ctx 218 | ids 219 | 220 | fun get_sigval_bindings (_ : SMLSyntax.context) (Sigval {valspecs, modspecs, ...})= 221 | marker_set_of_list 222 | ( List.map VAL (SymDict.domain valspecs) 223 | @ List.map MOD (SymDict.domain modspecs) 224 | ) 225 | 226 | and get_signat_bindings ctx signat = 227 | case signat of 228 | Sspec spec => get_spec_bindings ctx spec 229 | | Sident sym => 230 | get_sigval_bindings ctx (get_sig ctx sym) 231 | | Swhere {signat, ...} => get_signat_bindings ctx signat 232 | 233 | and get_spec_bindings ctx spec = 234 | case spec of 235 | SPval valdescs => 236 | List.map (VAL o #id) valdescs |> marker_set_of_list 237 | | ( SPtype _ 238 | | SPeqtype _ 239 | | SPdatdec _ 240 | | SPdatrepl _ 241 | | SPexception _ ) => MarkerSet.empty 242 | | SPmodule moddescs => 243 | List.map (MOD o #id) moddescs |> marker_set_of_list 244 | | SPinclude signat => 245 | get_signat_bindings ctx signat 246 | | SPinclude_ids syms => 247 | List.map (get_signat_bindings ctx) (List.map Sident syms) 248 | |> union_sets 249 | | SPsharing_type {spec, ...} => get_spec_bindings ctx spec 250 | | SPsharing {spec, ...} => get_spec_bindings ctx spec 251 | | SPseq specs => 252 | List.map (get_spec_bindings ctx) specs 253 | |> union_sets 254 | 255 | fun of_funarg ctx funarg = 256 | case funarg of 257 | Normal {id, ...} => MarkerSet.singleton (MOD id) 258 | | Sugar spec => get_spec_bindings ctx spec 259 | 260 | fun of_modname ctx longid = 261 | let 262 | val (identdict, moddict) = 263 | case (get_module_opt ctx longid) of 264 | NONE => (SymDict.empty, SymDict.empty) 265 | | SOME scope => (scope_identdict scope, scope_moddict scope) 266 | in 267 | ( SymDict.foldl 268 | (fn (id, elem, acc) => 269 | case elem of 270 | (V _) => VAL id :: acc 271 | | _ => acc 272 | ) 273 | [] 274 | identdict 275 | @ 276 | List.map MOD (SymDict.domain moddict) 277 | ) 278 | |> marker_set_of_list 279 | end 280 | end 281 | -------------------------------------------------------------------------------- /src/cm_parser/lex/lexer.sml: -------------------------------------------------------------------------------- 1 | (** Brandon Wu 2 | * 3 | * Copyright (c) 2022-2023 4 | * See the file LICENSE for details. 5 | *) 6 | 7 | signature LEXER = 8 | sig 9 | val lex : char Stream.stream -> CM_Token.token Stream.stream 10 | val lex_string : string -> CM_Token.token list 11 | val lex_file : string -> CM_Token.token list 12 | end 13 | 14 | structure CM_Lexer :> LEXER = 15 | struct 16 | open CM_Token 17 | 18 | fun revappend l1 l2 = 19 | (case l1 of 20 | x :: rest => 21 | revappend rest (x :: l2) 22 | | [] => l2) 23 | 24 | open Stream 25 | open Error 26 | 27 | structure Arg = 28 | struct 29 | structure Streamable = StreamStreamable 30 | structure Table = SymbolHashTable 31 | 32 | type symbol = char 33 | val ord = Char.ord 34 | type pos = int 35 | 36 | datatype tlex = LEX of char stream -> t 37 | withtype t = tlex -> pos -> token front 38 | 39 | type u = pos -> char stream * pos 40 | type v = pos -> char list -> char list * char stream * pos 41 | 42 | type self = { comment : symbol Streamable.t -> u, 43 | group_or_library : symbol Streamable.t -> t, 44 | ifmode : symbol Streamable.t -> u, 45 | is : symbol Streamable.t -> t, 46 | main : symbol Streamable.t -> t, 47 | string : symbol Streamable.t -> v } 48 | type info = { match : symbol list, 49 | len : int, 50 | start : symbol Streamable.t, 51 | follow : symbol Streamable.t, 52 | self : self } 53 | 54 | val keywords_list = 55 | [ ("structure", STRUCTURE) 56 | , ("signature", SIGNATURE) 57 | , ("functor", FUNCTOR) 58 | ] 59 | 60 | val keywords : token Table.table = Table.table 60 61 | 62 | val () = 63 | List.app 64 | (fn (str, token) => Table.insert keywords (Symbol.fromValue str) token) 65 | keywords_list 66 | 67 | fun identify table str = 68 | let 69 | val sym = Symbol.fromValue str 70 | in 71 | (case Table.find table sym of 72 | NONE => 73 | IDENT sym 74 | 75 | | SOME tok => tok 76 | ) 77 | end 78 | 79 | fun action f ({ match, len, follow, ...}: info) (k as LEX cont) pos = 80 | Cons (f (match, len, pos, follow), lazy (fn () => cont follow k (pos + len))) 81 | 82 | fun skip_main ({ len, follow, self, ...} : info) (k as LEX _) pos = 83 | #main self follow k (pos + len) 84 | 85 | fun analyze_gl ({ match, len, follow, self, ... } : info) (_ : tlex) pos = 86 | case String.implode match of 87 | "is" => (#is self follow (LEX (#is self)) (pos + len)(*; raise Fail (String.implode 88 | (Stream.toList follow))*)) 89 | | _ => #group_or_library self follow (LEX (#group_or_library self)) (pos + len) 90 | 91 | fun skip_gl ({ len, follow, self, ...} : info) (_ : tlex) pos = 92 | #group_or_library self follow (LEX (#group_or_library self)) (pos + len) 93 | 94 | val ident = 95 | action 96 | (fn (match, _, _, _) => identify keywords (implode match)) 97 | 98 | fun enter_if ({ len, follow, self, ...} : info) (k as LEX cont) pos = 99 | let 100 | val (follow, pos) = #ifmode self follow (pos + len) 101 | in 102 | cont follow k pos 103 | end 104 | 105 | 106 | 107 | fun skip_if ({ len, follow, self, ...} : info) pos = 108 | #ifmode self follow (pos + len) 109 | 110 | fun exit_if ({ follow, ...} : info) pos = 111 | (follow, pos) 112 | 113 | fun skip_is ({ len, follow, self, ...} : info) (_ : tlex) pos = 114 | #is self follow (LEX (#is self)) (pos + len) 115 | 116 | fun enter_group ({ len, follow, self, ...} : info) (_ : tlex) pos = 117 | Cons ( GROUP 118 | , lazy (fn () => #group_or_library self follow (LEX 119 | (#group_or_library self)) (pos + len)) 120 | ) 121 | 122 | fun enter_library ({ len, follow, self, ...} : info) (_ : tlex) pos = 123 | Cons ( LIBRARY 124 | , lazy (fn () => #group_or_library self follow (LEX 125 | (#group_or_library self)) (pos + len)) 126 | ) 127 | 128 | fun enter_is ({ len, follow, self, ...} : info) (_ : tlex) pos = 129 | Cons ( IS 130 | , lazy (fn () => #is self follow (LEX (#is self)) (pos + len)) 131 | ) 132 | 133 | fun action_is f ({ match, len, follow, self, ...}: info) (_ : tlex) pos = 134 | Cons (f (match, len, pos), lazy (fn () => #is self follow (LEX (#is 135 | self)) (pos + len))) 136 | 137 | val is_stdpn = 138 | action_is 139 | (fn (match, _, _) => 140 | ELEM ( PATH ( Symbol.fromValue (String.implode match) 141 | ) 142 | ) 143 | ) 144 | 145 | fun unfinished ({follow, ...} : info) _ pos = 146 | err 147 | ( LexError 148 | { reason = "unfinished mode" 149 | , pos = pos 150 | , rest = Stream.toList follow 151 | } 152 | ) 153 | 154 | fun enter_comment ({len, follow, self, ...}: info) (k as LEX cont) pos = 155 | let 156 | val (follow', pos') = #comment self follow (pos + len) 157 | in 158 | cont follow' k pos' 159 | end 160 | 161 | fun enter_string ({len, follow, self, ...}: info) (k as LEX cont) pos = 162 | let 163 | (* Suppose you have something like this: 164 | * " \" a \" " 165 | * This will get parsed by #string into a list which looks like: 166 | * [ #"\"" #"a", #"\"" ] 167 | * 168 | * The backslashes don't get parsed! 169 | *) 170 | val (chars, follow', pos') = #string self follow (pos + len) [] 171 | 172 | val correct = 173 | String.implode 174 | ( (List.concat o List.map 175 | (fn #"\"" => [#"\\", #"\""] 176 | | #"\n" => [#"\\", #"n"] 177 | (* TODO: fix other special characters? *) 178 | | other => [other] 179 | ) 180 | ) 181 | (List.rev chars) 182 | ) 183 | in 184 | Cons (ELEM (STRING correct), lazy (fn () => cont follow' k pos')) 185 | end 186 | 187 | fun eof (_ : info) (_ : tlex) (_ : pos) = 188 | Cons (EOF, eager Nil) 189 | 190 | fun error ({follow, ...}: info) (_ : tlex) (pos : pos) = 191 | err 192 | ( LexError 193 | { reason = "illegal lexeme" 194 | , pos = pos 195 | , rest = Stream.toList follow 196 | } 197 | ) 198 | 199 | (* comment *) 200 | 201 | fun reenter_comment ({ len, follow, self, ...}: info) pos = 202 | let 203 | val (follow', pos') = #comment self follow (pos + len) 204 | in 205 | #comment self follow' pos' 206 | end 207 | 208 | fun exit_comment ({ len, follow, ...}: info) pos = 209 | (follow, pos + len) 210 | 211 | fun comment_skip ({ len, follow, self, ...} : info) pos = 212 | #comment self follow (pos + len) 213 | 214 | fun unclosed_comment ({follow, ...}: info) pos = 215 | err 216 | ( LexError 217 | { reason = "unclosed comment" 218 | , pos = pos 219 | , rest = Stream.toList follow 220 | } 221 | ) 222 | 223 | fun comment_error ({follow, ...}: info) pos = 224 | err 225 | ( LexError 226 | { reason = "illegal character in comment" 227 | , pos = pos 228 | , rest = Stream.toList follow 229 | } 230 | ) 231 | 232 | fun unfinished_if ({follow, ...}: info) pos = 233 | err 234 | ( LexError 235 | { reason = "unfinished #if" 236 | , pos = pos 237 | , rest = Stream.toList follow 238 | } 239 | ) 240 | 241 | fun error_if ({follow, ...}: info) pos = 242 | err 243 | ( LexError 244 | { reason = "illegal character in #if" 245 | , pos = pos 246 | , rest = Stream.toList follow 247 | } 248 | ) 249 | 250 | (* string *) 251 | 252 | fun string_action f ({ match, len, follow, self, ...}: info) pos acc = 253 | #string self follow (pos + len) (f (match, acc)) 254 | 255 | val string_elem = 256 | string_action 257 | (fn (match, acc) => revappend match acc) 258 | 259 | val string_newline = 260 | string_action 261 | (fn (_, acc) => #"\n" :: acc) 262 | 263 | val string_backslash = 264 | string_action 265 | (fn (_, acc) => #"\\" :: acc) 266 | 267 | val string_quote = 268 | string_action 269 | (fn (_, acc) => #"\"" :: acc) 270 | 271 | fun hexdigit ch = 272 | let val i = Char.ord ch 273 | in 274 | if i <= Char.ord #"9" then 275 | i - Char.ord #"0" 276 | else if i <= Char.ord #"F" then 277 | i - Char.ord #"A" + 10 278 | else 279 | i - Char.ord #"f" 280 | end 281 | 282 | val string_hex2 = 283 | string_action 284 | (fn ([_, _, a, b], acc) => Char.chr (hexdigit a * 16 + hexdigit b) :: acc 285 | | _ => raise (Fail "impossible by lexer design")) 286 | 287 | fun string_skip ({ len, follow, self, ... }:info) pos acc = 288 | #string self follow (pos+len) acc 289 | 290 | fun exit_string ({ len, follow, ... }:info) pos acc = 291 | (acc, follow, pos+len) 292 | 293 | fun unclosed_string ({follow, ...}: info) pos = 294 | err 295 | ( LexError 296 | { reason = "unclosed string" 297 | , pos = pos 298 | , rest = Stream.toList follow 299 | } 300 | ) 301 | 302 | fun string_error ({follow, ...}: info) pos = 303 | err 304 | ( LexError 305 | { reason = "illegal character in string" 306 | , pos = pos 307 | , rest = Stream.toList follow 308 | } 309 | ) 310 | 311 | end 312 | 313 | structure LexMain = 314 | LexMainFun ( 315 | structure Streamable = StreamStreamable 316 | structure Arg = Arg 317 | ) 318 | 319 | fun doLex f s = lazy (fn () => f s (Arg.LEX f) 0) 320 | 321 | fun lex s = doLex LexMain.main s 322 | 323 | fun lex_string s = Stream.toList (lex (Stream.fromList (String.explode s))) 324 | 325 | fun lex_file s = lex_string (TextIO.inputAll (TextIO.openIn s)) 326 | end 327 | -------------------------------------------------------------------------------- /src/cm_parser/parse/parser.fun: -------------------------------------------------------------------------------- 1 | (* File generated by CM-Yacc version 2.1 *) 2 | 3 | functor ParserFun 4 | (structure Streamable : STREAMABLE 5 | structure Arg : 6 | sig 7 | type elem 8 | type symbol 9 | type files 10 | type export 11 | type exports 12 | type main 13 | 14 | val main_prog : exports * files -> main 15 | val cons_exports : export * exports -> exports 16 | val nil_exports : unit -> exports 17 | val functor_export : symbol -> export 18 | val signature_export : symbol -> export 19 | val structure_export : symbol -> export 20 | val cons_files : elem * files -> files 21 | val nil_files : unit -> files 22 | 23 | datatype terminal = 24 | ELEM of elem 25 | | LIBRARY 26 | | GROUP 27 | | STRUCTURE 28 | | SIGNATURE 29 | | FUNCTOR 30 | | IDENT of symbol 31 | | IS 32 | | EOF 33 | 34 | val error : terminal Streamable.t -> exn 35 | end) 36 | :> 37 | sig 38 | val parse : Arg.terminal Streamable.t -> Arg.main * Arg.terminal Streamable.t 39 | end 40 | = 41 | 42 | (* 43 | 44 | AUTOMATON LISTING 45 | ================= 46 | 47 | State 0: 48 | 49 | start -> . Main / 0 50 | 7 : Main -> . GROUP Exports IS Files / 0 51 | 8 : Main -> . LIBRARY Exports IS Files / 0 52 | 53 | LIBRARY => shift 1 54 | GROUP => shift 2 55 | Main => goto 3 56 | 57 | ----- 58 | 59 | State 1: 60 | 61 | 2 : Export -> . STRUCTURE IDENT / 1 62 | 3 : Export -> . SIGNATURE IDENT / 1 63 | 4 : Export -> . FUNCTOR IDENT / 1 64 | 5 : Exports -> . / 2 65 | 6 : Exports -> . Export Exports / 2 66 | 8 : Main -> LIBRARY . Exports IS Files / 0 67 | 68 | STRUCTURE => shift 8 69 | SIGNATURE => shift 7 70 | FUNCTOR => shift 6 71 | IS => reduce 5 72 | Export => goto 5 73 | Exports => goto 4 74 | 75 | ----- 76 | 77 | State 2: 78 | 79 | 2 : Export -> . STRUCTURE IDENT / 1 80 | 3 : Export -> . SIGNATURE IDENT / 1 81 | 4 : Export -> . FUNCTOR IDENT / 1 82 | 5 : Exports -> . / 2 83 | 6 : Exports -> . Export Exports / 2 84 | 7 : Main -> GROUP . Exports IS Files / 0 85 | 86 | STRUCTURE => shift 8 87 | SIGNATURE => shift 7 88 | FUNCTOR => shift 6 89 | IS => reduce 5 90 | Export => goto 5 91 | Exports => goto 9 92 | 93 | ----- 94 | 95 | State 3: 96 | 97 | start -> Main . / 0 98 | 99 | $ => accept 100 | 101 | ----- 102 | 103 | State 4: 104 | 105 | 8 : Main -> LIBRARY Exports . IS Files / 0 106 | 107 | IS => shift 10 108 | 109 | ----- 110 | 111 | State 5: 112 | 113 | 2 : Export -> . STRUCTURE IDENT / 1 114 | 3 : Export -> . SIGNATURE IDENT / 1 115 | 4 : Export -> . FUNCTOR IDENT / 1 116 | 5 : Exports -> . / 2 117 | 6 : Exports -> . Export Exports / 2 118 | 6 : Exports -> Export . Exports / 2 119 | 120 | STRUCTURE => shift 8 121 | SIGNATURE => shift 7 122 | FUNCTOR => shift 6 123 | IS => reduce 5 124 | Export => goto 5 125 | Exports => goto 11 126 | 127 | ----- 128 | 129 | State 6: 130 | 131 | 4 : Export -> FUNCTOR . IDENT / 1 132 | 133 | IDENT => shift 12 134 | 135 | ----- 136 | 137 | State 7: 138 | 139 | 3 : Export -> SIGNATURE . IDENT / 1 140 | 141 | IDENT => shift 13 142 | 143 | ----- 144 | 145 | State 8: 146 | 147 | 2 : Export -> STRUCTURE . IDENT / 1 148 | 149 | IDENT => shift 14 150 | 151 | ----- 152 | 153 | State 9: 154 | 155 | 7 : Main -> GROUP Exports . IS Files / 0 156 | 157 | IS => shift 15 158 | 159 | ----- 160 | 161 | State 10: 162 | 163 | 0 : Files -> . EOF / 0 164 | 1 : Files -> . ELEM Files / 0 165 | 8 : Main -> LIBRARY Exports IS . Files / 0 166 | 167 | ELEM => shift 18 168 | EOF => shift 17 169 | Files => goto 16 170 | 171 | ----- 172 | 173 | State 11: 174 | 175 | 6 : Exports -> Export Exports . / 2 176 | 177 | IS => reduce 6 178 | 179 | ----- 180 | 181 | State 12: 182 | 183 | 4 : Export -> FUNCTOR IDENT . / 1 184 | 185 | STRUCTURE => reduce 4 186 | SIGNATURE => reduce 4 187 | FUNCTOR => reduce 4 188 | IS => reduce 4 189 | 190 | ----- 191 | 192 | State 13: 193 | 194 | 3 : Export -> SIGNATURE IDENT . / 1 195 | 196 | STRUCTURE => reduce 3 197 | SIGNATURE => reduce 3 198 | FUNCTOR => reduce 3 199 | IS => reduce 3 200 | 201 | ----- 202 | 203 | State 14: 204 | 205 | 2 : Export -> STRUCTURE IDENT . / 1 206 | 207 | STRUCTURE => reduce 2 208 | SIGNATURE => reduce 2 209 | FUNCTOR => reduce 2 210 | IS => reduce 2 211 | 212 | ----- 213 | 214 | State 15: 215 | 216 | 0 : Files -> . EOF / 0 217 | 1 : Files -> . ELEM Files / 0 218 | 7 : Main -> GROUP Exports IS . Files / 0 219 | 220 | ELEM => shift 18 221 | EOF => shift 17 222 | Files => goto 19 223 | 224 | ----- 225 | 226 | State 16: 227 | 228 | 8 : Main -> LIBRARY Exports IS Files . / 0 229 | 230 | $ => reduce 8 231 | 232 | ----- 233 | 234 | State 17: 235 | 236 | 0 : Files -> EOF . / 0 237 | 238 | $ => reduce 0 239 | 240 | ----- 241 | 242 | State 18: 243 | 244 | 0 : Files -> . EOF / 0 245 | 1 : Files -> . ELEM Files / 0 246 | 1 : Files -> ELEM . Files / 0 247 | 248 | ELEM => shift 18 249 | EOF => shift 17 250 | Files => goto 20 251 | 252 | ----- 253 | 254 | State 19: 255 | 256 | 7 : Main -> GROUP Exports IS Files . / 0 257 | 258 | $ => reduce 7 259 | 260 | ----- 261 | 262 | State 20: 263 | 264 | 1 : Files -> ELEM Files . / 0 265 | 266 | $ => reduce 1 267 | 268 | ----- 269 | 270 | lookahead 0 = $ 271 | lookahead 1 = STRUCTURE SIGNATURE FUNCTOR IS 272 | lookahead 2 = IS 273 | 274 | *) 275 | 276 | struct 277 | local 278 | structure Value = struct 279 | datatype nonterminal = 280 | nonterminal 281 | | elem of Arg.elem 282 | | symbol of Arg.symbol 283 | | files of Arg.files 284 | | export of Arg.export 285 | | exports of Arg.exports 286 | | main of Arg.main 287 | end 288 | structure ParseEngine = ParseEngineFun (structure Streamable = Streamable 289 | type terminal = Arg.terminal 290 | type value = Value.nonterminal 291 | val dummy = Value.nonterminal 292 | fun read terminal = 293 | (case terminal of 294 | Arg.ELEM x => (1, Value.elem x) 295 | | Arg.LIBRARY => (2, Value.nonterminal) 296 | | Arg.GROUP => (3, Value.nonterminal) 297 | | Arg.STRUCTURE => (4, Value.nonterminal) 298 | | Arg.SIGNATURE => (5, Value.nonterminal) 299 | | Arg.FUNCTOR => (6, Value.nonterminal) 300 | | Arg.IDENT x => (7, Value.symbol x) 301 | | Arg.IS => (8, Value.nonterminal) 302 | | Arg.EOF => (9, Value.nonterminal) 303 | ) 304 | ) 305 | in 306 | val parse = ParseEngine.parse ( 307 | ParseEngine.next5x1 "\128\128\130\131\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\137\136\135\128y\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\137\136\135\128y\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\127\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\139\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\137\136\135\128y\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\141\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\142\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\143\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\144\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\147\128\128\128\128\128\128\128\146\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128x\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128zzz\128z\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128{{{\128{\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128|||\128|\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\147\128\128\128\128\128\128\128\146\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128v\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128~\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\147\128\128\128\128\128\128\128\146\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128w\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128}\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128", 308 | ParseEngine.next5x1 "\128\128\128\131\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\133\132\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\133\137\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\133\139\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\144\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\147\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\148\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128", 309 | Vector.fromList [(0,1,(fn _::rest => Value.files(Arg.nil_files {})::rest|_=>raise (Fail "bad parser"))), 310 | (0,2,(fn Value.files(arg0)::Value.elem(arg1)::rest => Value.files(Arg.cons_files {2=arg0,1=arg1})::rest|_=>raise (Fail "bad parser"))), 311 | (1,2,(fn Value.symbol(arg0)::_::rest => Value.export(Arg.structure_export arg0)::rest|_=>raise (Fail "bad parser"))), 312 | (1,2,(fn Value.symbol(arg0)::_::rest => Value.export(Arg.signature_export arg0)::rest|_=>raise (Fail "bad parser"))), 313 | (1,2,(fn Value.symbol(arg0)::_::rest => Value.export(Arg.functor_export arg0)::rest|_=>raise (Fail "bad parser"))), 314 | (2,0,(fn rest => Value.exports(Arg.nil_exports {})::rest)), 315 | (2,2,(fn Value.exports(arg0)::Value.export(arg1)::rest => Value.exports(Arg.cons_exports {2=arg0,1=arg1})::rest|_=>raise (Fail "bad parser"))), 316 | (3,4,(fn Value.files(arg0)::_::Value.exports(arg1)::_::rest => Value.main(Arg.main_prog {2=arg0,1=arg1})::rest|_=>raise (Fail "bad parser"))), 317 | (3,4,(fn Value.files(arg0)::_::Value.exports(arg1)::_::rest => Value.main(Arg.main_prog {2=arg0,1=arg1})::rest|_=>raise (Fail "bad parser")))], 318 | (fn Value.main x => x | _ => raise (Fail "bad parser")), Arg.error) 319 | end 320 | end 321 | -------------------------------------------------------------------------------- /src/directive_parser/lex/lexer.fun: -------------------------------------------------------------------------------- 1 | (* File generated by CM-Lex version 2.1 *) 2 | 3 | functor LexMainFun 4 | (structure Streamable : STREAMABLE 5 | structure Arg : 6 | sig 7 | type symbol 8 | val ord : symbol -> int 9 | 10 | type t 11 | 12 | type self = { main : symbol Streamable.t -> t, 13 | primary : symbol Streamable.t -> t } 14 | type info = { match : symbol list, 15 | len : int, 16 | start : symbol Streamable.t, 17 | follow : symbol Streamable.t, 18 | self : self } 19 | 20 | val enter_main : info -> t 21 | val eof : info -> t 22 | val equal : info -> t 23 | val error : info -> t 24 | val lex_bindable : info -> t 25 | val lex_longident : info -> t 26 | val lex_number : info -> t 27 | val skip : info -> t 28 | end) 29 | :> 30 | sig 31 | val main : Arg.symbol Streamable.t -> Arg.t 32 | val primary : Arg.symbol Streamable.t -> Arg.t 33 | end 34 | = 35 | 36 | (* 37 | 38 | AUTOMATON LISTINGS 39 | ================== 40 | 41 | Automaton main 42 | initial state = 4 43 | total states = 11 44 | 45 | ----- 46 | 47 | main state 2 (final:lex_bindable): 48 | 49 | 39 => state 2 (final:lex_bindable) 50 | 46 => state 10 51 | 48-57 => state 2 (final:lex_bindable) 52 | 65-90 => state 2 (final:lex_bindable) 53 | 95 => state 2 (final:lex_bindable) 54 | 97-122 => state 2 (final:lex_bindable) 55 | 56 | ----- 57 | 58 | main state 3 (final:lex_longident): 59 | 60 | 39 => state 3 (final:lex_longident) 61 | 46 => state 10 62 | 48-57 => state 3 (final:lex_longident) 63 | 65-90 => state 3 (final:lex_longident) 64 | 95 => state 3 (final:lex_longident) 65 | 97-122 => state 3 (final:lex_longident) 66 | 67 | ----- 68 | 69 | main state 4 (initial, final:error): 70 | 71 | 9-10 => state 8 (final:skip) 72 | 13 => state 8 (final:skip) 73 | 32 => state 8 (final:skip) 74 | 33 => state 9 (final:lex_bindable) 75 | 35-39 => state 9 (final:lex_bindable) 76 | 42-43 => state 9 (final:lex_bindable) 77 | 45-47 => state 9 (final:lex_bindable) 78 | 48-57 => state 5 (final:lex_number) 79 | 58 => state 9 (final:lex_bindable) 80 | 60 => state 9 (final:lex_bindable) 81 | 61 => state 6 (final:equal) 82 | 62-64 => state 9 (final:lex_bindable) 83 | 65-90 => state 2 (final:lex_bindable) 84 | 94 => state 9 (final:lex_bindable) 85 | 96 => state 9 (final:lex_bindable) 86 | 97-122 => state 2 (final:lex_bindable) 87 | 124 => state 9 (final:lex_bindable) 88 | 126 => state 9 (final:lex_bindable) 89 | EOS => state 1 (sink:eof) 90 | 91 | ----- 92 | 93 | main state 5 (final:lex_number): 94 | 95 | 48-57 => state 5 (final:lex_number) 96 | 97 | ----- 98 | 99 | main state 6 (final:equal): 100 | 101 | 33 => state 9 (final:lex_bindable) 102 | 35-39 => state 9 (final:lex_bindable) 103 | 42-43 => state 9 (final:lex_bindable) 104 | 45-47 => state 9 (final:lex_bindable) 105 | 58 => state 9 (final:lex_bindable) 106 | 60-64 => state 9 (final:lex_bindable) 107 | 94 => state 9 (final:lex_bindable) 108 | 96 => state 9 (final:lex_bindable) 109 | 124 => state 9 (final:lex_bindable) 110 | 126 => state 9 (final:lex_bindable) 111 | 112 | ----- 113 | 114 | main state 7 (final:lex_longident): 115 | 116 | 33 => state 7 (final:lex_longident) 117 | 35-39 => state 7 (final:lex_longident) 118 | 42-43 => state 7 (final:lex_longident) 119 | 45-47 => state 7 (final:lex_longident) 120 | 58 => state 7 (final:lex_longident) 121 | 60-64 => state 7 (final:lex_longident) 122 | 94 => state 7 (final:lex_longident) 123 | 96 => state 7 (final:lex_longident) 124 | 124 => state 7 (final:lex_longident) 125 | 126 => state 7 (final:lex_longident) 126 | 127 | ----- 128 | 129 | main state 8 (final:skip): 130 | 131 | 9-10 => state 8 (final:skip) 132 | 13 => state 8 (final:skip) 133 | 32 => state 8 (final:skip) 134 | 135 | ----- 136 | 137 | main state 9 (final:lex_bindable): 138 | 139 | 33 => state 9 (final:lex_bindable) 140 | 35-39 => state 9 (final:lex_bindable) 141 | 42-43 => state 9 (final:lex_bindable) 142 | 45-47 => state 9 (final:lex_bindable) 143 | 58 => state 9 (final:lex_bindable) 144 | 60-64 => state 9 (final:lex_bindable) 145 | 94 => state 9 (final:lex_bindable) 146 | 96 => state 9 (final:lex_bindable) 147 | 124 => state 9 (final:lex_bindable) 148 | 126 => state 9 (final:lex_bindable) 149 | 150 | ----- 151 | 152 | main state 10: 153 | 154 | 33 => state 7 (final:lex_longident) 155 | 35-39 => state 7 (final:lex_longident) 156 | 42-43 => state 7 (final:lex_longident) 157 | 45-47 => state 7 (final:lex_longident) 158 | 58 => state 7 (final:lex_longident) 159 | 60-64 => state 7 (final:lex_longident) 160 | 65-90 => state 3 (final:lex_longident) 161 | 94 => state 7 (final:lex_longident) 162 | 96 => state 7 (final:lex_longident) 163 | 97-122 => state 3 (final:lex_longident) 164 | 124 => state 7 (final:lex_longident) 165 | 126 => state 7 (final:lex_longident) 166 | 167 | ===== 168 | 169 | Automaton primary 170 | initial state = 4 171 | total states = 5 172 | 173 | ----- 174 | 175 | primary state 2 (final:enter_main): 176 | 177 | 39 => state 2 (final:enter_main) 178 | 48-57 => state 2 (final:enter_main) 179 | 65-90 => state 2 (final:enter_main) 180 | 95 => state 2 (final:enter_main) 181 | 97-122 => state 2 (final:enter_main) 182 | 183 | ----- 184 | 185 | primary state 3 (final:skip): 186 | 187 | 9-10 => state 3 (final:skip) 188 | 13 => state 3 (final:skip) 189 | 32 => state 3 (final:skip) 190 | 191 | ----- 192 | 193 | primary state 4 (initial, final:error): 194 | 195 | 9-10 => state 3 (final:skip) 196 | 13 => state 3 (final:skip) 197 | 32 => state 3 (final:skip) 198 | 65-90 => state 2 (final:enter_main) 199 | 97-122 => state 2 (final:enter_main) 200 | EOS => state 1 (sink:eof) 201 | 202 | *) 203 | 204 | struct 205 | local 206 | structure LexEngine = LexEngineFun (structure Streamable = Streamable 207 | type symbol = Arg.symbol 208 | val ord = Arg.ord) 209 | structure Tables = struct 210 | fun epsilon _ = raise (Fail "Illegal lexeme") 211 | val main = (4, 1, 9, Vector.fromList [Arg.eof,Arg.lex_bindable,Arg.lex_longident,Arg.error,Arg.lex_number,Arg.equal,Arg.lex_longident,Arg.skip,Arg.lex_bindable], LexEngine.next8x1 256 "\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^B\^@\^@\^@\^@\^@\^@\n\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^@\^@\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^B\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^C\^@\^@\^@\^@\^@\^@\n\^@\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^@\^@\^@\^@\^@\^@\^@\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^@\^@\^@\^@\^C\^@\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\b\b\^@\^@\b\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\b\t\^@\t\t\t\t\t\^@\^@\t\t\^@\t\t\t\^E\^E\^E\^E\^E\^E\^E\^E\^E\^E\t\^@\t\^F\t\t\t\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\t\^@\t\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\t\^@\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^E\^E\^E\^E\^E\^E\^E\^E\^E\^E\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\t\t\t\t\^@\^@\t\t\^@\t\t\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\t\t\t\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\a\^@\a\a\a\a\a\^@\^@\a\a\^@\a\a\a\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\a\^@\a\a\a\a\a\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\a\^@\a\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\a\^@\a\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\b\b\^@\^@\b\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\b\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\t\t\t\t\^@\^@\t\t\^@\t\t\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\t\t\t\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\t\^@\t\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\a\^@\a\a\a\a\a\^@\^@\a\a\^@\a\a\a\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\a\^@\a\a\a\a\a\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^@\^@\^@\a\^@\a\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^C\^@\a\^@\a\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@", LexEngine.next0x1 "\^@\^@\^@\^@\^A\^@\^@\^@\^@\^@\^@") 212 | val primary = (4, 1, 4, Vector.fromList [Arg.eof,Arg.enter_main,Arg.skip,Arg.error], LexEngine.next8x1 256 "\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^B\^@\^@\^@\^@\^@\^@\^@\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^@\^@\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^B\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^C\^C\^@\^@\^C\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^C\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^C\^C\^@\^@\^C\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^C\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^@\^@\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^B\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@\^@", LexEngine.next0x1 "\^@\^@\^@\^@\^A") 213 | end 214 | in 215 | fun main s = LexEngine.lex {main=main, primary=primary} Tables.main s 216 | and primary s = LexEngine.lex {main=main, primary=primary} Tables.primary s 217 | end 218 | end 219 | -------------------------------------------------------------------------------- /src/directive_parser/parse/parser.fun: -------------------------------------------------------------------------------- 1 | (* File generated by CM-Yacc version 2.1 *) 2 | 3 | functor ParserFun 4 | (structure Streamable : STREAMABLE 5 | structure Arg : 6 | sig 7 | type int 8 | type longid 9 | type value 10 | type directive 11 | 12 | val main : directive -> directive 13 | val run : unit -> directive 14 | val typeof_id : longid -> directive 15 | val do_help : unit -> directive 16 | val num_last : int -> directive 17 | val bare_last : unit -> directive 18 | val report : longid -> directive 19 | val change_setting : longid * value -> directive 20 | val break_fn : longid -> directive 21 | val break_bind : longid -> directive 22 | val sym_print : longid -> directive 23 | val sym_clear : longid -> directive 24 | val bare_clear : unit -> directive 25 | val num_reveal : int -> directive 26 | val bare_reveal : unit -> directive 27 | val num_prev : int -> directive 28 | val prev : unit -> directive 29 | val stop : unit -> directive 30 | val evaluate : unit -> directive 31 | val step : unit -> directive 32 | val value_num : int -> value 33 | val value_ident : longid -> value 34 | 35 | datatype terminal = 36 | NUM of int 37 | | IDENT of longid 38 | | STEP 39 | | EVALUATE 40 | | REVEAL 41 | | STOP 42 | | EQUAL 43 | | SET 44 | | PREV 45 | | BREAKBIND 46 | | BREAKFN 47 | | RUN 48 | | CLEAR 49 | | PRINT 50 | | REPORT 51 | | LAST 52 | | HELP 53 | | TYPEOF 54 | | EOF 55 | 56 | val error : terminal Streamable.t -> exn 57 | end) 58 | :> 59 | sig 60 | val parse : Arg.terminal Streamable.t -> Arg.directive * Arg.terminal Streamable.t 61 | end 62 | = 63 | 64 | (* 65 | 66 | AUTOMATON LISTING 67 | ================= 68 | 69 | State 0: 70 | 71 | start -> . Main / 0 72 | 2 : Directive -> . STEP / 1 73 | 3 : Directive -> . EVALUATE / 1 74 | 4 : Directive -> . STOP / 1 75 | 5 : Directive -> . PREV / 1 76 | 6 : Directive -> . PREV NUM / 1 77 | 7 : Directive -> . REVEAL / 1 78 | 8 : Directive -> . REVEAL NUM / 1 79 | 9 : Directive -> . CLEAR / 1 80 | 10 : Directive -> . CLEAR IDENT / 1 81 | 11 : Directive -> . PRINT IDENT / 1 82 | 12 : Directive -> . BREAKBIND IDENT / 1 83 | 13 : Directive -> . BREAKFN IDENT / 1 84 | 14 : Directive -> . SET IDENT EQUAL Value / 1 85 | 15 : Directive -> . REPORT IDENT / 1 86 | 16 : Directive -> . LAST / 1 87 | 17 : Directive -> . LAST NUM / 1 88 | 18 : Directive -> . HELP / 1 89 | 19 : Directive -> . TYPEOF IDENT / 1 90 | 20 : Directive -> . RUN / 1 91 | 21 : Main -> . Directive EOF / 0 92 | 93 | STEP => shift 7 94 | EVALUATE => shift 6 95 | REVEAL => shift 5 96 | STOP => shift 4 97 | SET => shift 3 98 | PREV => shift 10 99 | BREAKBIND => shift 9 100 | BREAKFN => shift 8 101 | RUN => shift 2 102 | CLEAR => shift 12 103 | PRINT => shift 15 104 | REPORT => shift 14 105 | LAST => shift 13 106 | HELP => shift 16 107 | TYPEOF => shift 11 108 | Directive => goto 1 109 | Main => goto 17 110 | 111 | ----- 112 | 113 | State 1: 114 | 115 | 21 : Main -> Directive . EOF / 0 116 | 117 | EOF => shift 18 118 | 119 | ----- 120 | 121 | State 2: 122 | 123 | 20 : Directive -> RUN . / 1 124 | 125 | EOF => reduce 20 126 | 127 | ----- 128 | 129 | State 3: 130 | 131 | 14 : Directive -> SET . IDENT EQUAL Value / 1 132 | 133 | IDENT => shift 19 134 | 135 | ----- 136 | 137 | State 4: 138 | 139 | 4 : Directive -> STOP . / 1 140 | 141 | EOF => reduce 4 142 | 143 | ----- 144 | 145 | State 5: 146 | 147 | 7 : Directive -> REVEAL . / 1 148 | 8 : Directive -> REVEAL . NUM / 1 149 | 150 | NUM => shift 20 151 | EOF => reduce 7 152 | 153 | ----- 154 | 155 | State 6: 156 | 157 | 3 : Directive -> EVALUATE . / 1 158 | 159 | EOF => reduce 3 160 | 161 | ----- 162 | 163 | State 7: 164 | 165 | 2 : Directive -> STEP . / 1 166 | 167 | EOF => reduce 2 168 | 169 | ----- 170 | 171 | State 8: 172 | 173 | 13 : Directive -> BREAKFN . IDENT / 1 174 | 175 | IDENT => shift 21 176 | 177 | ----- 178 | 179 | State 9: 180 | 181 | 12 : Directive -> BREAKBIND . IDENT / 1 182 | 183 | IDENT => shift 22 184 | 185 | ----- 186 | 187 | State 10: 188 | 189 | 5 : Directive -> PREV . / 1 190 | 6 : Directive -> PREV . NUM / 1 191 | 192 | NUM => shift 23 193 | EOF => reduce 5 194 | 195 | ----- 196 | 197 | State 11: 198 | 199 | 19 : Directive -> TYPEOF . IDENT / 1 200 | 201 | IDENT => shift 24 202 | 203 | ----- 204 | 205 | State 12: 206 | 207 | 9 : Directive -> CLEAR . / 1 208 | 10 : Directive -> CLEAR . IDENT / 1 209 | 210 | IDENT => shift 25 211 | EOF => reduce 9 212 | 213 | ----- 214 | 215 | State 13: 216 | 217 | 16 : Directive -> LAST . / 1 218 | 17 : Directive -> LAST . NUM / 1 219 | 220 | NUM => shift 26 221 | EOF => reduce 16 222 | 223 | ----- 224 | 225 | State 14: 226 | 227 | 15 : Directive -> REPORT . IDENT / 1 228 | 229 | IDENT => shift 27 230 | 231 | ----- 232 | 233 | State 15: 234 | 235 | 11 : Directive -> PRINT . IDENT / 1 236 | 237 | IDENT => shift 28 238 | 239 | ----- 240 | 241 | State 16: 242 | 243 | 18 : Directive -> HELP . / 1 244 | 245 | EOF => reduce 18 246 | 247 | ----- 248 | 249 | State 17: 250 | 251 | start -> Main . / 0 252 | 253 | $ => accept 254 | 255 | ----- 256 | 257 | State 18: 258 | 259 | 21 : Main -> Directive EOF . / 0 260 | 261 | $ => reduce 21 262 | 263 | ----- 264 | 265 | State 19: 266 | 267 | 14 : Directive -> SET IDENT . EQUAL Value / 1 268 | 269 | EQUAL => shift 29 270 | 271 | ----- 272 | 273 | State 20: 274 | 275 | 8 : Directive -> REVEAL NUM . / 1 276 | 277 | EOF => reduce 8 278 | 279 | ----- 280 | 281 | State 21: 282 | 283 | 13 : Directive -> BREAKFN IDENT . / 1 284 | 285 | EOF => reduce 13 286 | 287 | ----- 288 | 289 | State 22: 290 | 291 | 12 : Directive -> BREAKBIND IDENT . / 1 292 | 293 | EOF => reduce 12 294 | 295 | ----- 296 | 297 | State 23: 298 | 299 | 6 : Directive -> PREV NUM . / 1 300 | 301 | EOF => reduce 6 302 | 303 | ----- 304 | 305 | State 24: 306 | 307 | 19 : Directive -> TYPEOF IDENT . / 1 308 | 309 | EOF => reduce 19 310 | 311 | ----- 312 | 313 | State 25: 314 | 315 | 10 : Directive -> CLEAR IDENT . / 1 316 | 317 | EOF => reduce 10 318 | 319 | ----- 320 | 321 | State 26: 322 | 323 | 17 : Directive -> LAST NUM . / 1 324 | 325 | EOF => reduce 17 326 | 327 | ----- 328 | 329 | State 27: 330 | 331 | 15 : Directive -> REPORT IDENT . / 1 332 | 333 | EOF => reduce 15 334 | 335 | ----- 336 | 337 | State 28: 338 | 339 | 11 : Directive -> PRINT IDENT . / 1 340 | 341 | EOF => reduce 11 342 | 343 | ----- 344 | 345 | State 29: 346 | 347 | 0 : Value -> . IDENT / 1 348 | 1 : Value -> . NUM / 1 349 | 14 : Directive -> SET IDENT EQUAL . Value / 1 350 | 351 | NUM => shift 32 352 | IDENT => shift 31 353 | Value => goto 30 354 | 355 | ----- 356 | 357 | State 30: 358 | 359 | 14 : Directive -> SET IDENT EQUAL Value . / 1 360 | 361 | EOF => reduce 14 362 | 363 | ----- 364 | 365 | State 31: 366 | 367 | 0 : Value -> IDENT . / 1 368 | 369 | EOF => reduce 0 370 | 371 | ----- 372 | 373 | State 32: 374 | 375 | 1 : Value -> NUM . / 1 376 | 377 | EOF => reduce 1 378 | 379 | ----- 380 | 381 | lookahead 0 = $ 382 | lookahead 1 = EOF 383 | 384 | *) 385 | 386 | struct 387 | local 388 | structure Value = struct 389 | datatype nonterminal = 390 | nonterminal 391 | | int of Arg.int 392 | | longid of Arg.longid 393 | | value of Arg.value 394 | | directive of Arg.directive 395 | end 396 | structure ParseEngine = ParseEngineFun (structure Streamable = Streamable 397 | type terminal = Arg.terminal 398 | type value = Value.nonterminal 399 | val dummy = Value.nonterminal 400 | fun read terminal = 401 | (case terminal of 402 | Arg.NUM x => (1, Value.int x) 403 | | Arg.IDENT x => (2, Value.longid x) 404 | | Arg.STEP => (3, Value.nonterminal) 405 | | Arg.EVALUATE => (4, Value.nonterminal) 406 | | Arg.REVEAL => (5, Value.nonterminal) 407 | | Arg.STOP => (6, Value.nonterminal) 408 | | Arg.EQUAL => (7, Value.nonterminal) 409 | | Arg.SET => (8, Value.nonterminal) 410 | | Arg.PREV => (9, Value.nonterminal) 411 | | Arg.BREAKBIND => (10, Value.nonterminal) 412 | | Arg.BREAKFN => (11, Value.nonterminal) 413 | | Arg.RUN => (12, Value.nonterminal) 414 | | Arg.CLEAR => (13, Value.nonterminal) 415 | | Arg.PRINT => (14, Value.nonterminal) 416 | | Arg.REPORT => (15, Value.nonterminal) 417 | | Arg.LAST => (16, Value.nonterminal) 418 | | Arg.HELP => (17, Value.nonterminal) 419 | | Arg.TYPEOF => (18, Value.nonterminal) 420 | | Arg.EOF => (19, Value.nonterminal) 421 | ) 422 | ) 423 | in 424 | val parse = ParseEngine.parse ( 425 | ParseEngine.next5x1 "\128\128\128\136\135\134\133\128\132\139\138\137\131\141\144\143\142\145\140\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\147\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128j\128\128\128\128\128\128\128\128\128\128\128\128\128\128\148\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128z\128\128\128\128\128\128\128\128\128\128\128\128\128\149\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128w\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128{\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128|\128\128\128\128\128\128\128\128\128\128\128\128\128\128\150\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\151\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\152\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128y\128\128\128\128\128\128\128\128\128\128\128\128\128\128\153\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\154\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128u\128\128\128\128\128\128\128\128\128\128\128\128\128\155\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128n\128\128\128\128\128\128\128\128\128\128\128\128\128\128\156\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\157\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128l\128\128\128\128\128\128\128\128\128\128\128\128\127\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128i\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\158\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128v\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128q\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128r\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128x\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128k\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128t\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128m\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128o\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128s\128\128\128\128\128\128\128\128\128\128\128\128\128\161\160\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128p\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128~\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128}\128\128\128\128\128\128\128\128\128\128\128\128", 426 | ParseEngine.next5x1 "\128\129\145\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\158\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128\128", 427 | Vector.fromList [(0,1,(fn Value.longid(arg0)::rest => Value.value(Arg.value_ident arg0)::rest|_=>raise (Fail "bad parser"))), 428 | (0,1,(fn Value.int(arg0)::rest => Value.value(Arg.value_num arg0)::rest|_=>raise (Fail "bad parser"))), 429 | (1,1,(fn _::rest => Value.directive(Arg.step {})::rest|_=>raise (Fail "bad parser"))), 430 | (1,1,(fn _::rest => Value.directive(Arg.evaluate {})::rest|_=>raise (Fail "bad parser"))), 431 | (1,1,(fn _::rest => Value.directive(Arg.stop {})::rest|_=>raise (Fail "bad parser"))), 432 | (1,1,(fn _::rest => Value.directive(Arg.prev {})::rest|_=>raise (Fail "bad parser"))), 433 | (1,2,(fn Value.int(arg0)::_::rest => Value.directive(Arg.num_prev arg0)::rest|_=>raise (Fail "bad parser"))), 434 | (1,1,(fn _::rest => Value.directive(Arg.bare_reveal {})::rest|_=>raise (Fail "bad parser"))), 435 | (1,2,(fn Value.int(arg0)::_::rest => Value.directive(Arg.num_reveal arg0)::rest|_=>raise (Fail "bad parser"))), 436 | (1,1,(fn _::rest => Value.directive(Arg.bare_clear {})::rest|_=>raise (Fail "bad parser"))), 437 | (1,2,(fn Value.longid(arg0)::_::rest => Value.directive(Arg.sym_clear arg0)::rest|_=>raise (Fail "bad parser"))), 438 | (1,2,(fn Value.longid(arg0)::_::rest => Value.directive(Arg.sym_print arg0)::rest|_=>raise (Fail "bad parser"))), 439 | (1,2,(fn Value.longid(arg0)::_::rest => Value.directive(Arg.break_bind arg0)::rest|_=>raise (Fail "bad parser"))), 440 | (1,2,(fn Value.longid(arg0)::_::rest => Value.directive(Arg.break_fn arg0)::rest|_=>raise (Fail "bad parser"))), 441 | (1,4,(fn Value.value(arg0)::_::Value.longid(arg1)::_::rest => Value.directive(Arg.change_setting {2=arg0,1=arg1})::rest|_=>raise (Fail "bad parser"))), 442 | (1,2,(fn Value.longid(arg0)::_::rest => Value.directive(Arg.report arg0)::rest|_=>raise (Fail "bad parser"))), 443 | (1,1,(fn _::rest => Value.directive(Arg.bare_last {})::rest|_=>raise (Fail "bad parser"))), 444 | (1,2,(fn Value.int(arg0)::_::rest => Value.directive(Arg.num_last arg0)::rest|_=>raise (Fail "bad parser"))), 445 | (1,1,(fn _::rest => Value.directive(Arg.do_help {})::rest|_=>raise (Fail "bad parser"))), 446 | (1,2,(fn Value.longid(arg0)::_::rest => Value.directive(Arg.typeof_id arg0)::rest|_=>raise (Fail "bad parser"))), 447 | (1,1,(fn _::rest => Value.directive(Arg.run {})::rest|_=>raise (Fail "bad parser"))), 448 | (2,2,(fn _::Value.directive(arg0)::rest => Value.directive(Arg.main arg0)::rest|_=>raise (Fail "bad parser")))], 449 | (fn Value.directive x => x | _ => raise (Fail "bad parser")), Arg.error) 450 | end 451 | end 452 | --------------------------------------------------------------------------------