├── .github └── workflows │ └── workflow.yml ├── .gitignore ├── .gitmodules ├── .ocaml-gh ├── .ocamlformat ├── .prettierrc ├── LICENSE.md ├── README.md ├── SYNTAX.md ├── docs ├── .gitignore ├── cm-utils.js ├── fom-alternatives.js ├── fom-cm-mode.js ├── fom-cm-util.js ├── index.css ├── index.html ├── prelude.js ├── setup.js ├── util.js ├── worker-main.js └── worker.js ├── dune ├── dune-project ├── examples ├── aggregate-syntax.fom ├── aggregate-syntax.fomi ├── aggregate-syntax.js ├── aggregate-syntax.out ├── bounded-subtyping-of-counters.fom ├── bounded-subtyping-of-counters.fomi ├── bounded-subtyping-of-counters.js ├── bounded-subtyping-of-counters.out ├── effect-reader.fom ├── effect-reader.fomi ├── effect-reader.js ├── effect-reader.out ├── equality-witnesses.fom ├── equality-witnesses.fomi ├── equality-witnesses.js ├── equality-witnesses.out ├── equirecursive-fixpoint-combinator.fom ├── equirecursive-fixpoint-combinator.fomi ├── equirecursive-fixpoint-combinator.js ├── equirecursive-fixpoint-combinator.out ├── errors │ ├── exit.fom │ ├── exit.out │ ├── nested.fom │ ├── nested.out │ ├── test-local-scoping.fom │ └── test-local-scoping.out ├── f-omega-self-interpreter.fom ├── f-omega-self-interpreter.fomi ├── f-omega-self-interpreter.js ├── f-omega-self-interpreter.out ├── fact.fom ├── fact.fomi ├── fact.js ├── fact.out ├── fib.fom ├── fib.fomi ├── fib.js ├── fib.out ├── finally-tagless.fom ├── finally-tagless.fomi ├── finally-tagless.js ├── finally-tagless.out ├── first-order-and-higher-kinded-lists.fom ├── first-order-and-higher-kinded-lists.fomi ├── first-order-and-higher-kinded-lists.js ├── first-order-and-higher-kinded-lists.out ├── generic-folds.fom ├── generic-folds.fomi ├── generic-folds.js ├── generic-folds.out ├── graph-library.fom ├── graph-library.fomi ├── graph-library.js ├── graph-library.out ├── hmap-using-universal-embedding.fom ├── hmap-using-universal-embedding.fomi ├── hmap-using-universal-embedding.js ├── hmap-using-universal-embedding.out ├── hoas-gadt.fom ├── hoas-gadt.fomi ├── hoas-gadt.js ├── hoas-gadt.out ├── lib │ ├── algebras.fom │ ├── algebras.fomd │ ├── algebras.fomt │ ├── array.fom │ ├── array.fomd │ ├── array.fomt │ ├── bool.fom │ ├── bool.fomt │ ├── console.fom │ ├── dispenser.fom │ ├── dispenser.fomd │ ├── dispenser.fomt │ ├── eq.fom │ ├── eq.fomd │ ├── eq.fomt │ ├── int.fom │ ├── int.fomt │ ├── list.fom │ ├── list.fomt │ ├── map.fom │ ├── map.fomd │ ├── map.fomt │ ├── opt.fom │ ├── queue.fom │ ├── queue.fomt │ ├── ref.fom │ ├── ref.fomd │ ├── ref.fomt │ ├── stack.fom │ ├── stack.fomt │ ├── string.fom │ ├── string.fomt │ ├── target.fom │ ├── types.fomd │ ├── univ.fom │ ├── univ.fomd │ └── univ.fomt ├── list-encoding.fom ├── list-encoding.fomi ├── list-encoding.js ├── list-encoding.out ├── list.fom ├── list.fomi ├── list.js ├── list.out ├── lists-of-various-lengths.fom ├── lists-of-various-lengths.fomi ├── lists-of-various-lengths.js ├── lists-of-various-lengths.out ├── nat-gadt-using-eq-witnesses.fom ├── nat-gadt-using-eq-witnesses.fomi ├── nat-gadt-using-eq-witnesses.js ├── nat-gadt-using-eq-witnesses.out ├── nat-gadt.fom ├── nat-gadt.fomi ├── nat-gadt.js ├── nat-gadt.out ├── object-oriented-sets.fom ├── object-oriented-sets.fomi ├── object-oriented-sets.js ├── object-oriented-sets.out ├── pick-apple.fom ├── pick-apple.fomi ├── pick-apple.js ├── pick-apple.out ├── polymorphic-container-without-pretense.fom ├── polymorphic-container-without-pretense.fomi ├── polymorphic-container-without-pretense.js ├── polymorphic-container-without-pretense.out ├── polymorphic-container-without-recursion.fom ├── polymorphic-container-without-recursion.fomi ├── polymorphic-container-without-recursion.js ├── polymorphic-container-without-recursion.out ├── simple-push-stream.fom ├── simple-push-stream.fomi ├── simple-push-stream.js ├── simple-push-stream.out ├── ski-combinators.fom ├── ski-combinators.fomi ├── ski-combinators.js ├── ski-combinators.out ├── stack-adt.fom ├── stack-adt.fomi ├── stack-adt.js ├── stack-adt.out ├── stream-fusion.fom ├── stream-fusion.fomi ├── stream-fusion.js ├── stream-fusion.out ├── template-strings.fom ├── template-strings.fomi ├── template-strings.js ├── template-strings.out ├── type-gadt-using-eq-witnesses.fom ├── type-gadt-using-eq-witnesses.fomi ├── type-gadt-using-eq-witnesses.js ├── type-gadt-using-eq-witnesses.out ├── type-indexed-trie.fom ├── type-indexed-trie.fomi ├── type-indexed-trie.js ├── type-indexed-trie.out ├── type-level-programming.fom ├── type-level-programming.fomi ├── type-level-programming.js └── type-level-programming.out ├── opam ├── regression ├── 123.fom ├── 123.fomi ├── 123.js ├── 123.out ├── let-hoisting.fom ├── let-hoisting.fomi ├── let-hoisting.js └── let-hoisting.out └── src ├── main ├── FomAST │ ├── FomAST.ml │ ├── FomAST.mli │ └── dune ├── FomAnnot │ ├── FomAnnot.ml │ └── dune ├── FomCST │ ├── FomCST.ml │ └── dune ├── FomChecker │ ├── Exp.ml │ ├── FomChecker.ml │ ├── Kind.ml │ ├── Label.ml │ ├── LabelMap.ml │ ├── Row.ml │ ├── Typ.ml │ └── dune ├── FomCommand │ ├── FomCommand.ml │ └── dune ├── FomDiag │ ├── Diagnostic.ml │ ├── Diagnostic.mli │ ├── FomDiag.ml │ ├── Typ.ml │ └── dune ├── FomElab │ ├── FomElab.ml │ ├── FomElab.mli │ └── dune ├── FomEnv │ ├── FomEnv.ml │ ├── FomEnv.mli │ └── dune ├── FomError │ ├── Error.ml │ ├── FomError.ml │ └── dune ├── FomPP │ ├── FomPP.ml │ ├── FomPP.mli │ └── dune ├── FomPPrint │ ├── FomPPrint.ml │ └── dune ├── FomParser │ ├── Buffer.ml │ ├── FomParser.ml │ ├── FomParser.mli │ ├── Grammar.mly │ ├── LexTrn.ml │ ├── LexTrn.mli │ ├── Lexer.ml │ ├── Offside.ml │ ├── Parser.ml │ ├── Token.ml │ ├── Tokenizer.ml │ └── dune ├── FomSandbox │ ├── FomSandbox.ml │ └── dune ├── FomSource │ ├── FomSource.ml │ ├── Id.ml │ ├── Id.mli │ ├── Loc.ml │ ├── Loc.mli │ └── dune ├── FomToJs │ ├── FomToJs.ml │ ├── FomToJs.mli │ ├── FomToLam.ml │ ├── Js.ml │ ├── Js.mli │ ├── Lam.ml │ ├── LamCore.ml │ ├── LamHoist.ml │ ├── LamSimplify.ml │ ├── LamToJs.ml │ └── dune ├── FomToJsC │ ├── FomToJsC.ml │ ├── FomToJsC.mli │ └── dune └── FomToJsRT │ ├── FomToJsRT.ml │ └── dune └── test ├── FomAST ├── FomASTTest.ml └── dune ├── FomChecker ├── FomCheckerTest.ml └── dune ├── FomElab ├── FomElabTest.ml └── dune ├── FomParser ├── FomParserTest.ml └── dune ├── FomSource ├── FomSourceTest.ml └── dune └── FomToJs ├── FomToJsTest.ml └── dune /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: build-and-test 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches-ignore: 7 | - gh-pages 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: 15 | - ubuntu-latest 16 | ocaml-compiler: 17 | - 5.x 18 | - 4.x 19 | 20 | runs-on: ${{ matrix.os }} 21 | 22 | steps: 23 | - name: Checkout code 24 | uses: actions/checkout@v3 25 | with: 26 | submodules: true 27 | 28 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 29 | uses: ocaml/setup-ocaml@v2 30 | with: 31 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 32 | 33 | - name: Clone ocaml-gh 34 | run: git clone --depth 1 https://github.com/polytypic/ocaml-gh.git 35 | 36 | - name: Install Git Deps 37 | run: ./ocaml-gh/bin/ocaml-gh install-git-deps 38 | 39 | - name: Install dependencies 40 | run: opam pin . --yes 41 | 42 | - name: Install prettier 43 | run: npm i -g prettier@2.5.1 44 | 45 | - name: Build and test 46 | run: ./ocaml-gh/bin/ocaml-gh ci 47 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _opam 3 | examples/*.fom.js 4 | ocaml-gh 5 | regression/*.fom.js 6 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "src/StdlibPlus"] 2 | path = src/StdlibPlus 3 | url = https://github.com/polytypic/StdlibPlus.git 4 | [submodule "dep/StdlibPlus"] 5 | path = dep/StdlibPlus 6 | url = https://github.com/polytypic/StdlibPlus.git 7 | -------------------------------------------------------------------------------- /.ocaml-gh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | export PROJECT=f-omega-mu 4 | export GIT_DEPS=(https://github.com/polytypic/StdlibPlus.git) 5 | export GIT=git@github.com:polytypic/$PROJECT.git 6 | 7 | export WATCHEXEC_OPTS=(--ignore '*.fomi' --ignore '*.js' --ignore '*.out') 8 | 9 | export FOM_COMMAND=_build/default/src/main/FomCommand/FomCommand.exe 10 | 11 | foms=(examples/*.fom regression/*.fom) 12 | 13 | ocaml-gh-ci-after-build-and-test() { 14 | 15 | folded "Building JS runtime" \ 16 | build-js src/main/FomToJsRT/FomToJsRT.bc.js docs/FomToJsRT.js 17 | 18 | folded "Typing examples" \ 19 | timeout 10 type_examples 20 | 21 | folded "Running error examples" \ 22 | timeout 10 run_error_examples 23 | 24 | folded "Compiling and Evaluating examples" \ 25 | timeout 10 js_and_eval_examples 26 | } 27 | 28 | type_examples() { 29 | for fom in "${foms[@]}"; do 30 | read -r code 31 | echo "$code" > "${fom%.fom}.fomi" 32 | done < <($FOM_COMMAND -max-width 0 -stop type "${foms[@]}") 33 | } 34 | 35 | eval_examples() { 36 | for fom in "${foms[@]}"; do 37 | read -r code 38 | echo "$code" > "${fom%.fom}.out" 39 | done < <($FOM_COMMAND -max-width 0 -stop eval "${foms[@]}") 40 | } 41 | 42 | js_examples() { 43 | for fom in "${foms[@]}"; do 44 | read -r code 45 | echo "$code" > "${fom%.fom}.js" 46 | done < <($FOM_COMMAND -max-width 0 -stop js "${foms[@]}") 47 | 48 | prettier -w examples/*.js regression/*.js > /dev/null 49 | } 50 | 51 | js_and_eval_examples() { 52 | parallel js_examples eval_examples 53 | } 54 | 55 | error_foms=(examples/errors/*.fom) 56 | 57 | run_error_examples() { 58 | for fom in "${error_foms[@]}"; do 59 | out="${fom%.fom}.out" 60 | if $FOM_COMMAND "$fom" 2>&1 | sed -e "s#$(pwd)##g" > "$out"; then 61 | echo "$fom unexpectedly ran successfully" 62 | exit 1 63 | fi 64 | done 65 | } 66 | 67 | # 68 | 69 | ocaml-gh-ci-after-build-docs() { 70 | build-examples & 71 | 72 | build-js src/main/FomSandbox/FomSandbox.bc.js docs/FomSandbox.js 73 | 74 | wait 75 | } 76 | 77 | build-js() { 78 | local TARGET="$1" 79 | local OUTPUT="$2" 80 | 81 | opam exec -- dune build --root=. --profile release "./$TARGET" 82 | 83 | echo "'use strict';" > "$OUTPUT" 84 | cat "./_build/default/$TARGET" >> "$OUTPUT" 85 | } 86 | 87 | build-examples() { 88 | local OUTPUT=docs/examples.js 89 | 90 | rm -rf docs/examples 91 | mkdir -p docs/examples 92 | 93 | echo "export const examples = [" > $OUTPUT 94 | for example in examples/*.fom; do 95 | cp "$example" docs/examples/ 96 | echo " '$example'," >> $OUTPUT 97 | done 98 | echo "]" >> $OUTPUT 99 | 100 | cp -r examples/lib docs/examples/lib 101 | cp -r examples/errors docs/examples/errors 102 | 103 | rm -rf docs/regression 104 | mkdir -p docs/regression 105 | cp regression/*.fom docs/regression 106 | } 107 | 108 | # 109 | 110 | timeout() { 111 | local TIMEOUT="$1" 112 | shift 113 | "$@" & local PID=$! 114 | (sleep "$TIMEOUT"; kill $PID 2>/dev/null || true) & local WAITER=$! 115 | local EXIT_CODE=0 116 | wait $PID 2>/dev/null || EXIT_CODE=$? 117 | if ! kill $WAITER 2>/dev/null; then 118 | echo TIMEOUT: "$@" 2>&1 119 | return "$TIMEOUT" 120 | fi 121 | return $EXIT_CODE 122 | } 123 | 124 | parallel() { 125 | local PIDS=() 126 | while [ $# != 0 ]; do 127 | $1 & PIDS+=($!) 128 | shift 129 | done 130 | for PID in "${PIDS[@]}"; do 131 | local EXIT_CODE=0 132 | wait "$PID" 2>/dev/null || EXIT_CODE=$? 133 | if [ $EXIT_CODE != 0 ]; then 134 | kill "${PIDS[@]}" 2>/dev/null || true 135 | return $EXIT_CODE 136 | fi 137 | done 138 | } 139 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.24.1 2 | 3 | module-item-spacing=compact 4 | 5 | space-around-arrays=false 6 | space-around-lists=false 7 | space-around-records=false 8 | space-around-variants=false 9 | 10 | cases-exp-indent=2 11 | -------------------------------------------------------------------------------- /.prettierrc: -------------------------------------------------------------------------------- 1 | { 2 | "arrowParens": "avoid", 3 | "bracketSpacing": false, 4 | "printWidth": 80, 5 | "semi": false, 6 | "singleQuote": true, 7 | "proseWrap": "always" 8 | } 9 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright © 2020-2022 Vesa Karvonen 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | -------------------------------------------------------------------------------- /docs/.gitignore: -------------------------------------------------------------------------------- 1 | FomSandbox.js 2 | FomToJsRT.js 3 | examples 4 | examples.js 5 | regression 6 | -------------------------------------------------------------------------------- /docs/cm-utils.js: -------------------------------------------------------------------------------- 1 | export const getTokenEndingAt = (cm, cursor) => { 2 | const token = cm.getTokenAt(cursor) 3 | if (!token || token.end < cursor.ch || cursor.ch <= token.start) 4 | return undefined 5 | if (token.end !== cursor.ch) { 6 | token.string = token.string.slice(0, cursor.ch - token.end) 7 | token.end = cursor.ch 8 | } 9 | return token 10 | } 11 | 12 | export const getWidth = cm => { 13 | const charWidth = cm.defaultCharWidth() 14 | const scrollArea = cm.getScrollInfo() 15 | const scrollLeft = cm.doc.scrollLeft 16 | 17 | const leftColumn = Math.ceil(scrollLeft > 0 ? scrollLeft / charWidth : 0) 18 | const rightPosition = scrollLeft + (scrollArea.clientWidth - 30) 19 | const rightColumn = Math.floor(rightPosition / charWidth) 20 | 21 | return Math.max(0, rightColumn - leftColumn) 22 | } 23 | -------------------------------------------------------------------------------- /docs/fom-alternatives.js: -------------------------------------------------------------------------------- 1 | export const alternatives = Object.create(null) 2 | 3 | for (const {unicode, ascii, bop} of fom.synonyms()) 4 | alternatives[ascii] = unicode + (bop ? ' ' : '') 5 | 6 | for (const [basename, upper, lower, alternate] of [ 7 | ['Alpha', 'A', 'α'], 8 | ['Beta', 'B', 'β'], 9 | ['Gamma', 'Γ', 'γ'], 10 | ['Delta', 'Δ', 'δ'], 11 | ['Epsilon', 'E', 'ϵ', 'ε'], 12 | ['Zeta', 'Ζ', 'ζ'], 13 | ['Eta', 'Η', 'η'], 14 | ['Theta', 'Θ', 'θ', 'ϑ'], 15 | ['Iota', 'Ι', 'ι'], 16 | ['Kappa', 'Κ', 'κ', 'ϰ'], 17 | ['Lambda', 'Λ', 'λ'], 18 | ['Mu', 'Μ', 'μ'], 19 | ['Nu', 'Ν', 'ν'], 20 | ['Xi', 'Ξ', 'ξ'], 21 | ['Omicron', 'O', 'ℴ'], 22 | ['Pi', 'Π', 'π', 'ϖ'], 23 | ['Rho', 'Ρ', 'ρ', 'ϱ'], 24 | ['Sigma', 'Σ', 'σ', 'ς'], 25 | ['Tau', 'Τ', 'τ'], 26 | ['Upsilon', 'ϒ', 'υ'], 27 | ['Phi', 'Φ', 'ϕ', 'φ'], 28 | ['Chi', 'X', 'χ'], 29 | ['Psi', 'Ψ', 'ψ'], 30 | ['Omega', 'Ω', 'ω'], 31 | ]) { 32 | alternatives[`\\${basename}`] = upper 33 | alternatives[`\\${basename.toLowerCase()}`] = lower 34 | if (alternate) alternatives[`\\var${basename.toLowerCase()}`] = alternate 35 | } 36 | -------------------------------------------------------------------------------- /docs/fom-cm-mode.js: -------------------------------------------------------------------------------- 1 | import {nextNonSpace} from './util.js' 2 | 3 | CodeMirror.defineMode('fom', () => ({ 4 | startState: () => ({previous: '', state: fom.initial}), 5 | token: (stream, state) => { 6 | const start = stream.start 7 | 8 | const input = stream.string.slice(stream.start) 9 | const token = fom.token(input, state.state) 10 | 11 | state.state = token.state 12 | 13 | if (token.name === 'error') { 14 | stream.skipToEnd() 15 | } else { 16 | stream.start += fom.offset16(input, token.begins) 17 | stream.pos += fom.offset16(input, token.ends) 18 | } 19 | 20 | if ( 21 | token.name === 'variable' && 22 | (nextNonSpace(stream.string, stream.start - 1, -1) === "'" || 23 | ((nextNonSpace(stream.string, stream.pos) === ':' || 24 | nextNonSpace(stream.string, stream.pos) === '=') && 25 | (state.previous === 'punctuation' || 26 | (stream.start && 27 | !nextNonSpace(stream.string, stream.start - 1, -1))))) 28 | ) { 29 | token.name = 'property' 30 | } 31 | 32 | state.previous = token.name 33 | 34 | return token.name 35 | }, 36 | })) 37 | -------------------------------------------------------------------------------- /docs/fom-cm-util.js: -------------------------------------------------------------------------------- 1 | export const addMarker = (markers, cm, pos, annot) => 2 | markers.push( 3 | cm.markText(posAsNative(cm, pos.begins), posAsNative(cm, pos.ends), annot) 4 | ) 5 | 6 | export const clearMarkers = markers => { 7 | markers.forEach(mark => mark.clear()) 8 | markers.length = 0 9 | } 10 | 11 | export const posAsNative = (cm, {line, ch}) => { 12 | const input = cm.getLine(line) || '' 13 | return {line, ch: fom.offset16(input, ch)} 14 | } 15 | -------------------------------------------------------------------------------- /docs/index.css: -------------------------------------------------------------------------------- 1 | select { 2 | text-align-last: center; 3 | } 4 | 5 | .markdown-body { 6 | box-sizing: border-box; 7 | min-width: 200px; 8 | max-width: 980px; 9 | margin: 2%; 10 | padding: 45px; 11 | border: 1px #30363d solid; 12 | border-radius: 3px; 13 | color: #c9d1d9; 14 | background: #0d1117; 15 | } 16 | 17 | .CodeMirror.cm-s-dracula { 18 | font: 13.6px Consolas, 'Liberation Mono', SF Mono, Menlo, Courier, monospace; 19 | line-height: 19.72px; 20 | height: auto; 21 | background: #20222e !important; 22 | border: 2px #282a36 solid; 23 | border-radius: 5px; 24 | z-index: 1; 25 | box-shadow: 3px 3px 10px #0d1117; 26 | } 27 | 28 | #depsDl dt { 29 | margin-bottom: 0.5em; 30 | } 31 | 32 | #editInput:not(:checked) ~ #replaceSymbolsSpan, 33 | #depsSelect:not(:checked) ~ #depsDl, 34 | #jsSelect:not(:checked) ~ #terserSpan, 35 | #jsSelect:not(:checked) ~ #prettifySpan, 36 | #jsSelect:not(:checked) ~ #jsDiv { 37 | display: none; 38 | } 39 | 40 | #jsDiv .CodeMirror.cm-s-dracula { 41 | margin-top: 1em; 42 | } 43 | 44 | #fomDiv .CodeMirror.cm-s-dracula:hover, 45 | #resultDiv .CodeMirror.cm-s-dracula:hover, 46 | #typDiv .CodeMirror.cm-s-dracula:hover, 47 | #jsDiv .CodeMirror.cm-s-dracula:hover, 48 | #depsDl .CodeMirror.cm-s-dracula:hover { 49 | border: 2px #40464d solid; 50 | } 51 | 52 | #resultDiv .CodeMirror.cm-s-dracula, 53 | #jsDiv .CodeMirror.cm-s-dracula, 54 | #depsDl .CodeMirror.cm-s-dracula { 55 | background: #282a36 !important; 56 | margin-bottom: 1em; 57 | } 58 | 59 | #typDiv .CodeMirror { 60 | background: #30333e !important; 61 | border: 2px #30333e solid; 62 | position: fixed; 63 | top: 1em; 64 | right: 1em; 65 | z-index: 0; 66 | transition-property: z-index; 67 | transition-delay: 5s; 68 | } 69 | 70 | #typDiv .CodeMirror:hover, 71 | #typDiv.show .CodeMirror { 72 | z-index: 10; 73 | transition: none; 74 | } 75 | 76 | #typDiv.no-keywords .CodeMirror .cm-keyword { 77 | color: #50fa7b; 78 | } 79 | 80 | .om { 81 | font-size: 50%; 82 | display: inline-flex; 83 | transform: translate(0, 8%); 84 | align-items: center; 85 | justify-content: center; 86 | flex-direction: column-reverse; 87 | } 88 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 9 | Fωμ type checker and compiler 10 | 15 | 20 | 25 | 30 | 31 | 32 | 33 |

34 | Fωμ 35 | type checker and compiler — Sandbox · 36 | GitHub stars 41 |

42 |
43 |
44 |
45 |

46 | Try 47 | Fωμ 52 | above! 53 | 56 |

57 |
58 | 59 | 60 | 61 | 62 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 82 | 83 | 84 | 85 | 88 | 89 |
90 |
91 | 96 | 100 | 104 | 108 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | -------------------------------------------------------------------------------- /docs/prelude.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | 3 | const rec = (() => { 4 | const iterator = [][Symbol.iterator] 5 | 6 | const writable = Object.freeze({writable: true}) 7 | const writableFunction = Object.freeze({ 8 | arguments: writable, 9 | callee: writable, 10 | caller: writable, 11 | length: writable, 12 | name: writable, 13 | }) 14 | 15 | return fn => { 16 | const proxy = x => knot(x) 17 | const knot = fn(proxy) 18 | if (typeof knot === 'object') { 19 | if (Array.isArray(knot)) { 20 | Object.defineProperty(proxy, 'length', {value: knot.length}) 21 | proxy[Symbol.iterator] = iterator 22 | } else { 23 | Object.defineProperties(proxy, writableFunction) 24 | } 25 | Object.assign(proxy, knot) 26 | Object.setPrototypeOf(proxy, Object.getPrototypeOf(knot)) 27 | return proxy 28 | } else { 29 | return knot 30 | } 31 | } 32 | })() 33 | -------------------------------------------------------------------------------- /docs/util.js: -------------------------------------------------------------------------------- 1 | export const cmps = (l, toR) => (l === 0 ? toR() : l) 2 | 3 | export const get = (o, p, ...ps) => 4 | o != null && p != null ? get(o[p], ...ps) : o 5 | 6 | export const nextNonSpace = (str, i, dir = 1) => { 7 | while (0 <= i && i < str.length) { 8 | const c = str[i] 9 | if (c !== ' ' && c !== '\t' && c !== '\n') return c 10 | i += dir 11 | } 12 | return '' 13 | } 14 | 15 | export const throttled = (ms, fn) => { 16 | let timeout = null 17 | return (...args) => { 18 | clearTimeout(timeout) 19 | timeout = setTimeout(fn, ms, ...args) 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /docs/worker-main.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | 3 | // Error.stackTraceLimit = undefined // Unlimited stack trace on Chrome 4 | 5 | const timingStart = () => performance.now() 6 | const timingEnd = (message, start) => { 7 | console.log(message + ' took ' + ((performance.now() - start) | 0) + 'ms') 8 | } 9 | 10 | const timed = (message, thunk) => { 11 | const start = timingStart() 12 | const result = thunk() 13 | timingEnd(message, start) 14 | return result 15 | } 16 | 17 | class ErrorWithContext extends Error { 18 | constructor(error, context) { 19 | super(`${error instanceof Error ? error.message : error} (${context})`) 20 | this.error = error 21 | } 22 | 23 | get name() { 24 | const error = this.error 25 | return error instanceof Error ? error.name : '' 26 | } 27 | } 28 | 29 | const withContext = (context, thunk) => { 30 | try { 31 | return thunk() 32 | } catch (error) { 33 | throw new ErrorWithContext(error, context) 34 | } 35 | } 36 | 37 | const tryIn = (thunk, onSuccess, onFailure) => { 38 | let result 39 | try { 40 | result = thunk() 41 | } catch (error) { 42 | return onFailure(error) 43 | } 44 | return onSuccess(result) 45 | } 46 | 47 | onmessage = message => { 48 | onmessage = null 49 | eval(message.data) 50 | } 51 | -------------------------------------------------------------------------------- /docs/worker.js: -------------------------------------------------------------------------------- 1 | export const onWorker = ({init, before, compute, after}) => { 2 | const code = `(() => { 3 | (${init})() 4 | const compute = ${compute} 5 | onmessage = ({data}) => 6 | compute(data, (data, continues = false) => postMessage({data, continues})) 7 | })()` 8 | 9 | let working = false 10 | let worker 11 | 12 | return (...args) => { 13 | if (working) { 14 | worker.terminate() 15 | worker = undefined 16 | working = false 17 | } 18 | if (worker === undefined) { 19 | worker = new Worker('worker-main.js') 20 | worker.postMessage(code) 21 | worker.onmessage = ({data: {data, continues}}) => { 22 | working = continues 23 | after(data) 24 | } 25 | } 26 | working = true 27 | worker.postMessage(before(...args)) 28 | } 29 | } 30 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (dirs src) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.6) 2 | 3 | (name fom) 4 | (using menhir 2.1) 5 | -------------------------------------------------------------------------------- /examples/aggregate-syntax.fom: -------------------------------------------------------------------------------- 1 | # Aggregate syntax 2 | 3 | # Fωμ provides syntax for aggregate expressions and types: 4 | 5 | let an_aggregate: [int, int, int] = [1, 2, 3] 6 | 7 | # Lists 8 | 9 | type μlist = λα.'Nil | 'Cons (α, list α) 10 | 11 | # correspond to a particular form of aggregates and such aggregates can be 12 | # directly used as lists: 13 | 14 | let a_list: list int = [1, 2, 3] 15 | 16 | # The list type can also be expressed as a recursive join of aggregates: 17 | 18 | type μlist = λα.[] ∨ [α, …list α] 19 | 20 | # Aggregates are not limited to homogenous lists. Aggregate values and types 21 | # are structural and may be heterogenous. 22 | 23 | let a_heterogenous_aggregate: [int, string, (string, int)] = [1, "a", ("b", 2)] 24 | 25 | # The spine of an aggregate is always finite and the types of all elements are 26 | # known. This information is also manifest in the type of an aggregate. 27 | 28 | # Although not yet implemented in the toy Fωμ compiler, optimizing code around 29 | # finite aggregates should be relatively easy. For example, it should not be 30 | # impossibly difficult to eliminate intermediate aggregate construction when 31 | # calling a function to create an array from an aggregate: 32 | 33 | let «array, Array» = import "lib/array" 34 | 35 | let an_array = Array.of_list«('A | 'B, int)»[('A, 1), ('B, 2)] 36 | 37 | () 38 | -------------------------------------------------------------------------------- /examples/aggregate-syntax.fomi: -------------------------------------------------------------------------------- 1 | () 2 | -------------------------------------------------------------------------------- /examples/aggregate-syntax.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const target_ꓯαꓸ𛰙ꓱarrayꓽᕯ_𐙤_ᕯꓸarray_ = a => v => a.push(v) 3 | const ᐟA = ['A'] 4 | const 𛰙ᐟAꓹ_1𛰚 = {1: ᐟA, 2: 1} 5 | const ᐟB = ['B'] 6 | const 𛰙ᐟBꓹ_2𛰚 = {1: ᐟB, 2: 2} 7 | const ᐟNil = ['Nil'] 8 | const 𛰙𛰙ᐟBꓹ_2𛰚ꓹ_ᐟNil𛰚 = {1: 𛰙ᐟBꓹ_2𛰚, 2: ᐟNil} 9 | const ᐟCons𛰙𛰙ᐟBꓹ_2𛰚ꓹ_ᐟNil𛰚 = ['Cons', 𛰙𛰙ᐟBꓹ_2𛰚ꓹ_ᐟNil𛰚] 10 | const 𛰙𛰙ᐟAꓹ_1𛰚ꓹ_ᐟCons𛰙𛰙ᐟBꓹ_2𛰚ꓹ_ = {1: 𛰙ᐟAꓹ_1𛰚, 2: ᐟCons𛰙𛰙ᐟBꓹ_2𛰚ꓹ_ᐟNil𛰚} 11 | const ᐟCons𛰙𛰙ᐟAꓹ_1𛰚ꓹ_ᐟCons𛰙𛰙ᐟBꓹ_ = ['Cons', 𛰙𛰙ᐟAꓹ_1𛰚ꓹ_ᐟCons𛰙𛰙ᐟBꓹ_2𛰚ꓹ_] 12 | const target_impure_𛰙ꓱarrayꓽᕯ_𐙤_ = [] 13 | const _fold = rxr$1 => r$1 => ᐟNil_ǀ_ᐟCons$1 => { 14 | for (;;) { 15 | const rxr = rxr$1, 16 | r = r$1, 17 | ᐟNil_ǀ_ᐟCons = ᐟNil_ǀ_ᐟCons$1 18 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 19 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 20 | return r 21 | } else { 22 | ;(r$1 = rxr(r)(val_ᐟNil_ǀ_ᐟCons[1])), 23 | (ᐟNil_ǀ_ᐟCons$1 = val_ᐟNil_ǀ_ᐟCons[2]) 24 | } 25 | } 26 | } 27 | const ys = target_impure_𛰙ꓱarrayꓽᕯ_𐙤_ 28 | _fold(_𛰙𛰚 => x => target_ꓯαꓸ𛰙ꓱarrayꓽᕯ_𐙤_ᕯꓸarray_(ys)(x))(void 0)( 29 | ᐟCons𛰙𛰙ᐟAꓹ_1𛰚ꓹ_ᐟCons𛰙𛰙ᐟBꓹ_ 30 | ) 31 | void 0 32 | -------------------------------------------------------------------------------- /examples/aggregate-syntax.out: -------------------------------------------------------------------------------- 1 | () 2 | -------------------------------------------------------------------------------- /examples/bounded-subtyping-of-counters.fom: -------------------------------------------------------------------------------- 1 | # Bounded subtyping of counters with identity coercions 2 | 3 | # Similarly to the example in the book Types and Programming Languages, section 4 | # 32.4, an object has state `τ` and methods operating on said state `M τ`: 5 | 6 | type Object = λM.∃τ.(τ, M τ) 7 | 8 | # The methods form the interface to the object. For example, counter objects 9 | # can be incremented and the current value can be fetched as an integer: 10 | 11 | type CounterM = λτ.{ 12 | inc: τ → τ 13 | get: τ → int 14 | } 15 | 16 | # A concrete counter class might, for example, simply store state as integers: 17 | 18 | let CounterClass: CounterM int = { 19 | inc = λx.x + 1 20 | get = λx.x 21 | } 22 | 23 | # A counter object is sealed to hide the state type: 24 | 25 | let aCounter: Object CounterM = «int, (0, CounterClass)» 26 | 27 | # We can similarly specify a subtype of counters that can also be reset and that 28 | # keeps track of how many times the counter has been reset: 29 | 30 | type ResetCounterM = λτ.{ 31 | inc: τ → τ 32 | get: τ → int 33 | reset: τ → τ 34 | reset_count: τ → int 35 | } 36 | 37 | let ResetCounterClass: ResetCounterM {count: int, resets: int} = { 38 | get = λ{count}.count 39 | inc = λ{count, resets}.{count = count + 1, resets} 40 | reset = λ{resets}.{count = 0, resets = resets + 1} 41 | reset_count = λ{resets}.resets 42 | } 43 | 44 | let aResetCounter: Object ResetCounterM = 45 | «{count: int, resets: int}, ({count = 0, resets = 0}, ResetCounterClass)» 46 | 47 | # To encode bounded quantification of counters we can pass explicit coercions, 48 | # `B`, to access the methods. Here are helpers to invoke the methods `inc`, 49 | # `get`, `reset`, and `reset_count`: 50 | 51 | type CounterB = λM.∀τ.M τ → CounterM τ 52 | 53 | let inc: ∀M.CounterB M → Object M → Object M = λB.λ«τ, (x, M)». 54 | let C = B«τ» M 55 | «τ, (C.inc x, M)» 56 | 57 | let get: ∀M.CounterB M → Object M → int = λB.λ«τ, (x, M)». 58 | let C = B«τ» M 59 | C.get x 60 | 61 | type ResetCounterB = λM.∀τ.M τ → ResetCounterM τ 62 | 63 | let reset: ∀M.ResetCounterB M → Object M → Object M = λB.λ«τ, (x, M)». 64 | let C = B«τ» M 65 | «τ, (C.reset x, M)» 66 | 67 | let reset_count: ∀M.ResetCounterB M → Object M → int = λB.λ«τ, (x, M)». 68 | let C = B«τ» M 69 | C.reset_count x 70 | 71 | # Thanks to simple width subtyping, the coercions can be just identity 72 | # functions: 73 | 74 | let CounterB = Λτ.λM: CounterM τ.M 75 | let ResetCounterB = Λτ.λM: ResetCounterM τ.M 76 | 77 | # And to invoke methods we pass both the interface type and the (bound) 78 | # coercion: 79 | 80 | let four = 81 | aCounter 82 | ▷ inc«CounterM» CounterB 83 | ▷ inc«CounterM» CounterB 84 | ▷ inc«CounterM» CounterB 85 | ▷ inc«CounterM» CounterB 86 | ▷ get«CounterM» CounterB 87 | 88 | let two = 89 | aResetCounter 90 | ▷ inc«ResetCounterM» ResetCounterB 91 | ▷ inc«ResetCounterM» ResetCounterB 92 | ▷ reset«ResetCounterM» ResetCounterB 93 | ▷ inc«ResetCounterM» ResetCounterB 94 | ▷ reset«ResetCounterM» ResetCounterB 95 | ▷ reset_count«ResetCounterM» ResetCounterB 96 | 97 | {four, two} 98 | -------------------------------------------------------------------------------- /examples/bounded-subtyping-of-counters.fomi: -------------------------------------------------------------------------------- 1 | {four: int, two: int} 2 | -------------------------------------------------------------------------------- /examples/bounded-subtyping-of-counters.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | ;({four: 4, two: 2}) 3 | -------------------------------------------------------------------------------- /examples/bounded-subtyping-of-counters.out: -------------------------------------------------------------------------------- 1 | {four = 4, two = 2} 2 | -------------------------------------------------------------------------------- /examples/effect-reader.fom: -------------------------------------------------------------------------------- 1 | # Effect reader 2 | 3 | type pure = λF.λ_.{pure: ∀α.α → F α} 4 | type bind = λF.λD.{bind: ∀α.∀β.(α → D → F β) → (D → F α) → F β} 5 | 6 | let pure = ΛF.ΛD.Λα.λx: α.λF: pure F D.F.pure«α» x 7 | let bind = ΛF.ΛD.Λα.Λβ. 8 | λxyE: α → D → F β.λxE: D → F α.λF: bind F D.F.bind«α»«β» xyE xE 9 | 10 | type monad = pure ∧ bind 11 | 12 | type id = λα.α 13 | type Id = μ(monad id) 14 | let μId: Id = { 15 | pure = λx.x 16 | bind = λxyE.λxE.xyE (xE Id) Id 17 | } 18 | 19 | let μfib: ∀F.int → μ(monad F) → F int = ΛF.λn. 20 | if n ≤ 1 then 21 | pure«F»«μ(monad F)»«int» n 22 | else 23 | fib«F» (n - 2) ▷ bind«F»«μ(monad F)»«int»«int» λn2. 24 | fib«F» (n - 1) ▷ bind«F»«μ(monad F)»«int»«int» λn1. 25 | pure«F»«μ(monad F)»«int» (n2 + n1) 26 | 27 | fib«id» 10 Id 28 | -------------------------------------------------------------------------------- /examples/effect-reader.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/effect-reader.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌xꓸx = x => x 3 | const _Id = {pure: 𝛌xꓸx, bind: xyE => xE => xyE(xE(_Id))(_Id)} 4 | const _fib = n => { 5 | if (n <= 1) { 6 | return F => F.pure(n) 7 | } else { 8 | const _AppL = _fib((n - 2) | 0) 9 | return F => 10 | F.bind(n2 => { 11 | const _AppL$1 = _fib((n - 1) | 0) 12 | return F$1 => F$1.bind(n1 => F$2 => F$2.pure((n2 + n1) | 0))(_AppL$1) 13 | })(_AppL) 14 | } 15 | } 16 | _fib(10)(_Id) 17 | -------------------------------------------------------------------------------- /examples/effect-reader.out: -------------------------------------------------------------------------------- 1 | 55 2 | -------------------------------------------------------------------------------- /examples/equality-witnesses.fom: -------------------------------------------------------------------------------- 1 | # First-class type equality witnesses 2 | 3 | type Leibniz = λα.λβ.∀φ.φ α → φ β 4 | type Fold = λα.λβ.∀φ.(∀γ.φ γ γ) → φ α β 5 | 6 | type Eq = λeq.{ 7 | ofFold: ∀α.∀β.Fold α β → eq α β 8 | ofLeibniz: ∀α.∀β.Leibniz α β → eq α β 9 | refl: ∀α.eq α α 10 | symm: ∀α.∀β.eq α β → eq β α 11 | trans: ∀α.∀β.∀γ.eq β γ → eq α β → eq α γ 12 | to: ∀α.∀β.eq α β → α → β 13 | from: ∀α.∀β.eq α β → β → α 14 | } 15 | 16 | let Leibniz: Eq Leibniz = { 17 | ofFold = λab.Λφ.ab«λα.λβ.φ α → φ β» λx.x 18 | ofLeibniz = λab.ab 19 | refl = λx.x 20 | symm = Λα.λab.Λφ.ab«λβ.φ β → φ α» λx.x 21 | trans = λbc.λab.Λφ.λx.bc«φ» ab«φ»(x) 22 | to = λab.ab«λx.x» 23 | from = Λα.λab.ab«λβ.β → α» λx.x 24 | } 25 | 26 | let Fold: Eq Fold = { 27 | ofFold = λab.ab 28 | ofLeibniz = Λα.λab.Λφ.λh.ab«φ α» h«α» 29 | refl = Λα.λf.f«α» 30 | symm = λab.Λφ.λf.ab«λα.λβ.φ β α» f 31 | trans = Λα.λbc.λab.Λϕ.λf.bc«λγ.λδ.ϕ α γ → ϕ α δ» (λx.x) ab«ϕ»(f) 32 | to = λab.ab«λα.λβ.α → β» λx.x 33 | from = λab.ab«λα.λβ.β → α» λx.x 34 | } 35 | 36 | {Leibniz, Fold} 37 | -------------------------------------------------------------------------------- /examples/equality-witnesses.fomi: -------------------------------------------------------------------------------- 1 | {Leibniz: {ofFold: ∀α.∀β.(∀φ:* → * → *.(∀γ.φ γ γ) → φ α β) → ∀φ:* → *.φ α → φ β, ofLeibniz: ∀α.∀β.(∀φ:* → *.φ α → φ β) → ∀φ:* → *.φ α → φ β, refl: ∀α.∀φ:* → *.φ α → φ α, symm: ∀α.∀β.(∀φ:* → *.φ α → φ β) → ∀φ:* → *.φ β → φ α, trans: ∀α.∀β.∀γ.(∀φ:* → *.φ β → φ γ) → (∀φ:* → *.φ α → φ β) → ∀φ:* → *.φ α → φ γ, to: ∀α.∀β.(∀φ:* → *.φ α → φ β) → α → β, from: ∀α.∀β.(∀φ:* → *.φ α → φ β) → β → α}, Fold: {ofFold: ∀α.∀β.(∀φ:* → * → *.(∀γ.φ γ γ) → φ α β) → ∀φ:* → * → *.(∀γ.φ γ γ) → φ α β, ofLeibniz: ∀α.∀β.(∀φ:* → *.φ α → φ β) → ∀φ:* → * → *.(∀γ.φ γ γ) → φ α β, refl: ∀α.∀φ:* → * → *.(∀γ.φ γ γ) → φ α α, symm: ∀α.∀β.(∀φ:* → * → *.(∀γ.φ γ γ) → φ α β) → ∀φ:* → * → *.(∀γ.φ γ γ) → φ β α, trans: ∀α.∀β.∀γ.(∀φ:* → * → *.(∀γ.φ γ γ) → φ β γ) → (∀φ:* → * → *.(∀γ.φ γ γ) → φ α β) → ∀φ:* → * → *.(∀γ.φ γ γ) → φ α γ, to: ∀α.∀β.(∀φ:* → * → *.(∀γ.φ γ γ) → φ α β) → α → β, from: ∀α.∀β.(∀φ:* → * → *.(∀γ.φ γ γ) → φ α β) → β → α}} 2 | -------------------------------------------------------------------------------- /examples/equality-witnesses.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌xꓸx = x => x 3 | const 𝛌abꓸab_𝛌xꓸx = ab => ab(𝛌xꓸx) 4 | const 𝛌bcꓸλabꓸλxꓸbc_𛰙ab_x𛰚 = bc => ab => x => bc(ab(x)) 5 | const 𛰝ofFoldꘌ𝛌abꓸab_𝛌xꓸxꓹ_ofLeibnizꘌ𝛌xꓸxꓹ_ = { 6 | ofFold: 𝛌abꓸab_𝛌xꓸx, 7 | ofLeibniz: 𝛌xꓸx, 8 | refl: 𝛌xꓸx, 9 | symm: 𝛌abꓸab_𝛌xꓸx, 10 | trans: 𝛌bcꓸλabꓸλxꓸbc_𛰙ab_x𛰚, 11 | to: 𝛌xꓸx, 12 | from: 𝛌abꓸab_𝛌xꓸx, 13 | } 14 | const 𝛌bcꓸλabꓸλfꓸ𛰙bc_𝛌xꓸx𛰚_𛰙ab_ = bc => ab => f => bc(𝛌xꓸx)(ab(f)) 15 | const 𛰝ofFoldꘌ𝛌xꓸxꓹ_ofLeibnizꘌ𝛌xꓸxꓹ_ = { 16 | ofFold: 𝛌xꓸx, 17 | ofLeibniz: 𝛌xꓸx, 18 | refl: 𝛌xꓸx, 19 | symm: 𝛌xꓸx, 20 | trans: 𝛌bcꓸλabꓸλfꓸ𛰙bc_𝛌xꓸx𛰚_𛰙ab_, 21 | to: 𝛌abꓸab_𝛌xꓸx, 22 | from: 𝛌abꓸab_𝛌xꓸx, 23 | } 24 | ;({ 25 | Leibniz: 𛰝ofFoldꘌ𝛌abꓸab_𝛌xꓸxꓹ_ofLeibnizꘌ𝛌xꓸxꓹ_, 26 | Fold: 𛰝ofFoldꘌ𝛌xꓸxꓹ_ofLeibnizꘌ𝛌xꓸxꓹ_, 27 | }) 28 | -------------------------------------------------------------------------------- /examples/equality-witnesses.out: -------------------------------------------------------------------------------- 1 | {Leibniz = {ofFold = λ𝛌abꓸab_𝛌xꓸx, ofLeibniz = λ𝛌xꓸx, refl = λ𝛌xꓸx, symm = λ𝛌abꓸab_𝛌xꓸx, trans = λ𝛌bcꓸλabꓸλxꓸbc_𛰙ab_x𛰚, to = λ𝛌xꓸx, from = λ𝛌abꓸab_𝛌xꓸx}, Fold = {ofFold = λ𝛌xꓸx, ofLeibniz = λ𝛌xꓸx, refl = λ𝛌xꓸx, symm = λ𝛌xꓸx, trans = λ𝛌bcꓸλabꓸλfꓸ𛰙bc_𝛌xꓸx𛰚_𛰙ab_, to = λ𝛌abꓸab_𝛌xꓸx, from = λ𝛌abꓸab_𝛌xꓸx}} 2 | -------------------------------------------------------------------------------- /examples/equirecursive-fixpoint-combinator.fom: -------------------------------------------------------------------------------- 1 | # Equirecursive applicative fixpoint combinator 2 | 3 | # This example shows that with equirecursive types one can express the fixpoint 4 | # combinator. This also serves as a test towards ensuring that such recursive 5 | # definitions do not make the compiler loop. 6 | 7 | let Z = Λα.Λβ.λf: (α → β) → α → β. 8 | let z = λx: μτ.τ → α → β.f λv.x x v 9 | z z 10 | 11 | let fact = Z«int»«int» λfact. 12 | λn.if n ≤ 0 then 1 else n * fact (n-1) 13 | 14 | fact 5 15 | -------------------------------------------------------------------------------- /examples/equirecursive-fixpoint-combinator.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/equirecursive-fixpoint-combinator.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | 120 3 | -------------------------------------------------------------------------------- /examples/equirecursive-fixpoint-combinator.out: -------------------------------------------------------------------------------- 1 | 120 2 | -------------------------------------------------------------------------------- /examples/errors/exit.fom: -------------------------------------------------------------------------------- 1 | target«impure ()» "process.exit(1)" 2 | ▷ keep«()» 3 | -------------------------------------------------------------------------------- /examples/errors/exit.out: -------------------------------------------------------------------------------- 1 | Failure("Process exited with code 1")in file 2 | 3 | "/." 4 | 5 | on line 0, columns 0-1. 6 | -------------------------------------------------------------------------------- /examples/errors/nested.fom: -------------------------------------------------------------------------------- 1 | # Nested datatypes are disallowed 2 | 3 | type μnested = λα.(α, nested (α, α)) 4 | 5 | () 6 | -------------------------------------------------------------------------------- /examples/errors/nested.out: -------------------------------------------------------------------------------- 1 | Nested types like 2 | 3 | μnested:* → *.λα.(α, nested (α, α)) 4 | 5 | are not allowed to keep type checking decidable in file 6 | 7 | "/examples/errors/nested.fom" 8 | 9 | on line 3, columns 7-13. 10 | 11 | Also in file 12 | 13 | "/examples/errors/nested.fom" 14 | 15 | on line 3, columns 30-36: Nested argument passed to μ type constructor. 16 | -------------------------------------------------------------------------------- /examples/errors/test-local-scoping.fom: -------------------------------------------------------------------------------- 1 | include "../lib/univ.fomd" 2 | 3 | type opt_should_not_be_accessible = opt 4 | 5 | () 6 | -------------------------------------------------------------------------------- /examples/errors/test-local-scoping.out: -------------------------------------------------------------------------------- 1 | Unbound type variable 2 | 3 | opt 4 | 5 | in file 6 | 7 | "/examples/errors/test-local-scoping.fom" 8 | 9 | on line 3, columns 37-40. 10 | 11 | Also in file 12 | 13 | "/examples/errors/test-local-scoping.fom" 14 | 15 | on line 3, columns 37-40: Unbound type variable. 16 | -------------------------------------------------------------------------------- /examples/f-omega-self-interpreter.fom: -------------------------------------------------------------------------------- 1 | # A self-interpreter for the Fω subset 2 | 3 | # This example is based on the paper 4 | # 5 | # Breaking Through the Normalization Barrier: A Self-Interpreter for F-omega 6 | # by Matt Brown and Jens Palsberg 7 | # https://dl.acm.org/doi/abs/10.1145/2837614.2837623 8 | # 9 | # The implementation in this example differs from the paper in that a `Semantics 10 | # F` record is used pass the semantics to expressions. Kind inference in Fωμ 11 | # eliminates the need for kind annotations and they are only used to explicitly 12 | # constrain kinds to correspond to the paper. Annotation propagation in Fωμ 13 | # eliminates the need for many type annotations. There is also no need to 14 | # encode primitive types like `Nat` used in semantics. 15 | 16 | # Representation helpers 17 | 18 | type Star = ∀α.α 19 | 20 | type Strip = λF.λα.∀β.(∀γ: *.F γ → β) → α → β 21 | 22 | type Semantics = λF.{ 23 | abs: ∀α.∀β.(F α → F β) → F (F α → F β) 24 | app: ∀α.∀β.F (F α → F β) → F α →F β 25 | tabs: ∀α.Strip F α → α → F α 26 | tapp: ∀α.F α → ∀β.(α → F β) → F β 27 | } 28 | 29 | type Exp = λα.∀F.Semantics F → F (α F) 30 | 31 | let strip = ΛF.Λσ.Λτ.Λα.λf: ∀β.F β → α.λx: ∀γ.F (τ γ).f«τ σ» x«σ» 32 | 33 | # Representation of the type: λα.α → α 34 | 35 | type rep_id_fun = λF.λα: *.F α → F α 36 | 37 | # Representation of the type: ∀α.α → α 38 | 39 | type rep_id = λF.∀α.F (rep_id_fun F α) 40 | 41 | # Representation of the term: Λα.λx: α.x 42 | 43 | let rep_id: Exp rep_id = 44 | ΛF.λS. 45 | S.tabs«rep_id F» strip«F»«Star»«rep_id_fun F» 46 | Λα.S.abs«α»«α» λx.x 47 | 48 | # Representation of the term: λx: ∀α.α → α.x «∀α.α → α» x 49 | 50 | type rep_id_to_id = λF.F (rep_id F) → F (rep_id F) 51 | 52 | let rep_id_to_id: Exp rep_id_to_id = 53 | ΛF.λS. 54 | S.abs«rep_id F»«rep_id F» 55 | λx. 56 | S.app«rep_id F»«rep_id F» 57 | (S.tapp«rep_id F» x «F (rep_id F) → F (rep_id F)» 58 | λx.x«rep_id F») 59 | x 60 | 61 | # Operation on representations 62 | 63 | let foldExp = ΛF.λS: Semantics F.Λα.λe: Exp α.e«F» S 64 | 65 | # Implementation of unquote 66 | 67 | type Id = λα: *.α 68 | 69 | let unquote: ∀α.Exp α → α Id = foldExp«Id» { 70 | abs = λf.f 71 | app = λf.λx.f x 72 | tabs = λ_.λf.f 73 | tapp = λf.λg.g f 74 | } 75 | 76 | # Implementation of size 77 | 78 | type Int = λ_: *.int 79 | 80 | let size: ∀α.Exp α → int = foldExp«Int» { 81 | abs = λf.f 1 + 1 82 | app = λf.λx.f + x + 1 83 | tabs = λstrip.λf.strip«int» (λx.x) f + 1 84 | tapp = λf.λ_.f + 1 85 | } 86 | 87 | # Implementation of nf 88 | 89 | type Bools = (bool, bool) 90 | type KBools = λ_: *.Bools 91 | 92 | let nf: ∀α.Exp α → bool = 93 | Λα.λe. 94 | (foldExp«KBools» 95 | { abs = λf.((f (true, true)).1, false) 96 | app = λf.λx.(f.2 ∧ x.1, f.2 ∧ x.1) 97 | tabs = λstrip.λf.((strip«Bools» (λx.x) f).1, false) 98 | tapp = λf.λ_.(f.2, f.2) } 99 | «α» 100 | e).1 101 | 102 | # Implementation of cps 103 | 104 | type Ct = λα.∀β.(α → β) → β 105 | type CPS = λα.Ct (α Ct) 106 | 107 | let cps: ∀α.Exp α → CPS α = foldExp«Ct» { 108 | abs = λf.λk.k f 109 | app = λf.λx.ΛV.λk.f«V» λg.g x «V» k 110 | tabs = λ_.λf.λk.k f 111 | tapp = λf.λinst.ΛV.λk.f«V» λe.inst e «V» k 112 | } 113 | 114 | # Applying operations to sample representations: 115 | 116 | { 117 | unquote = unquote«rep_id_to_id» rep_id_to_id 118 | size = size«rep_id_to_id» rep_id_to_id 119 | cps = cps«rep_id» rep_id 120 | nf = nf«rep_id_to_id» rep_id_to_id 121 | } 122 | -------------------------------------------------------------------------------- /examples/f-omega-self-interpreter.fomi: -------------------------------------------------------------------------------- 1 | {unquote: (∀α.α → α) → ∀α.α → α, size: int, cps: ∀β.((∀α.∀β.(((∀β.(α → β) → β) → ∀β.(α → β) → β) → β) → β) → β) → β, nf: bool} 2 | -------------------------------------------------------------------------------- /examples/f-omega-self-interpreter.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌xꓸx_x = x => x(x) 3 | const 𝛌xꓸx = x => x 4 | const 𝛌kꓸk_𝛌xꓸx = k => k(𝛌xꓸx) 5 | const 𝛌kꓸk_𛰙𝛌kꓸk_𝛌xꓸx𛰚 = k => k(𝛌kꓸk_𝛌xꓸx) 6 | ;({unquote: 𝛌xꓸx_x, size: 5, cps: 𝛌kꓸk_𛰙𝛌kꓸk_𝛌xꓸx𛰚, nf: true}) 7 | -------------------------------------------------------------------------------- /examples/f-omega-self-interpreter.out: -------------------------------------------------------------------------------- 1 | {unquote = λ𝛌xꓸx_x, size = 5, cps = λ𝛌kꓸk_𛰙𝛌kꓸk_𝛌xꓸx𛰚, nf = true} 2 | -------------------------------------------------------------------------------- /examples/fact.fom: -------------------------------------------------------------------------------- 1 | # The traditional `fact`orial function 2 | 3 | let μfact: int → int = 4 | λn. 5 | if n ≤ 1 6 | then 1 7 | else n * fact (n - 1) 8 | 9 | fact 5 10 | -------------------------------------------------------------------------------- /examples/fact.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/fact.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const _fact = n => { 3 | if (n <= 1) { 4 | return 1 5 | } else { 6 | return (n * _fact((n - 1) | 0)) | 0 7 | } 8 | } 9 | _fact(5) 10 | -------------------------------------------------------------------------------- /examples/fact.out: -------------------------------------------------------------------------------- 1 | 120 2 | -------------------------------------------------------------------------------- /examples/fib.fom: -------------------------------------------------------------------------------- 1 | # Iterative `fib`onacci function 2 | 3 | # This is just a basic linear time iterative fibonacci function. Ideally this 4 | # should be compiled to a simple loop for the general case. 5 | 6 | let fib = 7 | let μloop: int → int → int → int = 8 | λi.λj.λn. 9 | if n ≤ 0 10 | then i 11 | else loop j ◇ i + j ◇ n - 1 12 | loop 0 1 13 | 14 | fib 10 15 | -------------------------------------------------------------------------------- /examples/fib.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/fib.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const _loop = i$1 => j$1 => n$1 => { 3 | for (;;) { 4 | const i = i$1, 5 | j = j$1, 6 | n = n$1 7 | if (n <= 0) { 8 | return i 9 | } else { 10 | ;(i$1 = j), (j$1 = (i + j) | 0), (n$1 = (n - 1) | 0) 11 | } 12 | } 13 | } 14 | _loop(0)(1)(10) 15 | -------------------------------------------------------------------------------- /examples/fib.out: -------------------------------------------------------------------------------- 1 | 55 2 | -------------------------------------------------------------------------------- /examples/finally-tagless.fom: -------------------------------------------------------------------------------- 1 | # Finally Tagless 2 | 3 | # This example is inspired by the paper: 4 | # 5 | # Finally Tagless, Partially Evaluated: 6 | # Tagless Staged Interpreters for Simpler Typed Languages 7 | # by Jacques Carette, Oleg Kiselyov, and Chung-chieh Shan 8 | # https://okmij.org/ftp/tagless-final/index.html 9 | # 10 | # This example differs from the paper mainly in that the interpreter is built 11 | # compositionally. Also, the whole evaluation semantics is thunked so there is 12 | # no need to treat conditionals as a special case. 13 | 14 | # Types for the two semantics (evaluation ℰ and size 𝒮) 15 | 16 | type ℰ = λα.() → α 17 | type 𝒮 = λ_.int 18 | 19 | type Σ = λ𝐹.{eval: 𝐹 ℰ, size: 𝐹 𝒮} 20 | 21 | # Integer expressions 22 | 23 | type IntExp = λσ.{ 24 | Int: int → σ int 25 | Add: σ int → σ int → σ int 26 | Mul: σ int → σ int → σ int 27 | Leq: σ int → σ int → σ bool 28 | } 29 | 30 | let IntExp: Σ IntExp = { 31 | eval = { 32 | Int = λi.λ().i 33 | Add = λx.λy.λ().x() + y() 34 | Mul = λx.λy.λ().x() * y() 35 | Leq = λx.λy.λ().x() ≤ y() 36 | } 37 | size = { 38 | Int = λ_.1 39 | Add = λx.λy.x + y + 1 40 | Mul = λx.λy.x + y + 1 41 | Leq = λx.λy.x + y + 1 42 | } 43 | } 44 | 45 | # Boolean expressions 46 | 47 | type BoolExp = λσ.{ 48 | Bool: bool → σ bool 49 | If: ∀α.σ bool → σ α → σ α → σ α 50 | } 51 | 52 | let BoolExp: Σ BoolExp = { 53 | eval = { 54 | Bool = λb.λ().b 55 | If = λc.λt.λe.λ().if c() then t() else e() 56 | } 57 | size = { 58 | Bool = λ_.1 59 | If = λc.λt.λe.c + t + e + 1 60 | } 61 | } 62 | 63 | # Lambda expressions 64 | 65 | type LamExp = λσ.{ 66 | Lam: ∀α.∀β.(σ α → σ β) → σ (α → β) 67 | App: ∀α.∀β.σ (α → β) → σ α → σ β 68 | } 69 | 70 | let LamExp: Σ LamExp = { 71 | eval = { 72 | Lam = λf.λ().λx.f (λ().x) () 73 | App = λf.λx.λ().f() x() 74 | } 75 | size = { 76 | Lam = λf.f 0 + 1 77 | App = λf.λx.f + x + 1 78 | } 79 | } 80 | 81 | # Fixpoint expression 82 | 83 | type FixExp = λσ.{Fix: ∀α.(σ α → σ α) → σ α} 84 | 85 | let FixExp: Σ FixExp = { 86 | eval = {Fix = λf.λ().μx.f (λ().x) ()} 87 | size = {Fix = λf.f 0 + 1} 88 | } 89 | 90 | # Composition of interpreter 91 | 92 | type Exp = IntExp ∧ BoolExp ∧ LamExp ∧ FixExp 93 | 94 | let Exp = IntExp „ BoolExp „ LamExp „ FixExp 95 | 96 | # An example 97 | 98 | let pow_exp = Λσ.λS: Exp σ. 99 | S.Lam«int»«int → int» λx.S.Fix«int → int» λpow. 100 | S.Lam«int»«int» λn. 101 | S.If«int» S.Leq(n)(S.Int(0)) 102 | S.Int(1) 103 | S.Mul(x)(S.App«int»«int» pow ◁ S.Add n S.Int(-1)) 104 | 105 | let pow = pow_exp«ℰ» Exp.eval () 106 | let pow_size = pow_exp«𝒮» Exp.size 107 | 108 | # The Fωμ toy compiler can constant fold the size calculation and completely 109 | # eliminate the thunking of the evaluation semantics. 110 | 111 | pow 2 pow_size 112 | -------------------------------------------------------------------------------- /examples/finally-tagless.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/finally-tagless.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛍xꓸλxꓸif_x_ᐸꘌ_0_then_1_else_ = x => { 3 | if (x <= 0) { 4 | return 1 5 | } else { 6 | return (2 * 𝛍xꓸλxꓸif_x_ᐸꘌ_0_then_1_else_((x - 1) | 0)) | 0 7 | } 8 | } 9 | 𝛍xꓸλxꓸif_x_ᐸꘌ_0_then_1_else_(11) 10 | -------------------------------------------------------------------------------- /examples/finally-tagless.out: -------------------------------------------------------------------------------- 1 | 2048 2 | -------------------------------------------------------------------------------- /examples/first-order-and-higher-kinded-lists.fom: -------------------------------------------------------------------------------- 1 | # Both first-order and higher-kinded recursive types are allowed 2 | 3 | # This example shows that a polymorphic list type can be expressed both as the 4 | # fixed point of a first-order `list_1` type and as the fixed point of a 5 | # higher-kinded `list_h` type. Furthermore, the types are considered 6 | # equivalent. 7 | 8 | # List as the fixed point of a higher-kinded `list_h` type 9 | type list_h = μlist_h.λα.'Nil | 'Cons (α, list_h α) 10 | 11 | # List as the fixed point of a first-order `list_1` type 12 | type list_1 = λα.μlist_1.'Nil | 'Cons (α, list_1) 13 | 14 | # Coercion from one type of constructor to another 15 | type coercion = λfrom.λto.∀α.from α → to α 16 | 17 | # Coercions between the representations are identity functions 18 | { 19 | of_list_h: coercion list_h list_1 = λx.x 20 | of_list_1: coercion list_1 list_h = λx.x 21 | } 22 | -------------------------------------------------------------------------------- /examples/first-order-and-higher-kinded-lists.fomi: -------------------------------------------------------------------------------- 1 | {of_list_h: ∀α.(μlist_h:* → *.λα.'Nil | 'Cons (α, list_h α)) α → μlist_1.'Nil | 'Cons (α, list_1), of_list_1: ∀α.(μlist_1.'Nil | 'Cons (α, list_1)) → (μlist_h:* → *.λα.'Nil | 'Cons (α, list_h α)) α} 2 | -------------------------------------------------------------------------------- /examples/first-order-and-higher-kinded-lists.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌xꓸx = x => x 3 | ;({of_list_h: 𝛌xꓸx, of_list_1: 𝛌xꓸx}) 4 | -------------------------------------------------------------------------------- /examples/first-order-and-higher-kinded-lists.out: -------------------------------------------------------------------------------- 1 | {of_list_h = λ𝛌xꓸx, of_list_1 = λ𝛌xꓸx} 2 | -------------------------------------------------------------------------------- /examples/generic-folds.fom: -------------------------------------------------------------------------------- 1 | # Generic `fold`s 2 | 3 | type Functor = λφ.{map: ∀α.∀β.(α → β) → φ α → φ β} 4 | 5 | let μfold: ∀φ.∀α.Functor φ → (φ α → α) → μ(φ) → α = 6 | Λφ.Λα.λF. 7 | λalgebra. 8 | μfold.λv.algebra ◁ F.map«μ(φ)»«α» fold v 9 | 10 | # List type 11 | type ListF = λα.λτ.'Nil | 'Cons (α, τ) 12 | type List = λα.μ(ListF α) 13 | let ListF: ∀τ.Functor (ListF τ) = { 14 | map = λf.case { 15 | Nil = λ().'Nil 16 | Cons = λ(x, xs).'Cons (x, f xs) 17 | } 18 | } 19 | 20 | let List = 21 | let one = Λα.λx: α.'Cons (x, 'Nil) 22 | let μhas: ∀α.(α → bool) → List α → bool = Λα.λp.case { 23 | Nil = λ().false 24 | Cons = λ(x, xs).p x ∨ has«α» p xs 25 | } 26 | let fold = Λρ.Λα.λrxr: ρ → α → ρ.λr: ρ. 27 | fold«ListF α»«ρ» ListF«α» ◁ case { 28 | Nil = λ().r 29 | Cons = λ(x: α, r: ρ).rxr r x 30 | } 31 | let filter = Λα.λp: α → bool.λxs: List α. 32 | xs 33 | ▷ fold«List α»«α» 34 | λxs.λx.if p x then 'Cons (x, xs) else xs 35 | 'Nil 36 | let concat = Λα.λxs: List α.λys: List α. 37 | fold«List α»«α» (λxs.λx.'Cons (x, xs)) ys xs 38 | {one, has, fold, filter, concat} 39 | 40 | # Set ADT 41 | type Set = λelem.λset.{ 42 | empty: set 43 | singleton: elem → set 44 | remove: elem → set → set 45 | union: set → set → set 46 | to_list: set → List elem 47 | } 48 | 49 | # Naïve Set implementation 50 | let Set = { 51 | make = Λelem.λeq: elem → elem → bool. 52 | type set = List elem 53 | let empty = 'Nil 54 | let singleton = List.one«elem» 55 | let remove = λx: elem.List.filter«elem» λy.¬eq x y 56 | let union = λl: set.λr: set. 57 | List.concat«elem» l 58 | ◁ List.filter«elem» (λi.¬List.has«elem» (eq i) l) r 59 | let to_list = λs: set.s 60 | «set, {empty, singleton, remove, union, to_list}»: ∃(Set elem) 61 | } 62 | 63 | # Term type 64 | type TermBase = λρ.λσ.λτ. 65 | | 'Lit {val: int} 66 | | 'Var {id: ρ} 67 | | 'Abs {var: ρ, exp: σ} 68 | | 'App {fn: τ, arg: σ} 69 | type TermF = λτ.TermBase string τ τ 70 | type Term = μ(TermF) 71 | type EvalCtx = TermBase string Term 72 | type VarTerm = λτ.TermBase τ Term Term 73 | 74 | let TermF: Functor TermF = { 75 | map = λab.case { 76 | Lit = λ{val}.'Lit {val} 77 | Var = λ{id}.'Var {id} 78 | Abs = λ{var, exp}.'Abs {var, exp = ab exp} 79 | App = λ{fn, arg}.'App {fn = ab fn, arg = ab arg} 80 | } 81 | } 82 | 83 | # Set of strings 84 | let «ids, Ids» = Set.make«string» (=«string») 85 | 86 | # Compute free variables using `fold` 87 | let fv = 88 | fold«TermF»«ids» TermF ◁ case { 89 | Lit = λ{}.Ids.empty 90 | Var = λ{id}.Ids.singleton id 91 | Abs = λ{var, exp}.Ids.remove var exp 92 | App = λ{fn, arg}.Ids.union fn arg 93 | } 94 | 95 | # Using `fv` 96 | 'App { 97 | fn = 98 | 'Abs { 99 | var = "x" 100 | exp = 'App {fn = 'Var {id = "F"}, arg = 'Var {id = "x"}} 101 | } 102 | arg = 'Var {id = "y"} 103 | } 104 | ▷ fv 105 | ▷ Ids.to_list 106 | -------------------------------------------------------------------------------- /examples/generic-folds.fomi: -------------------------------------------------------------------------------- 1 | μτ.'Nil | 'Cons (string, τ) 2 | -------------------------------------------------------------------------------- /examples/generic-folds.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐟNil = ['Nil'] 3 | const ꘌ𖩇string𖩉 = l => r => l === r 4 | const ᐥxᐥ = 'x' 5 | const ᐥFᐥ = 'F' 6 | const 𛰝idꘌᐥFᐥ𛰞 = {id: ᐥFᐥ} 7 | const ᐟVar𛰝idꘌᐥFᐥ𛰞 = ['Var', 𛰝idꘌᐥFᐥ𛰞] 8 | const 𛰝idꘌᐥxᐥ𛰞 = {id: ᐥxᐥ} 9 | const ᐟVar𛰝idꘌᐥxᐥ𛰞 = ['Var', 𛰝idꘌᐥxᐥ𛰞] 10 | const 𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_argꘌᐟVar𛰝idꘌᐥxᐥ𛰞𛰞 = { 11 | fn: ᐟVar𛰝idꘌᐥFᐥ𛰞, 12 | arg: ᐟVar𛰝idꘌᐥxᐥ𛰞, 13 | } 14 | const ᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_argꘌᐟVar𛰝idꘌᐥxᐥ𛰞𛰞 = [ 15 | 'App', 16 | 𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_argꘌᐟVar𛰝idꘌᐥxᐥ𛰞𛰞, 17 | ] 18 | const 𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_ = { 19 | var: ᐥxᐥ, 20 | exp: ᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_argꘌᐟVar𛰝idꘌᐥxᐥ𛰞𛰞, 21 | } 22 | const ᐟAbs𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_ = [ 23 | 'Abs', 24 | 𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_, 25 | ] 26 | const ᐥyᐥ = 'y' 27 | const 𛰝idꘌᐥyᐥ𛰞 = {id: ᐥyᐥ} 28 | const ᐟVar𛰝idꘌᐥyᐥ𛰞 = ['Var', 𛰝idꘌᐥyᐥ𛰞] 29 | const 𛰝fnꘌᐟAbs𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_ = { 30 | fn: ᐟAbs𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_, 31 | arg: ᐟVar𛰝idꘌᐥyᐥ𛰞, 32 | } 33 | const ᐟApp𛰝fnꘌᐟAbs𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_ = [ 34 | 'App', 35 | 𛰝fnꘌᐟAbs𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_, 36 | ] 37 | const _has = p => ᐟNil_ǀ_ᐟCons => { 38 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 39 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 40 | return false 41 | } else { 42 | return p(val_ᐟNil_ǀ_ᐟCons[1]) || _has(p)(val_ᐟNil_ǀ_ᐟCons[2]) 43 | } 44 | } 45 | ;(function fold(ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp) { 46 | const [tag_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp, val_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp] = 47 | ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp 48 | switch (tag_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp) { 49 | case 'Var': { 50 | return ['Cons', {1: val_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp.id, 2: ᐟNil}] 51 | } 52 | case 'Lit': { 53 | return ᐟNil 54 | } 55 | case 'App': { 56 | const fn = fold(val_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp.fn) 57 | const arg = fold(val_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp.arg) 58 | const ys = (function fold(ᐟNil_ǀ_ᐟCons) { 59 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 60 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 61 | return ᐟNil 62 | } else { 63 | const $2$ = fold(val_ᐟNil_ǀ_ᐟCons[2]) 64 | if (_has(ꘌ𖩇string𖩉(val_ᐟNil_ǀ_ᐟCons[1]))(fn)) { 65 | return $2$ 66 | } else { 67 | return ['Cons', {1: val_ᐟNil_ǀ_ᐟCons[1], 2: $2$}] 68 | } 69 | } 70 | })(arg) 71 | return (function fold(ᐟNil_ǀ_ᐟCons) { 72 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 73 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 74 | return ys 75 | } else { 76 | const $2$ = fold(val_ᐟNil_ǀ_ᐟCons[2]) 77 | return ['Cons', {1: val_ᐟNil_ǀ_ᐟCons[1], 2: $2$}] 78 | } 79 | })(fn) 80 | } 81 | default: { 82 | const exp = fold(val_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp.exp) 83 | return (function fold(ᐟNil_ǀ_ᐟCons) { 84 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 85 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 86 | return ᐟNil 87 | } else { 88 | const $2$ = fold(val_ᐟNil_ǀ_ᐟCons[2]) 89 | if (val_ᐟLit_ǀ_ᐟVar_ǀ_ᐟAbs_ǀ_ᐟApp.var === val_ᐟNil_ǀ_ᐟCons[1]) { 90 | return $2$ 91 | } else { 92 | return ['Cons', {1: val_ᐟNil_ǀ_ᐟCons[1], 2: $2$}] 93 | } 94 | } 95 | })(exp) 96 | } 97 | } 98 | })(ᐟApp𛰝fnꘌᐟAbs𛰝varꘌᐥxᐥꓹ_expꘌᐟApp𛰝fnꘌᐟVar𛰝idꘌᐥFᐥ𛰞ꓹ_) 99 | -------------------------------------------------------------------------------- /examples/generic-folds.out: -------------------------------------------------------------------------------- 1 | ["F", "y"] 2 | -------------------------------------------------------------------------------- /examples/graph-library.fom: -------------------------------------------------------------------------------- 1 | # Graph library 2 | 3 | # This example is inspired by the paper 4 | # 5 | # An extended comparative study of language support for generic programming 6 | # by Jaakko Järvi, Andrew Lumsdaine, and Jeremy Siek 7 | # https://www.researchgate.net/publication/213880958_An_extended_comparative_study_of_language_support_for_generic_programming 8 | 9 | include "lib/algebras" 10 | include "lib/map" 11 | include "lib/dispenser" 12 | include "lib/types" 13 | 14 | let List = import "lib/list" 15 | let Map = import "lib/map" 16 | let Opt = import "lib/opt" 17 | let Queue = import "lib/queue" 18 | let Stack = import "lib/stack" 19 | 20 | # 21 | 22 | type IncidenceGraph = λgraph.λvertex.λedge.{ 23 | out_edges: graph → vertex → opt (list edge) 24 | source: graph → edge → vertex 25 | sink: graph → edge → vertex 26 | } 27 | 28 | type VertexListGraph = λgraph.λvertex.{ 29 | vertices: graph → list vertex 30 | num_vertices: graph → int 31 | } 32 | 33 | # 34 | 35 | let AdjacencyListGraph = 36 | type vertex = int 37 | type edge = (vertex, vertex) 38 | type graph = {num_vertices: int, vertices: list (list vertex)} 39 | let num_vertices = λg: graph.g.num_vertices 40 | let vertices = λg: graph.List.iota g.num_vertices 41 | let out_edges = λg: graph.λi: vertex. 42 | List.nth«list vertex» i g.vertices 43 | ▷ Opt.map«list vertex»«list edge» ◇ 44 | List.map«vertex»«edge» λj: vertex.(i, j) 45 | let source = λ_: graph.λ(x: vertex, _: vertex).x 46 | let sink = λ_: graph.λ(_: vertex, x: vertex).x 47 | {num_vertices, vertices, out_edges, source, sink} 48 | 49 | # 50 | 51 | type BFSVisitor = λmonad.λgraph.λvertex.λedge. 52 | type visit = λfeature.graph → feature → monad () in { 53 | discover_vertex: visit vertex 54 | finish_vertex: visit vertex 55 | examine_edge: visit edge 56 | tree_edge: visit edge 57 | non_tree_edge: visit edge 58 | gray_target: visit edge 59 | black_target: visit edge 60 | } 61 | 62 | let bfs = Λmonad.Λmap.Λgraph.Λvertex.Λedge. 63 | λMonad: Monad monad. 64 | λMap: Map vertex map. 65 | λGraph: IncidenceGraph graph vertex edge ∧ VertexListGraph graph vertex. 66 | λvisitor: BFSVisitor monad graph vertex edge. 67 | λgraph: graph. 68 | λsource: vertex. 69 | # TODO: Actually implement BFS :) 70 | Monad.of«()» () 71 | 72 | bfs 73 | -------------------------------------------------------------------------------- /examples/graph-library.fomi: -------------------------------------------------------------------------------- 1 | ∀monad:* → *.∀map:* → *.∀graph.∀vertex.∀edge.{of: ∀α.α → monad α, chain: ∀α.∀β.(α → monad β) → monad α → monad β} → {count: ∀ν.map ν → int, empty: ∀(map), entries: ∀ν.map ν → (μlist:* → *.λα.'Nil | 'Cons (α, list α)) (vertex, ν), get: ∀ν.map ν → vertex → 'None | 'Some ν, put: ∀ν.vertex → ν → map ν → map ν, fold_back: ∀ρ.∀ν.((vertex, ν) → ρ → ρ) → ρ → map ν → ρ} → {out_edges: graph → vertex → 'None | 'Some ((μlist:* → *.λα.'Nil | 'Cons (α, list α)) edge), source: graph → edge → vertex, sink: graph → edge → vertex, vertices: graph → (μlist:* → *.λα.'Nil | 'Cons (α, list α)) vertex, num_vertices: graph → int} → {discover_vertex: graph → vertex → monad (), finish_vertex: graph → vertex → monad (), examine_edge: graph → edge → monad (), tree_edge: graph → edge → monad (), non_tree_edge: graph → edge → monad (), gray_target: graph → edge → monad (), black_target: graph → edge → monad ()} → graph → vertex → monad () 2 | -------------------------------------------------------------------------------- /examples/graph-library.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | Monad => Map => Graph => visitor => graph => source => Monad.of(void 0) 3 | -------------------------------------------------------------------------------- /examples/graph-library.out: -------------------------------------------------------------------------------- 1 | λ_ 2 | -------------------------------------------------------------------------------- /examples/hmap-using-universal-embedding.fom: -------------------------------------------------------------------------------- 1 | # Heterogenous map using a universal embedding 2 | 3 | include "lib/types" 4 | 5 | type HMap = λmap.λκ.{ 6 | empty: map 7 | new_key: ∀ν.() → κ ν 8 | get: ∀ν.κ ν → map → opt ν 9 | add: ∀ν.κ ν → ν → map → map 10 | } 11 | 12 | let «map, «κ, HMap»»: ∃map.∃(HMap map) = 13 | let «univ, Univ» = import "lib/univ" 14 | «list univ, «λν.{to: ν → univ, of: univ → opt ν}, { 15 | empty = 'Nil 16 | new_key = Univ.new 17 | get = μget.Λν.λk.case { 18 | Nil = λ().'None 19 | Cons = λ(u, m). 20 | k.of u ▷ case { 21 | None = λ().get«ν» k m 22 | Some = λv.'Some v 23 | } 24 | } 25 | add = λk.λv.λm.'Cons (k.to v, m) 26 | }»» 27 | 28 | let k1 = HMap.new_key«int» () 29 | let k2 = HMap.new_key«string» () 30 | let m = 31 | HMap.empty 32 | ▷ HMap.add«int» k1 101 33 | ▷ HMap.add«string» k2 "42" 34 | 35 | (HMap.get«int» k1 m, HMap.get«string» k2 m) 36 | -------------------------------------------------------------------------------- /examples/hmap-using-universal-embedding.fomi: -------------------------------------------------------------------------------- 1 | ('None | 'Some int, 'None | 'Some string) 2 | -------------------------------------------------------------------------------- /examples/hmap-using-universal-embedding.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐟNone = ['None'] 3 | const ᐥ42ᐥ = '42' 4 | const ᐟNil = ['Nil'] 5 | const target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_ = r => x => { 6 | r[0] = x 7 | } 8 | const target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_$1 = r => r[0] 9 | const target_α_𐙤_impure_𛰙ꓱrefꓽᕯ_ = x => [x] 10 | const counter = target_α_𐙤_impure_𛰙ꓱrefꓽᕯ_(0) 11 | const 𝛍getꓸλkꓸcase_𛰝Nilꘌλ_𛰙𛰚ꓸᐟNoneꓹ_ = k$1 => ᐟNil_ǀ_ᐟCons$1 => { 12 | for (;;) { 13 | const k = k$1, 14 | ᐟNil_ǀ_ᐟCons = ᐟNil_ǀ_ᐟCons$1 15 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 16 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 17 | return ᐟNone 18 | } else { 19 | const [tag_kꓸof_𛰙val_ᐟNil_ǀ_ᐟCons𛰚ꓸ1, val_kꓸof_𛰙val_ᐟNil_ǀ_ᐟCons𛰚ꓸ1] = 20 | k.of(val_ᐟNil_ǀ_ᐟCons[1]) 21 | if (tag_kꓸof_𛰙val_ᐟNil_ǀ_ᐟCons𛰚ꓸ1 === 'Some') { 22 | return ['Some', val_kꓸof_𛰙val_ᐟNil_ǀ_ᐟCons𛰚ꓸ1] 23 | } else { 24 | ᐟNil_ǀ_ᐟCons$1 = val_ᐟNil_ǀ_ᐟCons[2] 25 | } 26 | } 27 | } 28 | } 29 | const id = target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_$1(counter) 30 | target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_(counter)((id + 1) | 0) 31 | const id$1 = target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_$1(counter) 32 | target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_(counter)((id$1 + 1) | 0) 33 | const $1$ = 𝛍getꓸλkꓸcase_𛰝Nilꘌλ_𛰙𛰚ꓸᐟNoneꓹ_({ 34 | to: x => ({id, value: x}), 35 | of: x => { 36 | if (x.id === id) { 37 | return ['Some', x.value] 38 | } else { 39 | return ᐟNone 40 | } 41 | }, 42 | })([ 43 | 'Cons', 44 | {1: {id: id$1, value: ᐥ42ᐥ}, 2: ['Cons', {1: {id, value: 101}, 2: ᐟNil}]}, 45 | ]) 46 | const $2$ = 𝛍getꓸλkꓸcase_𛰝Nilꘌλ_𛰙𛰚ꓸᐟNoneꓹ_({ 47 | to: x => ({id: id$1, value: x}), 48 | of: x => { 49 | if (x.id === id$1) { 50 | return ['Some', x.value] 51 | } else { 52 | return ᐟNone 53 | } 54 | }, 55 | })([ 56 | 'Cons', 57 | {1: {id: id$1, value: ᐥ42ᐥ}, 2: ['Cons', {1: {id, value: 101}, 2: ᐟNil}]}, 58 | ]) 59 | ;({1: $1$, 2: $2$}) 60 | -------------------------------------------------------------------------------- /examples/hmap-using-universal-embedding.out: -------------------------------------------------------------------------------- 1 | ('Some 101, 'Some "42") 2 | -------------------------------------------------------------------------------- /examples/hoas-gadt.fom: -------------------------------------------------------------------------------- 1 | # HOAS GADT using Scott encoding 2 | 3 | type μExpr = λα.∀ρ.Cases ρ → ρ α 4 | 5 | and μCases = λρ.{ 6 | Val: ∀α. α → ρ α 7 | Bin: ∀α.∀β.∀γ.(α → β → γ) → Expr α → Expr β → ρ γ 8 | If: ∀α. Expr bool → Expr α → Expr α → ρ α 9 | App: ∀α.∀β. Expr (α → β) → Expr α → ρ β 10 | Lam: ∀α.∀β. (Expr α → Expr β) → ρ (α → β) 11 | Fix: ∀α.∀β. Expr ((α → β) → α → β) → ρ (α → β) 12 | } 13 | 14 | let {Val, Bin, If, App, Lam, Fix}: Cases Expr = { 15 | Val = Λα.λx.λcs.cs.Val«α» x 16 | Bin = Λα.Λβ.Λγ.λf.λx.λy.λcs.cs.Bin«α»«β»«γ» f x y 17 | If = Λα.λc.λt.λe.λcs.cs.If«α» c t e 18 | App = Λα.Λβ.λf.λx.λcs.cs.App«α»«β» f x 19 | Lam = Λα.Λβ.λf.λcs.cs.Lam«α»«β» f 20 | Fix = Λα.Λβ.λf.λcs.cs.Fix«α»«β» f 21 | } 22 | 23 | let match = Λρ.λcs: Cases ρ.Λα.λe: Expr α.e«ρ» cs 24 | 25 | let μeval: ∀α.Expr α → α = match«λα.α» { 26 | Val = λx.x 27 | Bin = Λα.Λβ.λxyz.λx.λy.xyz eval«α»(x) eval«β»(y) 28 | If = Λα.λc.λt.λe.eval«α» if eval«bool» c then t else e 29 | App = Λα.Λβ.λxy.λx.eval«α → β» xy eval«α»(x) 30 | Lam = Λα.Λβ.λf.λx.eval«β» f(Val«α»(x)) 31 | Fix = Λα.Λβ.λf.let f = eval«(α → β) → α → β» f in μg.λx.f g x 32 | } 33 | 34 | let Fact = 35 | Fix«int»«int» 36 | ◁ Lam«int → int»«int → int» λf.Lam«int»«int» λx. 37 | If«int» (Bin«int»«int»«bool» (=«int») x Val«int»(0)) 38 | Val«int»(1) 39 | (Bin«int»«int»«int» (*) 40 | x 41 | ◁ App«int»«int» f 42 | ◁ Bin«int»«int»«int» (-) x Val«int»(1)) 43 | 44 | eval«int» ◁ App«int»«int» Fact ◁ Val«int» 5 45 | -------------------------------------------------------------------------------- /examples/hoas-gadt.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/hoas-gadt.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ꘌ𖩇int𖩉 = l => r => l === r 3 | const 𝛌csꓸcsꓸVal_0 = cs => cs.Val(0) 4 | const 𝛌csꓸcsꓸVal_1 = cs => cs.Val(1) 5 | const ᕯ = l => r => (l * r) | 0 6 | const ᜭ = l => r => (l - r) | 0 7 | const 𝛌fꓸλcsꓸcsꓸLam_𛰙λxꓸλcsꓸ𛰙𛰙csꓸIf_ = f => cs => 8 | cs.Lam( 9 | x => cs$1 => 10 | cs$1.If(cs$2 => cs$2.Bin(ꘌ𖩇int𖩉)(x)(𝛌csꓸcsꓸVal_0))(𝛌csꓸcsꓸVal_1)(cs$2 => 11 | cs$2.Bin(ᕯ)(x)(cs$3 => 12 | cs$3.App(f)(cs$4 => cs$4.Bin(ᜭ)(x)(𝛌csꓸcsꓸVal_1)) 13 | ) 14 | ) 15 | ) 16 | const 𝛌csꓸcsꓸLam_𛰙𝛌fꓸλcsꓸcsꓸLam_ = cs => cs.Lam(𝛌fꓸλcsꓸcsꓸLam_𛰙λxꓸλcsꓸ𛰙𛰙csꓸIf_) 17 | const 𝛌csꓸcsꓸFix_𛰙𝛌csꓸcsꓸLam_𛰙𝛌fꓸλcsꓸcsꓸLam_ = cs => 18 | cs.Fix(𝛌csꓸcsꓸLam_𛰙𝛌fꓸλcsꓸcsꓸLam_) 19 | const 𝛌csꓸcsꓸVal_5 = cs => cs.Val(5) 20 | const 𝛌csꓸ𛰙csꓸApp_𛰙𝛌csꓸcsꓸFix_𛰙𝛌csꓸcsꓸLam_ = cs => 21 | cs.App(𝛌csꓸcsꓸFix_𛰙𝛌csꓸcsꓸLam_𛰙𝛌fꓸλcsꓸcsꓸLam_)(𝛌csꓸcsꓸVal_5) 22 | const 𝛌xꓸx = x => x 23 | const _eval = e => 24 | e({ 25 | Val: 𝛌xꓸx, 26 | Bin: xyz => x => y => xyz(_eval(x))(_eval(y)), 27 | If: c => t => e$1 => { 28 | if (_eval(c)) { 29 | return _eval(t) 30 | } else { 31 | return _eval(e$1) 32 | } 33 | }, 34 | App: xy => x => _eval(xy)(_eval(x)), 35 | Lam: f => x => _eval(f(cs => cs.Val(x))), 36 | Fix: f => { 37 | const f$1 = _eval(f) 38 | const g = x => f$1(g)(x) 39 | return g 40 | }, 41 | }) 42 | _eval(𝛌csꓸ𛰙csꓸApp_𛰙𝛌csꓸcsꓸFix_𛰙𝛌csꓸcsꓸLam_) 43 | -------------------------------------------------------------------------------- /examples/hoas-gadt.out: -------------------------------------------------------------------------------- 1 | 120 2 | -------------------------------------------------------------------------------- /examples/lib/algebras.fom: -------------------------------------------------------------------------------- 1 | include "algebras" 2 | 3 | let Identity = 4 | let of = Λα.λx: α.x 5 | let ap = Λα.Λβ.of«α → β» 6 | let chain = ap 7 | {of, ap, chain} 8 | 9 | let Constant = Λγ. 10 | let map = Λα.Λβ.λ_: α → β.λx: γ.x 11 | {map} 12 | 13 | let Applicative = 14 | let map = Λ𝐹.λF: Applicative 𝐹.Λα.Λβ.λxy: α → β.λxF: 𝐹 α. 15 | F.ap«α»«β» (F.of«α → β» xy) xF 16 | {map} 17 | 18 | let Monad = 19 | let map = Λ𝐹.λF: Monad 𝐹.Λα.Λβ.λxy: α → β.λxF: 𝐹 α. 20 | xF ▷ F.chain«α»«β» λx. 21 | F.of«β» (xy x) 22 | {map} 23 | 24 | let Traversable = 25 | let sequence = Λ𝐹.λF: Applicative 𝐹.Λ𝑇.λT: Traversable 𝑇.Λα. 26 | T.traverse«𝐹» F «𝐹 α» «α» λxF.xF 27 | {sequence} 28 | 29 | let Profunctor = 30 | let map = Λ𝐹.λF: Profunctor 𝐹.Λγ. 31 | Λα.Λβ.λab: α → β.F.promap«γ»«γ»«α»«β» (λx.x) ab 32 | let contramap = Λ𝐹.λF: Profunctor 𝐹.Λγ. 33 | Λα.Λβ.λab: α → β.F.promap«α»«β»«γ»«γ» ab (λx.x) 34 | {map, contramap} 35 | 36 | {Identity, Constant, Applicative, Monad, Profunctor, Traversable} 37 | -------------------------------------------------------------------------------- /examples/lib/algebras.fomd: -------------------------------------------------------------------------------- 1 | local include "types" 2 | 3 | # * 4 | 5 | type Equals = λτ.{ 6 | equals: τ → τ → bool 7 | } 8 | 9 | type Less = λτ.{ 10 | less: τ → τ → bool 11 | } 12 | 13 | type Compare = λτ.{ 14 | compare: τ → τ → ord 15 | } 16 | 17 | type Concat = λτ.{ 18 | concat: τ → τ → τ 19 | } 20 | 21 | type Empty = λτ.{ 22 | empty: τ 23 | } 24 | 25 | type Invert = λτ.{ 26 | invert: τ → τ 27 | } 28 | 29 | type Monoid = Empty ∧ Concat 30 | 31 | type Group = Monoid ∧ Invert 32 | 33 | # * → * 34 | 35 | type Zero = λ𝐹.{ 36 | zero: ∀α.𝐹 α 37 | } 38 | 39 | type Of = λ𝐹.{ 40 | of: ∀α.α → 𝐹 α 41 | } 42 | 43 | type Filter = λ𝐹.{ 44 | filter: ∀α.(α → bool) → 𝐹 α → 𝐹 α 45 | } 46 | 47 | type Map = λ𝐹.{ 48 | map: ∀α.∀β.(α → β) → 𝐹 α → 𝐹 β 49 | } 50 | 51 | type Functor = Map 52 | 53 | type Ap = λ𝐹.{ 54 | ap: ∀α.∀β.𝐹 (α → β) → 𝐹 α → 𝐹 β 55 | } 56 | 57 | type Applicative = Of ∧ Ap 58 | 59 | type Plus = λ𝐹.{ 60 | plus: ∀α.𝐹 α → 𝐹 α → 𝐹 α 61 | } 62 | 63 | type Reduce = λ𝐹.{ 64 | reduce: ∀α.∀β.(α → β → α) → α → 𝐹 β → α 65 | } 66 | 67 | type Extend = λ𝐹.{ 68 | extend: ∀α.∀β.(𝐹 α → β) → 𝐹 α → 𝐹 β 69 | } 70 | 71 | type Extract = λ𝐹.{ 72 | extract: ∀α.𝐹 α → α 73 | } 74 | 75 | type Comonad = Extend ∧ Extract 76 | 77 | type Contramap = λ𝐹.{ 78 | contramap: ∀α.∀β.(α → β) → 𝐹 β → 𝐹 α 79 | } 80 | 81 | type Traverse = λ𝑇.{ 82 | traverse: ∀𝐹.Applicative 𝐹 → ∀α.∀β.(α → 𝐹 β) → 𝑇 α → 𝐹 (𝑇 β) 83 | } 84 | 85 | type Chain = λ𝐹.{ 86 | chain: ∀α.∀β.(α → 𝐹 β) → 𝐹 α → 𝐹 β 87 | } 88 | 89 | type Monad = Of ∧ Chain 90 | 91 | type Traversable = Traverse 92 | 93 | # * → * → * 94 | 95 | type Id = λ𝐹.{ 96 | id: ∀α.∀β.𝐹 α β 97 | } 98 | 99 | type Compose = λ𝐹.{ 100 | compose: ∀α.∀β.∀γ.𝐹 α β → 𝐹 β γ → 𝐹 α γ 101 | } 102 | 103 | type Category = Id ∧ Compose 104 | 105 | type Bimap = λ𝐹.{ 106 | bimap: ∀α.∀β.∀γ.∀δ.(α → β) → (γ → δ) → 𝐹 α γ → 𝐹 β δ 107 | } 108 | 109 | type Promap = λ𝐹.{ 110 | promap: ∀α.∀β.∀γ.∀δ.(α → β) → (γ → δ) → 𝐹 β γ → 𝐹 α δ 111 | } 112 | 113 | type Profunctor = Promap 114 | -------------------------------------------------------------------------------- /examples/lib/algebras.fomt: -------------------------------------------------------------------------------- 1 | include "types" 2 | include "algebras" 3 | 4 | { 5 | Identity: Monad id ∧ Applicative id 6 | 7 | Constant: ∀γ.Functor λ_.γ 8 | 9 | Applicative: { 10 | map: ∀𝐹.Applicative 𝐹 → ∀α.∀β.(α → β) → 𝐹 α → 𝐹 β 11 | } 12 | 13 | Monad: { 14 | map: ∀𝐹.Monad 𝐹 → ∀α.∀β.(α → β) → 𝐹 α → 𝐹 β 15 | } 16 | 17 | Traversable: { 18 | sequence: ∀𝐹.Applicative 𝐹 → ∀𝑇.Traversable 𝑇 → ∀α.𝑇 (𝐹 α) → 𝐹 (𝑇 α) 19 | } 20 | 21 | Profunctor: { 22 | map: ∀𝐹.Profunctor 𝐹 → ∀γ.∀α.∀β.(α → β) → 𝐹 γ α → 𝐹 γ β 23 | contramap: ∀𝐹.Profunctor 𝐹 → ∀γ.∀α.∀β.(α → β) → 𝐹 β γ → 𝐹 α γ 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /examples/lib/array.fom: -------------------------------------------------------------------------------- 1 | include "types" 2 | 3 | let List = import "list" 4 | 5 | type array = λα.∃array.array α 6 | 7 | let tabulate = Λα.λf: int → α.λn: int. 8 | target«∀α.(int → α) → int → impure (array α)» 9 | "fn => n => {\ 10 | \ const a = new Array(n);\ 11 | \ for (let i=0; i a.length" «α» xs 19 | ▷ keep«int» 20 | 21 | let sub = Λα.λxs: array α.λi: int. 22 | target«∀α.array α → int → impure α» 23 | "a => i => {\ 24 | \ if (i < 0 || a.length <= i)\ 25 | \ throw new Error(\ 26 | \ `Array.sub: Index out of bounds: 0 <= ${i} < ${a.length}`);\ 27 | \ return a[i];\ 28 | \}" 29 | «α» xs i 30 | ▷ keep«α» 31 | 32 | let update = Λα.λxs: array α.λi: int.λx: α. 33 | target«∀α.array α → int → α → impure ()» 34 | "a => i => v => {\ 35 | \ if (i < 0 || a.length <= i)\ 36 | \ throw new Error(\ 37 | \ `Array.update: Index out of bounds: 0 <= ${i} < ${a.length}`);\ 38 | \ a[i] = v;\ 39 | \}" 40 | «α» xs i x 41 | ▷ keep«()» 42 | 43 | let push = Λα.λxs: array α.λx: α. 44 | target«∀α.array α → α → impure ()» "a => v => a.push(v)" «α» xs x 45 | ▷ keep«()» 46 | 47 | let of_list = Λα.λxs: list α. 48 | let ys = target«impure (array α)» "[]" ▷ keep«array α» 49 | List.iter«α» (push«α» ys) xs 50 | ys 51 | 52 | «array, {tabulate, length, sub, update, push, of_list}» 53 | -------------------------------------------------------------------------------- /examples/lib/array.fomd: -------------------------------------------------------------------------------- 1 | local include "types" 2 | 3 | type Array = λarray.{ 4 | tabulate: ∀α.(int → α) → int → array α 5 | length: ∀α.array α → int 6 | sub: ∀α.array α → int → α 7 | update: ∀α.array α → int → α → () 8 | push: ∀α.array α → α → () 9 | of_list: ∀α.list α → array α 10 | } 11 | -------------------------------------------------------------------------------- /examples/lib/array.fomt: -------------------------------------------------------------------------------- 1 | include "array" 2 | 3 | ∃(Array) 4 | -------------------------------------------------------------------------------- /examples/lib/bool.fom: -------------------------------------------------------------------------------- 1 | let Target = import "target" 2 | 3 | let equals = (=«bool») 4 | 5 | let compare = λl: bool.λr: bool. 6 | if equals l r then 7 | 'Eq 8 | else if r then 9 | 'Lt 10 | else 11 | 'Gt 12 | 13 | let to_string = Target.to_string«bool» 14 | 15 | {compare, equals, to_string} 16 | -------------------------------------------------------------------------------- /examples/lib/bool.fomt: -------------------------------------------------------------------------------- 1 | include "types" in { 2 | equals: bool → bool → bool 3 | compare: bool → bool → ord 4 | to_string: bool → string 5 | } 6 | -------------------------------------------------------------------------------- /examples/lib/console.fom: -------------------------------------------------------------------------------- 1 | let keeping = Λα.Λβ.λef: α → impure β.λx: α.ef x ▷ keep«β» 2 | 3 | let log = target«string → impure ()» "console.log" ▷ keeping«string»«()» 4 | let info = target«string → impure ()» "console.info" ▷ keeping«string»«()» 5 | let warn = target«string → impure ()» "console.warn" ▷ keeping«string»«()» 6 | let error = target«string → impure ()» "console.error" ▷ keeping«string»«()» 7 | 8 | {log, info, warn, error} 9 | -------------------------------------------------------------------------------- /examples/lib/dispenser.fom: -------------------------------------------------------------------------------- 1 | include "dispenser" 2 | include "types" 3 | 4 | let of_core = Λdispenser.λDispenser: DispenserCore dispenser. 5 | let fold = Λρ.Λα.λvss: α → ρ → ρ.λs: ρ.λd: dispenser α. 6 | let μloop: dispenser α → ρ → ρ = λd.λs. 7 | Dispenser.remove«α» d ▷ case { 8 | None = λ().s 9 | Some = λ(v: α, d: dispenser α).loop d (vss v s) 10 | } 11 | loop d s 12 | Dispenser „ {fold} 13 | 14 | {of_core} 15 | -------------------------------------------------------------------------------- /examples/lib/dispenser.fomd: -------------------------------------------------------------------------------- 1 | local include "types" 2 | 3 | type DispenserCore = λdispenser.{ 4 | empty: ∀(dispenser) 5 | insert: ∀ν.ν → dispenser ν → dispenser ν 6 | remove: ∀ν.dispenser ν → opt (ν, dispenser ν) 7 | is_empty: ∀ν.dispenser ν → bool 8 | } 9 | 10 | type Dispenser = DispenserCore ∧ λdispenser.{ 11 | fold: ∀ρ.∀ν.(ν → ρ → ρ) → ρ → dispenser ν → ρ 12 | } 13 | -------------------------------------------------------------------------------- /examples/lib/dispenser.fomt: -------------------------------------------------------------------------------- 1 | include "dispenser" in { 2 | of_core: ∀dispenser.DispenserCore dispenser → Dispenser dispenser 3 | } 4 | -------------------------------------------------------------------------------- /examples/lib/eq.fom: -------------------------------------------------------------------------------- 1 | «λα.λβ.∀φ.φ α → φ β, { 2 | refl = λx.x 3 | symm = Λα.λab.Λφ.ab«λβ.φ β → φ α» λx.x 4 | trans = λbc.λab.Λφ.λx.bc«φ» ab«φ»(x) 5 | to = λab.ab«λx.x» 6 | from = Λα.λab.ab«λβ.β → α» λx.x 7 | }» 8 | -------------------------------------------------------------------------------- /examples/lib/eq.fomd: -------------------------------------------------------------------------------- 1 | type Eq = λeq.{ 2 | refl: ∀α.eq α α 3 | symm: ∀α.∀β.eq α β → eq β α 4 | trans: ∀α.∀β.∀γ.eq β γ → eq α β → eq α γ 5 | to: ∀α.∀β.eq α β → α → β 6 | from: ∀α.∀β.eq α β → β → α 7 | } 8 | -------------------------------------------------------------------------------- /examples/lib/eq.fomt: -------------------------------------------------------------------------------- 1 | include "eq" 2 | 3 | ∃(Eq) 4 | -------------------------------------------------------------------------------- /examples/lib/int.fom: -------------------------------------------------------------------------------- 1 | let Target = import "target" 2 | 3 | let equals = (=«int») 4 | 5 | let compare = λl: int.λr: int. 6 | if equals l r then 7 | 'Eq 8 | else if l < r then 9 | 'Lt 10 | else 11 | 'Gt 12 | 13 | let to_string = Target.to_string«int» 14 | 15 | {compare, equals, to_string} 16 | -------------------------------------------------------------------------------- /examples/lib/int.fomt: -------------------------------------------------------------------------------- 1 | include "types" in { 2 | equals: int → int → bool 3 | compare: int → int → ord 4 | to_string: int → string 5 | } 6 | -------------------------------------------------------------------------------- /examples/lib/list.fom: -------------------------------------------------------------------------------- 1 | include "types" 2 | 3 | let of = Λα.λx: α.'Cons (x, 'Nil) 4 | 5 | let μhas: ∀α.(α → bool) → list α → bool = Λα.λp.case { 6 | Nil = λ().false 7 | Cons = λ(x, xs).p x ∨ has«α» p xs 8 | } 9 | 10 | let μfold: ∀α.∀ρ.(ρ → α → ρ) → ρ → list α → ρ = 11 | Λα.Λρ.λrxr.λr.case { 12 | Nil = λ().r 13 | Cons = λ(x, xs).fold«α»«ρ» rxr (rxr r x) xs 14 | } 15 | 16 | let empty = [] 17 | 18 | let prepend = Λα.λx: α.λxs: list α.'Cons (x, xs) 19 | 20 | let rev_to = Λα.fold«α»«list α» λxs.λx.prepend«α» x xs 21 | 22 | let rev = Λα.rev_to«α» 'Nil 23 | 24 | let map = Λα.Λβ.λxy: α → β.λxs: list α. 25 | xs 26 | ▷ fold«α»«list β» (λys.λx.'Cons (xy x, ys)) 'Nil 27 | ▷ rev«β» 28 | 29 | let chain = Λα.Λβ.λxys:α → list β.λxs: list α. 30 | xs 31 | ▷ fold«α»«list β» (λys.λx.rev_to«β» ys ◇ xys x) 'Nil 32 | ▷ rev«β» 33 | 34 | let filter = Λα.λp: α → bool.λxs: list α. 35 | xs 36 | ▷ fold«α»«list α» 37 | λxs.λx.if p x then 'Cons (x, xs) else xs 38 | 'Nil 39 | ▷ rev«α» 40 | 41 | let reject = Λα.λp: α → bool.filter«α» λx.¬p x 42 | 43 | let concat = Λα.λxs: list α.λys: list α.rev«α» xs ▷ rev_to«α» ys 44 | 45 | let infinite_of = Λα.λx: α.μxs: list_of_inf α.'Cons (x, xs) 46 | 47 | let head = Λα.case { 48 | Nil = λ().'None 49 | Cons = λ(x: α, _: list α).'Some x 50 | } 51 | 52 | let take_n = Λα.λn: int.λxs: list α. 53 | let μtake_n: list α → int → list α → list α = 54 | λys.λn.λxs. 55 | if n ≤ 0 then 56 | ys 57 | else 58 | xs ▷ case { 59 | Nil = λ().ys 60 | Cons = λ(x, xs).take_n 'Cons(x, ys) (n - 1) xs 61 | } 62 | take_n 'Nil n xs ▷ rev«α» 63 | 64 | let μdrop_n: ∀α.int → list α → list α = Λα.λn.λxs. 65 | if n ≤ 0 then 66 | xs 67 | else 68 | xs ▷ case { 69 | Nil = λ().'Nil 70 | Cons = λ(_, xs).drop_n«α» (n-1) xs 71 | } 72 | 73 | let nth = Λα.λn: int.λxs: list α.drop_n«α» n xs ▷ head«α» 74 | 75 | let iota = 76 | let μiota: list int → int → list int = λxs.λn. 77 | if 0 < n then let n = n - 1 in iota 'Cons(n, xs) n else xs 78 | iota 'Nil 79 | 80 | let is_empty: ∀α.list α → bool = 81 | case { 82 | Nil = λ_.true 83 | Cons = λ_.false 84 | } 85 | 86 | let iter = Λα.λxu: α → ().fold«α»«()» (λ().xu) () 87 | 88 | {of, map, chain, has, fold, rev_to, rev, filter, reject, concat, infinite_of, 89 | head, take_n, drop_n, nth, iota, is_empty, empty, prepend, iter} 90 | -------------------------------------------------------------------------------- /examples/lib/list.fomt: -------------------------------------------------------------------------------- 1 | include "types" in { 2 | of: ∀α.α → list_of_1 α 3 | map: ∀α.∀β.(α → β) → list α → list β 4 | chain: ∀α.∀β.(α → list β) → list α → list β 5 | has: ∀α.(α → bool) → list α → bool 6 | fold: ∀α.∀ρ.(ρ → α → ρ) → ρ → list α → ρ 7 | rev_to: ∀α.list α → list α → list α 8 | rev: ∀α.list α → list α 9 | filter: ∀α.(α → bool) → list α → list α 10 | concat: ∀α.list α → list α → list α 11 | infinite_of: ∀α.α → list_of_inf α 12 | head: ∀α.list α → opt α 13 | take_n: ∀α.int → list α → list α 14 | drop_n: ∀α.int → list α → list α 15 | nth: ∀α.int → list α → opt α 16 | iota: int → list int 17 | is_empty: ∀α.list α → bool 18 | empty: ∀α.list α 19 | prepend: ∀α.α → list α → list α 20 | iter: ∀α.(α → ()) → list α → () 21 | } 22 | -------------------------------------------------------------------------------- /examples/lib/map.fom: -------------------------------------------------------------------------------- 1 | include "algebras" 2 | include "types" 3 | 4 | let List = import "list" 5 | 6 | Λκ.λkey. 7 | type kv = λν.{key: κ, val: ν} 8 | 9 | type μtree = λν.'Lf | 'Br (br ν) 10 | and μbr = kv ∧ lg 11 | and μlg = λν.{lt: tree ν, gt: tree ν} 12 | 13 | type map = λν.Compare κ ∧ {root: tree ν} 14 | 15 | let empty = key „ {root = 'Lf} 16 | 17 | let get = Λν.λ{compare: κ → κ → ord, root: tree ν}.λkey: κ. 18 | let μget: tree ν → opt ν = case { 19 | Lf = λ().'None 20 | Br = λbr. 21 | compare key br.key ▷ case { 22 | Lt = λ().get br.lt 23 | Eq = λ().'Some br.val 24 | Gt = λ().get br.gt 25 | } 26 | } 27 | get root 28 | 29 | let put = Λν.λkey: κ.λval: ν.λ{compare: cmp κ, root: tree ν}. 30 | let μput: tree ν → tree ν = case { 31 | Lf = λ().'Br {key, val, lt = 'Lf, gt = 'Lf} 32 | Br = λbr. 33 | compare key br.key ▷ case { 34 | Lt = λ().'Br ((br: kv ν) „ {lt = put br.lt, gt = br.gt}) 35 | Eq = λ().'Br ({key, val} „ (br: lg ν)) 36 | Gt = λ().'Br ((br: kv ν) „ {lt = br.lt, gt = put br.gt}) 37 | } 38 | } 39 | {compare, root = put root} 40 | 41 | let fold_back = Λρ.Λν.λvrr: (κ, ν) → ρ → ρ.λs: ρ.λ{root: tree ν}. 42 | let μgo: tree ν → ρ → ρ = 43 | λnode.λs. 44 | node ▷ case { 45 | Lf = λ().s 46 | Br = λbr. 47 | s 48 | ▷ go br.gt 49 | ▷ vrr (br.key, br.val) 50 | ▷ go br.lt 51 | } 52 | go root s 53 | 54 | let count = Λν.fold_back«int»«ν» (λ_.λn.n + 1) 0 55 | 56 | let entries = Λν.fold_back«list (κ, ν)»«ν» List.prepend«(κ, ν)» 'Nil 57 | 58 | «map, {empty, get, put, fold_back, count, entries}» 59 | -------------------------------------------------------------------------------- /examples/lib/map.fomd: -------------------------------------------------------------------------------- 1 | local include "types" 2 | 3 | type Map = λκ.λmap.{ 4 | count: ∀ν.map ν → int 5 | empty: ∀ν.map ν 6 | entries: ∀ν.map ν → list (κ, ν) 7 | get: ∀ν.map ν → κ → opt ν 8 | put: ∀ν.κ → ν → map ν → map ν 9 | fold_back: ∀ρ.∀ν.((κ, ν) → ρ → ρ) → ρ → map ν → ρ 10 | } 11 | -------------------------------------------------------------------------------- /examples/lib/map.fomt: -------------------------------------------------------------------------------- 1 | include "algebras" 2 | include "map" 3 | 4 | ∀κ.Compare κ → ∃(Map κ) 5 | -------------------------------------------------------------------------------- /examples/lib/opt.fom: -------------------------------------------------------------------------------- 1 | include "types" 2 | include "algebras" 3 | 4 | let of = Λα.λx: α.'Some x 5 | 6 | let chain = Λα.Λβ.λxyO: α → opt β.case { 7 | None = λ().'None 8 | Some = λx: α.xyO x 9 | } 10 | 11 | let map = Λα.Λβ.λxy: α → β.case { 12 | None = λ().'None 13 | Some = λx: α.'Some (xy x) 14 | } 15 | 16 | let traverse = ΛF.λM: Monad F.Λα.Λβ.λxyM: α → F β.case { 17 | None = λ(). 18 | M.of«opt β» 'None 19 | Some = λx: α. 20 | xyM x ▷ M.chain«β»«opt β» λy. 21 | M.of«opt β» ◁ 'Some y 22 | } 23 | 24 | {of, map, chain, traverse} 25 | -------------------------------------------------------------------------------- /examples/lib/queue.fom: -------------------------------------------------------------------------------- 1 | include "types" 2 | 3 | let {of_core} = import "dispenser" 4 | 5 | let List = import "list" 6 | 7 | type queue = λν.{front: list ν, back: list ν} 8 | 9 | let empty = {front = [], back = []} 10 | 11 | let is_empty = Λν.λq: queue ν. 12 | List.is_empty«ν» q.front 13 | 14 | let insert = Λν.λv: ν.λq: queue ν. 15 | if List.is_empty«ν» q.front then 16 | {front = [v], back = []} 17 | else 18 | {front = q.front, back = 'Cons (v, q.back)} 19 | 20 | let remove = Λν.λq: queue ν. 21 | q.front ▷ case { 22 | Nil = λ().'None 23 | Cons = λ(v: ν, front: list ν). 24 | 'Some ( 25 | v, 26 | if List.is_empty«ν» front then 27 | {front = List.rev«ν» q.back, back = []} 28 | else 29 | {front, back = q.back} 30 | ) 31 | } 32 | 33 | «queue, of_core «queue» {empty, insert, remove, is_empty}» 34 | -------------------------------------------------------------------------------- /examples/lib/queue.fomt: -------------------------------------------------------------------------------- 1 | include "dispenser" 2 | 3 | ∃(Dispenser) 4 | -------------------------------------------------------------------------------- /examples/lib/ref.fom: -------------------------------------------------------------------------------- 1 | type ref = λα.∃ref.ref α 2 | 3 | let ref = Λα.λx: α.target«α → impure (ref α)» "x => [x]" x ▷ keep«ref α» 4 | let get = Λα.λr: ref α.target«ref α → impure α» "r => r[0]" r ▷ keep«α» 5 | let set = Λα.λr: ref α.λx: α. 6 | target«ref α → α → impure ()» "r => x => { r[0] = x }" r x ▷ keep«()» 7 | 8 | «ref, {ref, get, set}» 9 | -------------------------------------------------------------------------------- /examples/lib/ref.fomd: -------------------------------------------------------------------------------- 1 | type Ref = λref.{ 2 | ref: ∀α.α → ref α 3 | get: ∀α.ref α → α 4 | set: ∀α.ref α → α → () 5 | } 6 | -------------------------------------------------------------------------------- /examples/lib/ref.fomt: -------------------------------------------------------------------------------- 1 | include "ref" 2 | 3 | ∃(Ref) 4 | -------------------------------------------------------------------------------- /examples/lib/stack.fom: -------------------------------------------------------------------------------- 1 | include "types" 2 | 3 | let {of_core} = import "dispenser" 4 | 5 | let List = import "list" 6 | 7 | type stack = list 8 | 9 | let empty = [] 10 | let is_empty = List.is_empty 11 | let insert = Λν.λv: ν.λq: stack ν.'Cons (v, q) 12 | let remove = Λν.case { 13 | Nil = λ().'None 14 | Cons = λ(x: ν, xs: list ν).'Some (x, xs) 15 | } 16 | 17 | «stack, of_core «stack» {empty, insert, remove, is_empty}» 18 | -------------------------------------------------------------------------------- /examples/lib/stack.fomt: -------------------------------------------------------------------------------- 1 | include "dispenser" 2 | 3 | ∃(Dispenser) 4 | -------------------------------------------------------------------------------- /examples/lib/string.fom: -------------------------------------------------------------------------------- 1 | include "types" 2 | 3 | let List = import "list" 4 | 5 | let equals = (=«string») 6 | 7 | let to_literal = target«string → string» "JSON.stringify" 8 | 9 | let join: list string → string = List.fold«string»«string» (^) "" 10 | 11 | {equals, to_literal, join} 12 | -------------------------------------------------------------------------------- /examples/lib/string.fomt: -------------------------------------------------------------------------------- 1 | include "types" 2 | 3 | { 4 | equals: string → string → bool 5 | to_literal: string → string 6 | join: list string → string 7 | } 8 | -------------------------------------------------------------------------------- /examples/lib/target.fom: -------------------------------------------------------------------------------- 1 | let to_string = target«∀α.α → string» "x => \"\"+x" 2 | 3 | let fail = Λα.λm: string. 4 | target«∀α.string → impure α» "m => { throw new Error(m) }" «α» m 5 | ▷ keep«α» 6 | 7 | {to_string, fail} 8 | -------------------------------------------------------------------------------- /examples/lib/types.fomd: -------------------------------------------------------------------------------- 1 | type id = λα.α 2 | 3 | type ord = 'Lt | 'Eq | 'Gt 4 | 5 | type cmp = λα.α → α → ord 6 | 7 | type opt = λα.'None | 'Some α 8 | 9 | type res = λω.λα.'Error ω | 'Ok α 10 | 11 | type μlist = λα.[] ∨ [α, …list α] 12 | type μlist_of_1 = λα.[α] 13 | type μlist_of_1_to_n = λα.[α, …list α] 14 | type μlist_of_inf = λα.[α, …list_of_inf α] 15 | 16 | type alt = λα.λβ.'In1 α | 'In2 β 17 | 18 | type iso = λα.λβ.(α → β, β → α) 19 | 20 | type any = ∃α.α 21 | type nothing = ∀α.α 22 | -------------------------------------------------------------------------------- /examples/lib/univ.fom: -------------------------------------------------------------------------------- 1 | include "types" 2 | 3 | let new_id = 4 | let «ref, {ref, get, set}» = import "ref" 5 | let counter = ref«int» 0 6 | λ(). 7 | let id = get«int» counter 8 | set«int» counter (id + 1) 9 | id 10 | 11 | let unsafe_cast = target«∀α.α → nothing» "x => x" 12 | 13 | type univ = {id: int, value: nothing} 14 | 15 | let new = Λα.λ(). 16 | let id = new_id () 17 | let to = λx: α.{id, value = unsafe_cast«α» x} 18 | let of = λx: univ. 19 | if x.id =«int» id then 20 | 'Some x.value«α» 21 | else 22 | 'None 23 | {to, of} 24 | 25 | «univ, {new}» 26 | -------------------------------------------------------------------------------- /examples/lib/univ.fomd: -------------------------------------------------------------------------------- 1 | local include "types" 2 | 3 | type Univ = λuniv.{ 4 | new: ∀α.() → {to: α → univ, of: univ → opt α} 5 | } 6 | -------------------------------------------------------------------------------- /examples/lib/univ.fomt: -------------------------------------------------------------------------------- 1 | include "univ" 2 | 3 | ∃(Univ) 4 | -------------------------------------------------------------------------------- /examples/list-encoding.fom: -------------------------------------------------------------------------------- 1 | # Recursive `list` type encoding and `fold` function 2 | 3 | type μlist = λt.∀r.{nil: r, cons: t → list t → r} → r 4 | 5 | let nil: ∀(list) = λc.c.nil 6 | let cons: ∀t.t → list t → list t = 7 | λhd.λtl.λc.c.cons hd tl 8 | 9 | let μfold: ∀t.∀r.(t → r → r) → r → list t → r = 10 | Λt.Λr.λfn.λz.λxs. 11 | xs«r» {nil = z, cons = λx.λxs.fold«t»«r» fn ◇ fn x z ◇ xs} 12 | 13 | let pi_digits = cons«int» 3 ◁ cons«int» 1 ◁ cons«int» 4 ◁ cons«int» 1 ◁ nil«int» 14 | 15 | fold«int»«int» (+) 0 pi_digits 16 | -------------------------------------------------------------------------------- /examples/list-encoding.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/list-encoding.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𐘁 = l => r => (l + r) | 0 3 | const 𝛌cꓸcꓸnil = c => c.nil 4 | const 𝛌cꓸ𛰙cꓸcons_1𛰚_𝛌cꓸcꓸnil = c => c.cons(1)(𝛌cꓸcꓸnil) 5 | const 𝛌cꓸ𛰙cꓸcons_4𛰚_𛰙𝛌cꓸ𛰙cꓸcons_ = c => c.cons(4)(𝛌cꓸ𛰙cꓸcons_1𛰚_𝛌cꓸcꓸnil) 6 | const 𝛌cꓸ𛰙cꓸcons_1𛰚_𛰙𝛌cꓸ𛰙cꓸcons_ = c => c.cons(1)(𝛌cꓸ𛰙cꓸcons_4𛰚_𛰙𝛌cꓸ𛰙cꓸcons_) 7 | const 𝛌cꓸ𛰙cꓸcons_3𛰚_𛰙𝛌cꓸ𛰙cꓸcons_ = c => c.cons(3)(𝛌cꓸ𛰙cꓸcons_1𛰚_𛰙𝛌cꓸ𛰙cꓸcons_) 8 | const _fold = fn => z => xs => 9 | xs({nil: z, cons: x => xs$1 => _fold(fn)(fn(x)(z))(xs$1)}) 10 | _fold(𐘁)(0)(𝛌cꓸ𛰙cꓸcons_3𛰚_𛰙𝛌cꓸ𛰙cꓸcons_) 11 | -------------------------------------------------------------------------------- /examples/list-encoding.out: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /examples/list.fom: -------------------------------------------------------------------------------- 1 | # List using a recursive sum type 2 | 3 | type μlist = λα.'Nil | 'Cons (α, list α) 4 | 5 | let infiniteOf = Λα.λx: α.μxs: μω.'Cons (α, ω).'Cons (x, xs) 6 | 7 | let μtakeN: ∀α.int → list α → list α = 8 | Λα.λn.λxs. 9 | if n ≤ 0 then 10 | 'Nil 11 | else 12 | xs ▷ case { 13 | Nil = λ().'Nil, 14 | Cons = λ(x, xs).'Cons (x, takeN«α» ◇ n-1 ◇ xs) 15 | } 16 | 17 | takeN«string» 5 ◁ infiniteOf«string» "Fωμ" 18 | -------------------------------------------------------------------------------- /examples/list.fomi: -------------------------------------------------------------------------------- 1 | (μlist:* → *.λα.'Nil | 'Cons (α, list α)) string 2 | -------------------------------------------------------------------------------- /examples/list.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐟNil = ['Nil'] 3 | const ᐥFωμᐥ = 'Fωμ' 4 | const 𝛍xsꓸᐟCons𛰙ᐥFωμᐥꓹ_xs𛰚 = rec(xs => ['Cons', {1: ᐥFωμᐥ, 2: xs}]) 5 | const _takeN = n => xs => { 6 | if (n <= 0) { 7 | return ᐟNil 8 | } else { 9 | const [tag_xs, val_xs] = xs 10 | if (tag_xs === 'Nil') { 11 | return ᐟNil 12 | } else { 13 | const $2$ = _takeN((n - 1) | 0)(val_xs[2]) 14 | return ['Cons', {1: val_xs[1], 2: $2$}] 15 | } 16 | } 17 | } 18 | _takeN(5)(𝛍xsꓸᐟCons𛰙ᐥFωμᐥꓹ_xs𛰚) 19 | -------------------------------------------------------------------------------- /examples/list.out: -------------------------------------------------------------------------------- 1 | ["Fωμ", "Fωμ", "Fωμ", "Fωμ", "Fωμ"] 2 | -------------------------------------------------------------------------------- /examples/lists-of-various-lengths.fom: -------------------------------------------------------------------------------- 1 | # Types of lists of various lengths 2 | 3 | # This example explores the idea that with equirecursive structural types it is 4 | # possible to encode some properties of the length of a list, such as that a 5 | # list is non-empty, without using number parameterized types. 6 | 7 | # An ordinary recursive list type 8 | type μlist_of_0_to_n = λα.'Nil | 'Cons (α, list_of_0_to_n α) 9 | 10 | # A list of exactly one element 11 | type list_of_1 = λα.'Cons (α, 'Nil) 12 | 13 | # A list of one or more elements 14 | type list_of_1_to_n = λα.'Cons (α, list_of_0_to_n α) 15 | 16 | # An infinite list (due to strictness these are always cycles) 17 | type μlist_of_inf = λα.'Cons (α, list_of_inf α) 18 | 19 | # We now have the following subtype relationships: 20 | # 21 | # list_of_1_to_n α ⊂ list_of_0_to_n α 22 | # list_of_inf α ⊂ list_of_1_to_n α 23 | # list_of_1 α ⊂ list_of_1_to_n α 24 | # 25 | # Or as a hierarhy: 26 | # 27 | # list_of_0_to_n α 28 | # | 29 | # list_of_1_to_n α 30 | # / \ 31 | # list_of_1 α list_of_inf α 32 | # 33 | # Moreover, lists of any finite length or more can be similarly specified 34 | # yielding the expected subtype relationships. 35 | 36 | let an_empty_list : list_of_0_to_n int = 'Nil 37 | let a_singleton_list : list_of_1 int = 'Cons (2, 'Nil) 38 | let a_non_empty_list : list_of_1_to_n int = 'Cons (101, 'Nil) 39 | let μan_infinite_list : list_of_inf int = 'Cons (42, an_infinite_list) 40 | 41 | # Type safe function to get the first element of a non-empty list: 42 | let head: ∀α.list_of_1_to_n α → α = case { Cons = λ(x, _).x } 43 | 44 | let _ = head«int» an_infinite_list 45 | let _ = head«int» a_non_empty_list 46 | let _ = head«int» 'Cons(4, an_empty_list) 47 | 48 | # Extract the only element of a one element list: 49 | let only: ∀α.list_of_1 α → α = case { Cons = λ(x, _).x } 50 | 51 | let _ = only«int» a_singleton_list 52 | 53 | # The type of `cycle` guarantees that it returns an infinite list: 54 | let cycle: ∀α.list_of_1_to_n α → list_of_inf α = Λα.λxxs. 55 | μcycle. 56 | let μcomplete: list_of_0_to_n α → list_of_inf α = λxs. 57 | # Equality is work-in-progress 🤫 58 | if xxs =«list_of_0_to_n α» xs then 59 | cycle 60 | else 61 | xs ▷ case { 62 | Nil = λ().cycle 63 | Cons = λ(x, xs).'Cons (x, complete xs) 64 | } 65 | xxs ▷ case { Cons = λ(x, xs).'Cons (x, complete xs) } 66 | 67 | cycle«int» 'Cons(4, a_singleton_list) 68 | ▷ cycle«int» 69 | -------------------------------------------------------------------------------- /examples/lists-of-various-lengths.fomi: -------------------------------------------------------------------------------- 1 | (μlist_of_inf:* → *.λα.'Cons (α, list_of_inf α)) int 2 | -------------------------------------------------------------------------------- /examples/lists-of-various-lengths.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐟNil = ['Nil'] 3 | const 𛰙2ꓹ_ᐟNil𛰚 = {1: 2, 2: ᐟNil} 4 | const ᐟCons𛰙2ꓹ_ᐟNil𛰚 = ['Cons', 𛰙2ꓹ_ᐟNil𛰚] 5 | const 𛰙4ꓹ_ᐟCons𛰙2ꓹ_ᐟNil𛰚𛰚 = {1: 4, 2: ᐟCons𛰙2ꓹ_ᐟNil𛰚} 6 | const ᐟCons𛰙4ꓹ_ᐟCons𛰙2ꓹ_ᐟNil𛰚𛰚 = ['Cons', 𛰙4ꓹ_ᐟCons𛰙2ꓹ_ᐟNil𛰚𛰚] 7 | const _cycle = xxs => 8 | rec(cycle => { 9 | const _complete = xs => { 10 | if (xxs === xs) { 11 | return cycle 12 | } else { 13 | const [tag_xs, val_xs] = xs 14 | if (tag_xs === 'Nil') { 15 | return cycle 16 | } else { 17 | const $2$ = _complete(val_xs[2]) 18 | return ['Cons', {1: val_xs[1], 2: $2$}] 19 | } 20 | } 21 | } 22 | const $2$ = _complete(xxs[1][2]) 23 | return ['Cons', {1: xxs[1][1], 2: $2$}] 24 | }) 25 | const _AppL = _cycle(ᐟCons𛰙4ꓹ_ᐟCons𛰙2ꓹ_ᐟNil𛰚𛰚) 26 | _cycle(_AppL) 27 | -------------------------------------------------------------------------------- /examples/lists-of-various-lengths.out: -------------------------------------------------------------------------------- 1 | μα₁.'Cons (4, 'Cons (2, α₁)) 2 | -------------------------------------------------------------------------------- /examples/nat-gadt-using-eq-witnesses.fom: -------------------------------------------------------------------------------- 1 | # Natural number GADT encoding using type equality witnesses 2 | 3 | include "lib/types" 4 | 5 | let «eq, Eq» = import "lib/eq" 6 | 7 | type μNat = λn. 8 | | 'Zero (Zero n) 9 | | 'Succ ∃(Succ n) 10 | and μZero = λn. eq 'Z n 11 | and μSucc = λn.λm.(eq 'S(m) n, Nat m) 12 | 13 | let Zero: Nat 'Z = 'Zero Eq.refl«'Z» 14 | let Succ: ∀n.Nat n → Nat 'S(n) = Λn.λn.'Succ «n, (Eq.refl«'S n», n)» 15 | 16 | let from: int → opt ∃(Nat) = λn. 17 | if n < 0 then 18 | 'None 19 | else 20 | let μloop: ∀n.Nat n → int → ∃(Nat) = Λn.λn.λi. 21 | if i ≤ 0 then 22 | «n, n» 23 | else 24 | loop«'S n» (Succ«n» n) (i-1) 25 | 'Some (loop«'Z» Zero n) 26 | 27 | let to: ∃(Nat) → int = λ«n, n». 28 | let μloop: ∀n.Nat n → int → int = λn.λi. 29 | n ▷ case { 30 | Zero = λ_.i 31 | Succ = λ«n, (_, n)».loop«n» n (i+1) 32 | } 33 | loop«n» n 0 34 | 35 | from 10 ▷ case { 36 | None = λ().0 37 | Some = to 38 | } 39 | -------------------------------------------------------------------------------- /examples/nat-gadt-using-eq-witnesses.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/nat-gadt-using-eq-witnesses.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌xꓸx = x => x 3 | const ᐟZero𛰙𝛌xꓸx𛰚 = ['Zero', 𝛌xꓸx] 4 | const _loop = n$1 => i$1 => { 5 | for (;;) { 6 | const n = n$1, 7 | i = i$1 8 | if (i <= 0) { 9 | return n 10 | } else { 11 | ;(n$1 = ['Succ', {1: 𝛌xꓸx, 2: n}]), (i$1 = (i - 1) | 0) 12 | } 13 | } 14 | } 15 | const _n = _loop(ᐟZero𛰙𝛌xꓸx𛰚)(10) 16 | const _loop$1 = n$1 => i$1 => { 17 | for (;;) { 18 | const n = n$1, 19 | i = i$1 20 | const [tag_n, val_n] = n 21 | if (tag_n === 'Zero') { 22 | return i 23 | } else { 24 | ;(n$1 = val_n[2]), (i$1 = (i + 1) | 0) 25 | } 26 | } 27 | } 28 | _loop$1(_n)(0) 29 | -------------------------------------------------------------------------------- /examples/nat-gadt-using-eq-witnesses.out: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /examples/nat-gadt.fom: -------------------------------------------------------------------------------- 1 | # Natural number GADT using Scott encoding 2 | 3 | include "lib/types" 4 | 5 | type μNat = λn.∀r.Cases r → r n 6 | 7 | and μCases = λr.{ 8 | Zero: r 'Z 9 | Succ: ∀n.Nat n → r 'S(n) 10 | } 11 | 12 | let {Zero, Succ}: Cases Nat = { 13 | Zero = λcs.cs.Zero 14 | Succ = Λn.λn.λcs.cs.Succ«n» n 15 | } 16 | 17 | let from: int → opt ∃(Nat) = λn. 18 | if n < 0 then 19 | 'None 20 | else 21 | let μloop: ∀n.Nat n → int → ∃(Nat) = Λn.λn.λi. 22 | if i ≤ 0 then 23 | «n, n» 24 | else 25 | loop«'S n» (Succ«n» n) (i-1) 26 | 'Some (loop«'Z» Zero n) 27 | 28 | let to: ∃(Nat) → int = λ«n, n». 29 | let μloop: ∀n.Nat n → int → int = λn.λi. 30 | n«λ_.int» { 31 | Zero = i 32 | Succ = Λn.λn.loop«n» n (i + 1) 33 | } 34 | loop«n» n 0 35 | 36 | from 10 ▷ case { 37 | None = λ().0 38 | Some = to 39 | } 40 | -------------------------------------------------------------------------------- /examples/nat-gadt.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/nat-gadt.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌csꓸcsꓸZero = cs => cs.Zero 3 | const _loop = n$1 => i$1 => { 4 | for (;;) { 5 | const n = n$1, 6 | i = i$1 7 | if (i <= 0) { 8 | return n 9 | } else { 10 | ;(n$1 = cs => cs.Succ(n)), (i$1 = (i - 1) | 0) 11 | } 12 | } 13 | } 14 | const _n = _loop(𝛌csꓸcsꓸZero)(10) 15 | const _loop$1 = n => i => n({Zero: i, Succ: n$1 => _loop$1(n$1)((i + 1) | 0)}) 16 | _loop$1(_n)(0) 17 | -------------------------------------------------------------------------------- /examples/nat-gadt.out: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /examples/object-oriented-sets.fom: -------------------------------------------------------------------------------- 1 | # Object-oriented integer set implementations 2 | 3 | # This is a translation of snippets from the essay 4 | # 5 | # On Understanding Data Abstraction, Revisited 6 | # by William R. Cook. 7 | 8 | type μISet = { 9 | isEmpty: bool 10 | contains: int → bool 11 | insert: int → ISet 12 | union: ISet → ISet 13 | } 14 | 15 | let μInsert: (ISet, int) → ISet = λ(s, n). 16 | if s.contains n then s else μthis.{ 17 | isEmpty = false 18 | contains = λi.i =«int» n ∨ s.contains i 19 | insert = λi.Insert (this, i) 20 | union = λs.Union (this, s) 21 | } 22 | 23 | and μUnion: (ISet, ISet) → ISet = λ(s1, s2). 24 | μthis.{ 25 | isEmpty = s1.isEmpty ∧ s2.isEmpty 26 | contains = λi.s1.contains i ∨ s2.contains i 27 | insert = λi.Insert (this, i) 28 | union = λs.Union (this, s) 29 | } 30 | 31 | let μEmpty: ISet = { 32 | isEmpty = true 33 | contains = λ_.false 34 | insert = λi.Insert (Empty, i) 35 | union = λs.s 36 | } 37 | 38 | let μEven: ISet = { 39 | isEmpty = false 40 | contains = λi.i % 2 =«int» 0 41 | insert = λi.Insert (Even, i) 42 | union = λs.Union (Even, s) 43 | } 44 | 45 | let μFull: ISet = { 46 | isEmpty = false 47 | contains = λ_.true 48 | insert = λ_.Full 49 | union = λ_.Full 50 | } 51 | 52 | let Interval: (int, int) → ISet = λ(n, m). 53 | μthis.{ 54 | isEmpty = n > m 55 | contains = λi.n ≤ i ∧ i ≤ m 56 | insert = λi.Insert (this, i) 57 | union = λs.Union (this, s) 58 | } 59 | 60 | Empty.insert(4).union(Empty.insert 2) 61 | -------------------------------------------------------------------------------- /examples/object-oriented-sets.fomi: -------------------------------------------------------------------------------- 1 | μISet.{isEmpty: bool, contains: int → bool, insert: int → ISet, union: ISet → ISet} 2 | -------------------------------------------------------------------------------- /examples/object-oriented-sets.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌_ꓸfalse = _ => false 3 | const 𝛌sꓸs = s => s 4 | const Insert = _𛰙sꓹ_n𛰚 => { 5 | if (_𛰙sꓹ_n𛰚[1].contains(_𛰙sꓹ_n𛰚[2])) { 6 | return _𛰙sꓹ_n𛰚[1] 7 | } else { 8 | const $this$ = { 9 | isEmpty: false, 10 | contains: i => i === _𛰙sꓹ_n𛰚[2] || _𛰙sꓹ_n𛰚[1].contains(i), 11 | insert: i => Insert({1: $this$, 2: i}), 12 | union: s => Union({1: $this$, 2: s}), 13 | } 14 | return $this$ 15 | } 16 | } 17 | const Union = _𛰙s1ꓹ_s2𛰚 => { 18 | const $this$ = { 19 | isEmpty: _𛰙s1ꓹ_s2𛰚[1].isEmpty && _𛰙s1ꓹ_s2𛰚[2].isEmpty, 20 | contains: i => _𛰙s1ꓹ_s2𛰚[1].contains(i) || _𛰙s1ꓹ_s2𛰚[2].contains(i), 21 | insert: i => Insert({1: $this$, 2: i}), 22 | union: s => Union({1: $this$, 2: s}), 23 | } 24 | return $this$ 25 | } 26 | const _Empty = { 27 | isEmpty: true, 28 | contains: 𝛌_ꓸfalse, 29 | insert: i => Insert({1: _Empty, 2: i}), 30 | union: 𝛌sꓸs, 31 | } 32 | _Empty.insert(4).union(_Empty.insert(2)) 33 | -------------------------------------------------------------------------------- /examples/object-oriented-sets.out: -------------------------------------------------------------------------------- 1 | {isEmpty = false, contains = λcontains, insert = λinsert, union = λunion} 2 | -------------------------------------------------------------------------------- /examples/pick-apple.fom: -------------------------------------------------------------------------------- 1 | # Comparing Apples to Apples 2 | 3 | # This example is inspired by the paper 4 | # 5 | # An extended comparative study of language support for generic programming 6 | # by Jaakko Järvi, Andrew Lumsdaine, and Jeremy Siek 7 | # https://www.researchgate.net/publication/213880958_An_extended_comparative_study_of_language_support_for_generic_programming 8 | 9 | type Comparable = λα.{ 10 | better: α → α → bool 11 | } 12 | 13 | let pick = Λα.λC: Comparable α.λl: α.λr: α. 14 | if C.better l r then l else r 15 | 16 | type Apple = {apple: int} 17 | 18 | let Apple = { 19 | better = λl: Apple.λr: Apple. 20 | r.apple < l.apple 21 | } 22 | 23 | let a1 = {apple = 101} 24 | and a2 = {apple = 42} 25 | 26 | pick«Apple» Apple a1 a2 27 | -------------------------------------------------------------------------------- /examples/pick-apple.fomi: -------------------------------------------------------------------------------- 1 | {apple: int} 2 | -------------------------------------------------------------------------------- /examples/pick-apple.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | ;({apple: 101}) 3 | -------------------------------------------------------------------------------- /examples/pick-apple.out: -------------------------------------------------------------------------------- 1 | {apple = 101} 2 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-pretense.fom: -------------------------------------------------------------------------------- 1 | # Polymorphic container without pretense 2 | 3 | # Inspired by 4 | # 5 | # Getting around polymorphism restrictions using Category Theory and pretense 6 | # by Oleg Kiselyov 7 | # http://okmij.org/ftp/Computation/extra-polymorphism.html#irregular 8 | # 9 | # this shows that in Fωμ there is no need for pretense as the infinite expansion 10 | # of the type is still considered to have finitely many distinct subtrees. In 11 | # Fωμ, regularity restriction is weakened to a non-nestedness restriction. 12 | 13 | let Int = import "lib/int" 14 | 15 | type μcontainer = λα.{ 16 | get: α 17 | map: ∀β.(α → β) → container β 18 | } 19 | 20 | let μcontainer: ∀α.α → container α = λx.{ 21 | get = x 22 | map = Λβ.λxy.container«β» (xy x) 23 | } 24 | 25 | container«int»(101).map«string» Int.to_string 26 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-pretense.fomi: -------------------------------------------------------------------------------- 1 | (μcontainer:* → *.λα.{get: α, map: ∀β.(α → β) → container β}) string 2 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-pretense.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const target_ꓯαꓸα_𐙤_string_ᐥx_ꘌᐳ_ = x => '' + x 3 | const _container = x => ({get: x, map: xy => _container(xy(x))}) 4 | _container(101).map(target_ꓯαꓸα_𐙤_string_ᐥx_ꘌᐳ_) 5 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-pretense.out: -------------------------------------------------------------------------------- 1 | {get = "101", map = λmap} 2 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-recursion.fom: -------------------------------------------------------------------------------- 1 | # Polymorphic container without recursion 2 | 3 | # Inspired by 4 | # 5 | # Getting around polymorphism restrictions using Category Theory and pretense 6 | # by Oleg Kiselyov 7 | # http://okmij.org/ftp/Computation/extra-polymorphism.html#irregular 8 | # 9 | # this avoids the issue entirely by not using recursion. 10 | 11 | let Int = import "lib/int" 12 | 13 | # This is like in TAPL, section 32.4., except that `τ` takes a parameter. 14 | 15 | type Object = λM.λα.∃τ.(τ α, M τ) 16 | 17 | type ContainerM = λcontainer.{ 18 | get: ∀α.container α → α 19 | map: ∀α.∀β.(α → β) → container α → container β 20 | } 21 | 22 | let ContainerC: ContainerM λx.x = { 23 | get = λx.x 24 | map = λab.ab 25 | } 26 | 27 | let container: ∀α.α → Object ContainerM α = λx.«λx.x, (x, ContainerC)» 28 | 29 | # Unlike in TAPL we use an explicit coercion (naïve witness) to encode bounded 30 | # quantification. 31 | 32 | type ContainerB = λM.∀τ.M τ → ContainerM τ 33 | 34 | let get: ∀M.ContainerB M → ∀α.Object M α → α = 35 | λB.Λα.λ«τ, (x, M)». 36 | let C = B«τ» M 37 | C.get«α» x 38 | 39 | let map: ∀M.ContainerB M → ∀α.∀β.(α → β) → Object M α → Object M β = 40 | λB.Λα.Λβ.λab.λ«τ, (x, M)». 41 | let C = B«τ» M 42 | «τ, (C.map«α»«β» ab x, M)» 43 | 44 | let ContainerB = Λτ.λM: ContainerM τ.M 45 | 46 | container«int» 101 47 | ▷ map«ContainerM» ContainerB «int» «string» Int.to_string 48 | ▷ get«ContainerM» ContainerB «string» 49 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-recursion.fomi: -------------------------------------------------------------------------------- 1 | string 2 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-recursion.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const target_ꓯαꓸα_𐙤_string_ᐥx_ꘌᐳ_ = x => '' + x 3 | target_ꓯαꓸα_𐙤_string_ᐥx_ꘌᐳ_(101) 4 | -------------------------------------------------------------------------------- /examples/polymorphic-container-without-recursion.out: -------------------------------------------------------------------------------- 1 | "101" 2 | -------------------------------------------------------------------------------- /examples/simple-push-stream.fom: -------------------------------------------------------------------------------- 1 | # Simple Push Stream 2 | 3 | # This example is inspired by the talk 4 | # 5 | # Even Better Stream Fusion 6 | # by Oleg Kiselyov 7 | # https://www.youtube.com/watch?v=WrbAwOTekaQ 8 | 9 | let «ref, Ref» = import "lib/ref" 10 | let «array, Array» = import "lib/array" 11 | 12 | # At the moment Fωμ does not have primitive support for arrays and ref cells so 13 | # we use opaque native JavaScript for those. 14 | 15 | type Arr = λarr.{ 16 | of_array: ∀α.array α → arr α 17 | map: ∀α.∀β.(α → β) → arr α → arr β 18 | filter: ∀α.(α → bool) → arr α → arr α 19 | sum: arr int → int 20 | } 21 | 22 | let «arr, Arr»: ∃(Arr) = 23 | «λα.{n: int, ix: int → (α → ()) → ()}, { 24 | of_array = Λα.λxs.{n = Array.length«α» xs, ix = λi.λk.k (Array.sub«α» xs i)} 25 | map = λxy.λ{n, ix}.{n, ix = λi.λk.ix i λx.k (xy x)} 26 | filter = λxb.λ{n, ix}.{n, ix = λi.λk.ix i λx.if xb x then k x else ()} 27 | sum = λ{n, ix}. 28 | let sum = Ref.ref«int» 0 29 | let μloop: int → int = λi. 30 | if i < n then 31 | ix i λx.Ref.set«int» sum (x + Ref.get«int» sum) 32 | loop (i + 1) 33 | else 34 | Ref.get«int» sum 35 | loop 0 36 | }» 37 | 38 | # The non-recursive implementation of push streams allows the Fωμ toy compiler 39 | # to essentially eliminate all abstraction overhead. The end result is a loop 40 | # whose body contains no closures or other short lived allocations. Of course, 41 | # the opaque native JavaScript cannot be optimized by the Fωμ toy compiler and 42 | # should be replaced with transparent primitives. 43 | 44 | 10 45 | ▷ Array.tabulate«int» λi.i 46 | ▷ Arr.of_array«int» 47 | ▷ Arr.filter«int» λx.x % 2 ≠«int» 0 48 | ▷ Arr.map«int»«int» λx.x * x 49 | ▷ Arr.sum 50 | -------------------------------------------------------------------------------- /examples/simple-push-stream.fomi: -------------------------------------------------------------------------------- 1 | int 2 | -------------------------------------------------------------------------------- /examples/simple-push-stream.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_ = r => x => { 3 | r[0] = x 4 | } 5 | const target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_$1 = r => r[0] 6 | const target_ꓯαꓸ𛰙ꓱarrayꓽᕯ_𐙤_ᕯꓸarray_ = a => i => { 7 | if (i < 0 || a.length <= i) 8 | throw new Error(`Array.sub: Index out of bounds: 0 <= ${i} < ${a.length}`) 9 | return a[i] 10 | } 11 | const target_α_𐙤_impure_𛰙ꓱrefꓽᕯ_ = x => [x] 12 | const target_ꓯαꓽκꓸ𛰙ꓱarrayꓽκ_𐙤_ᕯꓸarray_ = a => a.length 13 | const target_ꓯαꓸ𛰙int_𐙤_α𛰚_𐙤_int_ = fn => n => { 14 | const a = new Array(n) 15 | for (let i = 0; i < n; ++i) a[i] = fn(i) 16 | return a 17 | } 18 | const 𝛌iꓸi = i => i 19 | const _AppL = target_ꓯαꓸ𛰙int_𐙤_α𛰚_𐙤_int_(𝛌iꓸi)(10) 20 | const n = target_ꓯαꓽκꓸ𛰙ꓱarrayꓽκ_𐙤_ᕯꓸarray_(_AppL) 21 | const sum = target_α_𐙤_impure_𛰙ꓱrefꓽᕯ_(0) 22 | const _loop = i$1 => { 23 | for (;;) { 24 | const i = i$1 25 | if (i < n) { 26 | const x = target_ꓯαꓸ𛰙ꓱarrayꓽᕯ_𐙤_ᕯꓸarray_(_AppL)(i) 27 | if ((x % 2 | 0) !== 0) { 28 | const x$1 = (((x * x) | 0) + target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_$1(sum)) | 0 29 | target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_(sum)(x$1) 30 | } else { 31 | } 32 | i$1 = (i + 1) | 0 33 | } else { 34 | return target_𛰙ꓱrefꓽᕯ_𐙤_ᕯꓸref_α𛰚_$1(sum) 35 | } 36 | } 37 | } 38 | _loop(0) 39 | -------------------------------------------------------------------------------- /examples/simple-push-stream.out: -------------------------------------------------------------------------------- 1 | 165 2 | -------------------------------------------------------------------------------- /examples/ski-combinators.fom: -------------------------------------------------------------------------------- 1 | # SKI combinators at type and value level 2 | 3 | type K = λx.λ_.x 4 | type S = λx.λy.λz.x z (y z) 5 | type I = S K K 6 | 7 | type μL = L → L 8 | let K = λx: L.λ_: L.x 9 | let S = λx: L.λy: L.λz: L.x z (y z) 10 | let I = S K K 11 | 12 | I 13 | -------------------------------------------------------------------------------- /examples/ski-combinators.fomi: -------------------------------------------------------------------------------- 1 | (μL.L → L) → μL.L → L 2 | -------------------------------------------------------------------------------- /examples/ski-combinators.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | z => z 3 | -------------------------------------------------------------------------------- /examples/ski-combinators.out: -------------------------------------------------------------------------------- 1 | λ_ 2 | -------------------------------------------------------------------------------- /examples/stack-adt.fom: -------------------------------------------------------------------------------- 1 | # Stack ADT using an existential type 2 | 3 | include "lib/types" 4 | 5 | type Stack = λstack.{ 6 | empty: ∀α.stack α 7 | push: ∀α.α → stack α → stack α 8 | pop: ∀α.stack α → opt (α, stack α) 9 | } 10 | 11 | let «stack, Stack»: ∃(Stack) = «list, { 12 | empty = 'Nil 13 | push = λx.λxs.'Cons (x, xs) 14 | pop = case { 15 | Nil = λ().'None 16 | Cons = λxxs.'Some xxs 17 | } 18 | }» 19 | 20 | let a_stack = 21 | Stack.empty«int» 22 | ▷ Stack.push«int» 3 23 | ▷ Stack.push«int» 1 24 | ▷ Stack.push«int» 5 25 | 26 | let μto_list: ∀α.stack α → list α = Λα.λs. 27 | Stack.pop«α» s ▷ case { 28 | None = λ().'Nil 29 | Some = λ(x, xs).'Cons (x, to_list«α» xs) 30 | } 31 | 32 | to_list«int» a_stack 33 | -------------------------------------------------------------------------------- /examples/stack-adt.fomi: -------------------------------------------------------------------------------- 1 | (μlist:* → *.λα.'Nil | 'Cons (α, list α)) int 2 | -------------------------------------------------------------------------------- /examples/stack-adt.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐟNil = ['Nil'] 3 | const 𛰙3ꓹ_ᐟNil𛰚 = {1: 3, 2: ᐟNil} 4 | const ᐟCons𛰙3ꓹ_ᐟNil𛰚 = ['Cons', 𛰙3ꓹ_ᐟNil𛰚] 5 | const 𛰙1ꓹ_ᐟCons𛰙3ꓹ_ᐟNil𛰚𛰚 = {1: 1, 2: ᐟCons𛰙3ꓹ_ᐟNil𛰚} 6 | const ᐟCons𛰙1ꓹ_ᐟCons𛰙3ꓹ_ᐟNil𛰚𛰚 = ['Cons', 𛰙1ꓹ_ᐟCons𛰙3ꓹ_ᐟNil𛰚𛰚] 7 | const 𛰙5ꓹ_ᐟCons𛰙1ꓹ_ᐟCons𛰙3ꓹ_ᐟNil𛰚𛰚𛰚 = {1: 5, 2: ᐟCons𛰙1ꓹ_ᐟCons𛰙3ꓹ_ᐟNil𛰚𛰚} 8 | const ᐟCons𛰙5ꓹ_ᐟCons𛰙1ꓹ_ᐟCons𛰙3ꓹ_ = ['Cons', 𛰙5ꓹ_ᐟCons𛰙1ꓹ_ᐟCons𛰙3ꓹ_ᐟNil𛰚𛰚𛰚] 9 | const _to_list = ᐟNil_ǀ_ᐟCons => { 10 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 11 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 12 | return ᐟNil 13 | } else { 14 | const $2$ = _to_list(val_ᐟNil_ǀ_ᐟCons[2]) 15 | return ['Cons', {1: val_ᐟNil_ǀ_ᐟCons[1], 2: $2$}] 16 | } 17 | } 18 | _to_list(ᐟCons𛰙5ꓹ_ᐟCons𛰙1ꓹ_ᐟCons𛰙3ꓹ_) 19 | -------------------------------------------------------------------------------- /examples/stack-adt.out: -------------------------------------------------------------------------------- 1 | [5, 1, 3] 2 | -------------------------------------------------------------------------------- /examples/stream-fusion.fom: -------------------------------------------------------------------------------- 1 | # Stream fusion 2 | 3 | # Based on the paper 4 | # 5 | # Stream fusion: From Lists to Streams to Nothing at All 6 | # Duncan Coutts, Roman Leschinskiy, Don Stewart 7 | # http://citeseer.ist.psu.edu/viewdoc/summary?doi=10.1.1.104.7401 8 | 9 | include "lib/types" 10 | 11 | let List = import "lib/list" 12 | 13 | type Stream = λstream.{ 14 | of_list: ∀α.list α → stream α 15 | to_list: ∀α.stream α → list α 16 | map: ∀α.∀β.(α → β) → stream α → stream β 17 | filter: ∀α.(α → bool) → stream α → stream α 18 | append: ∀α.stream α → stream α → stream α 19 | concatMap: ∀α.∀β.(α → stream β) → stream α → stream β 20 | } 21 | 22 | # Non recursive existential stream type 23 | let «stream, Stream»: ∃(Stream) = 24 | type stream = λα.∃s.(s, s → 'Done | 'Yield (α, s) | 'Skip s) 25 | «stream, { 26 | of_list = Λα.λxs.«list α, ( 27 | xs, 28 | case { 29 | Nil = λ().'Done 30 | Cons = λc.'Yield c 31 | } 32 | )» 33 | to_list = Λα.λ«s, (xs, next)». 34 | let μto_list: list α → s → list α = λys.λxs. 35 | next xs ▷ case { 36 | Done = λ().List.rev«α» ys 37 | Yield = λ(hd, tl).to_list 'Cons(hd, ys) tl 38 | Skip = to_list ys 39 | } 40 | to_list 'Nil xs 41 | map = λfn.λ«s, (xs, next)».«s, ( 42 | xs, 43 | λxs. 44 | next xs ▷ case { 45 | Done = λ().'Done 46 | Yield = λ(hd, tl).'Yield (fn hd, tl) 47 | Skip = λs.'Skip s 48 | } 49 | )» 50 | filter = λp.λ«s, (xs, next)».«s, ( 51 | xs, 52 | λxs. 53 | next xs ▷ case { 54 | Done = λ().'Done 55 | Yield = λ(hd, tl). 56 | if p hd then 'Yield (hd, tl) else 'Skip tl 57 | Skip = λs.'Skip s 58 | } 59 | )» 60 | append = λ«s1, (xs1, next1)».λ«s2, (xs2, next2)». 61 | «'S1 s1 | 'S2 s2, ( 62 | 'S1 xs1, 63 | case { 64 | S1 = λs1.next1 s1 ▷ case { 65 | Done = λ().'Skip 'S2(xs2) 66 | Yield = λ(hd, tl).'Yield (hd, 'S1 tl) 67 | Skip = λs1.'Skip 'S1(s1) 68 | } 69 | S2 = λs2.next2 s2 ▷ case { 70 | Done = λ().'Done 71 | Yield = λ(hd, tl).'Yield (hd, 'S2 tl) 72 | Skip = λs2.'Skip 'S2(s2) 73 | } 74 | } 75 | )» 76 | concatMap = Λ_.Λβ.λxys.λ«xs, (xs, next)». 77 | «(xs, opt (stream β)), ( 78 | (xs, 'None), 79 | λ(xs, ys_opt). 80 | ys_opt ▷ case { 81 | None = λ().next xs ▷ case { 82 | Done = λ().'Done 83 | Yield = λ(x, xs).'Skip (xs, 'Some (xys x)) 84 | Skip = λxs.'Skip (xs, 'None) 85 | } 86 | Some = λ«ys, (ys, next)». 87 | next ys ▷ case { 88 | Done = λ().'Skip (xs, 'None) 89 | Yield = λ(y, ys).'Yield (y, (xs, 'Some «ys, (ys, next)»)) 90 | Skip = λys.'Skip (xs, 'Some «ys, (ys, next)») 91 | } 92 | } 93 | )» 94 | }» 95 | 96 | # Thanks to the non-recursive implementation and a couple of optimizations, with 97 | # the exception of `concatMap`, the Fωμ toy compiler is able to fuse stream 98 | # operations, eliminate intermediate stream data structures, and translate the 99 | # stream expression to a collection of loops. 100 | 101 | let xs = List.iota 5 102 | Stream.append«int» ◇ Stream.of_list«int» xs ◇ Stream.of_list«int» xs 103 | ▷ Stream.map«int»«int» λx.x + 1 104 | ▷ Stream.filter«int» λx.x % 2 =«int» 1 105 | ▷ Stream.map«int»«int» λx.x * 2 106 | ▷ Stream.to_list«int» 107 | -------------------------------------------------------------------------------- /examples/stream-fusion.fomi: -------------------------------------------------------------------------------- 1 | (μlist:* → *.λα.'Nil | 'Cons (α, list α)) int 2 | -------------------------------------------------------------------------------- /examples/stream-fusion.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐟNil = ['Nil'] 3 | const 𝛌xsꓸλxꓸᐟCons𛰙xꓹ_xs𛰚 = xs => x => ['Cons', {1: x, 2: xs}] 4 | const _fold = rxr$1 => r$1 => ᐟNil_ǀ_ᐟCons$1 => { 5 | for (;;) { 6 | const rxr = rxr$1, 7 | r = r$1, 8 | ᐟNil_ǀ_ᐟCons = ᐟNil_ǀ_ᐟCons$1 9 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 10 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 11 | return r 12 | } else { 13 | ;(r$1 = rxr(r)(val_ᐟNil_ǀ_ᐟCons[1])), 14 | (ᐟNil_ǀ_ᐟCons$1 = val_ᐟNil_ǀ_ᐟCons[2]) 15 | } 16 | } 17 | } 18 | const _iota = xs$1 => n$1 => { 19 | for (;;) { 20 | const xs = xs$1, 21 | n = n$1 22 | if (0 < n) { 23 | ;(xs$1 = ['Cons', {1: (n - 1) | 0, 2: xs}]), (n$1 = (n - 1) | 0) 24 | } else { 25 | return xs 26 | } 27 | } 28 | } 29 | const xs = _iota(ᐟNil)(5) 30 | const S1 = ys$1 => ᐟNil_ǀ_ᐟCons$1 => { 31 | for (;;) { 32 | const ys = ys$1, 33 | ᐟNil_ǀ_ᐟCons = ᐟNil_ǀ_ᐟCons$1 34 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 35 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 36 | return S2(ys)(xs) 37 | } else { 38 | if ((((val_ᐟNil_ǀ_ᐟCons[1] + 1) | 0) % 2 | 0) === 1) { 39 | ;(ys$1 = [ 40 | 'Cons', 41 | {1: (((val_ᐟNil_ǀ_ᐟCons[1] + 1) | 0) * 2) | 0, 2: ys}, 42 | ]), 43 | (ᐟNil_ǀ_ᐟCons$1 = val_ᐟNil_ǀ_ᐟCons[2]) 44 | } else { 45 | ᐟNil_ǀ_ᐟCons$1 = val_ᐟNil_ǀ_ᐟCons[2] 46 | } 47 | } 48 | } 49 | } 50 | const S2 = ys$1 => ᐟNil_ǀ_ᐟCons$1 => { 51 | for (;;) { 52 | const ys = ys$1, 53 | ᐟNil_ǀ_ᐟCons = ᐟNil_ǀ_ᐟCons$1 54 | const [tag_ᐟNil_ǀ_ᐟCons, val_ᐟNil_ǀ_ᐟCons] = ᐟNil_ǀ_ᐟCons 55 | if (tag_ᐟNil_ǀ_ᐟCons === 'Nil') { 56 | return _fold(𝛌xsꓸλxꓸᐟCons𛰙xꓹ_xs𛰚)(ᐟNil)(ys) 57 | } else { 58 | if ((((val_ᐟNil_ǀ_ᐟCons[1] + 1) | 0) % 2 | 0) === 1) { 59 | ;(ys$1 = [ 60 | 'Cons', 61 | {1: (((val_ᐟNil_ǀ_ᐟCons[1] + 1) | 0) * 2) | 0, 2: ys}, 62 | ]), 63 | (ᐟNil_ǀ_ᐟCons$1 = val_ᐟNil_ǀ_ᐟCons[2]) 64 | } else { 65 | ᐟNil_ǀ_ᐟCons$1 = val_ᐟNil_ǀ_ᐟCons[2] 66 | } 67 | } 68 | } 69 | } 70 | S1(ᐟNil)(xs) 71 | -------------------------------------------------------------------------------- /examples/stream-fusion.out: -------------------------------------------------------------------------------- 1 | [2, 6, 10, 2, 6, 10] 2 | -------------------------------------------------------------------------------- /examples/template-strings.fom: -------------------------------------------------------------------------------- 1 | # Template strings 2 | 3 | include "lib/types" 4 | 5 | # The syntax of string literals in Fωμ is an extension of JSON strings. A valid 6 | # JSON string is also a valid string literal in Fωμ. By tapping into invalid 7 | # escape sequences of JSON strings, Fωμ extends the syntax of literals to allow 8 | # them to be formatted and constructed more conveniently. 9 | 10 | # First of all, multiline literals can use Standard ML style `\ws+\` ignored 11 | # escapes. Alternatively, a string literal can include a newline followed by 12 | # ignored whitespace and a `\` to continue the literal. Both of these allow to 13 | # break and align a literal over multiple lines. 14 | 15 | # For example, the binding 16 | 17 | let expression = "if (condition) {\n action()\n}" 18 | 19 | # can also be expressed equivalently using SML style escapes as 20 | 21 | let expression = 22 | "if (condition) {\n\ 23 | \ action()\n\ 24 | \}" 25 | 26 | # and using newline escapes as 27 | 28 | let expression = 29 | "if (condition) { 30 | \ action() 31 | \}" 32 | 33 | # The SML style escapes allow to break a literal over multiple lines without 34 | # inserting newlines to the resulting string. 35 | 36 | # Fωμ also implements a syntax for string interpolation or template strings. 37 | 38 | # In the basic form one can use the `\(` escape as an alternative to string 39 | # concatenation: 40 | 41 | let message = λsubstitution: string. 42 | "Hello, \(substitution)!" 43 | 44 | # Template strings actually elaborate to a fold over the fragments, i.e. 45 | # literal strings and tagged expressions `\specifier(expression)`, of the 46 | # template string. 47 | 48 | # The semantics of the fold can be provided as a named record. The default 49 | # semantics is implemented equivalently to the record 50 | 51 | let def = { 52 | begin = "" 53 | finish = λaccum: string.accum 54 | string = λvalue: string.λaccum: string.accum ^ value 55 | text = λliteral: string.λaccum: string.accum ^ literal 56 | } 57 | 58 | # and the empty tag `\(` is interpreted as `\string(`. So the message function 59 | # could be more explicitly and equivalently written as 60 | 61 | let message = λsubstitution: string. 62 | def"Hello, \string(substitution)!" 63 | 64 | # which is elaborated to 65 | 66 | let message = λsubstitution: string. 67 | def.begin 68 | ▷ def.text "Hello, " 69 | ▷ def.string (substitution) 70 | ▷ def.text "!" 71 | ▷ def.finish 72 | 73 | # and all features can, of course, be used in a single template 74 | 75 | let expression = λcondition: string.λaction: string. 76 | def"if (\(condition)) { 77 | \ \(action)() 78 | \}" 79 | 80 | # Specifiers or tags beyond the standard `\string(` can also be provided as long 81 | # as they don't collide with the standard JSON escape sequences `\b`, `\f`, 82 | # `\n`, `\r`, and `\t` as they are interpreted eagerly to remain compatible with 83 | # JSON strings. For example, one could create a semantics with specifiers for 84 | # integers and booleans as 85 | 86 | let Int = import "lib/int" and Bool = import "lib/bool" 87 | 88 | let fmt = def „ { 89 | D = λvalue: int.λaccum: string.accum ^ Int.to_string value 90 | B = λvalue: bool.λaccum: string.accum ^ Bool.to_string value 91 | } 92 | 93 | let meaning = fmt"The \B(true) meaning of life is \D(42)." 94 | 95 | # A specifier can be passed multiple arguments by using a record or tuple. 96 | 97 | let fmt = fmt „ { 98 | I = λ{base: int, value: int}.λaccum: string. 99 | accum ^ target«int → int → string» "b => v => v.toString(b)" base value 100 | } 101 | 102 | let meaning = fmt"The \B(true) meaning of life is \I{base = 2, value = 42}." 103 | 104 | # A semantics can, of course, build more than just strings as output. For 105 | # example, to build prepared SQL statements, one could write a semantics that 106 | # inserts placeholders to the SQL statement and collects the arguments as a 107 | # separate list: 108 | 109 | let «_, sql» = 110 | type sql = string 111 | type arg = string 112 | type args = list arg 113 | type rev = args → args → args 114 | type state = {sql, args, rev} 115 | let rev0 = λys: args.λ_: args.ys 116 | let rev1 = λrev: rev.λys: args.case { 117 | Nil = λ().ys 118 | Cons = λ(arg: arg, args: args).rev 'Cons(arg, ys) args 119 | } 120 | «{sql, args, rev}, { 121 | begin = {sql = "", args = 'Nil, rev = rev0} 122 | finish = λ{sql, args, rev}. 123 | {sql, args = rev 'Nil args} 124 | string = λarg.λ{sql, args, rev}. 125 | {sql = sql ^ "?", args = 'Cons (arg, args), rev = rev1 rev} 126 | text = λtext.λ{sql, args, rev}. 127 | {sql = sql ^ text, args, rev = rev1 rev} 128 | }»: ∃state.{ 129 | begin: state 130 | finish: state → {sql, args} 131 | string: string → state → state 132 | text: string → state → state 133 | } 134 | 135 | let feature = "template strings" 136 | let status = "experimental" 137 | 138 | # Thanks to the non-recursive implementation, `sql` templates can be completely 139 | # constant folded by the Fωμ toy compiler: 140 | 141 | sql"INSERT INTO language \ 142 | \VALUES (\(feature), \(status))" 143 | -------------------------------------------------------------------------------- /examples/template-strings.fomi: -------------------------------------------------------------------------------- 1 | {sql: string, args: (μlist:* → *.λα.'Nil | 'Cons (α, list α)) string} 2 | -------------------------------------------------------------------------------- /examples/template-strings.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐥINSERT_INTO_language_VALUES_ = 'INSERT INTO language VALUES (?, ?)' 3 | const ᐥtemplate_stringsᐥ = 'template strings' 4 | const ᐥexperimentalᐥ = 'experimental' 5 | const ᐟNil = ['Nil'] 6 | const 𛰙ᐥexperimentalᐥꓹ_ᐟNil𛰚 = {1: ᐥexperimentalᐥ, 2: ᐟNil} 7 | const ᐟCons𛰙ᐥexperimentalᐥꓹ_ᐟNil𛰚 = ['Cons', 𛰙ᐥexperimentalᐥꓹ_ᐟNil𛰚] 8 | const 𛰙ᐥtemplate_stringsᐥꓹ_ᐟCons𛰙ᐥexperimentalᐥꓹ_ = { 9 | 1: ᐥtemplate_stringsᐥ, 10 | 2: ᐟCons𛰙ᐥexperimentalᐥꓹ_ᐟNil𛰚, 11 | } 12 | const ᐟCons𛰙ᐥtemplate_stringsᐥꓹ_ = [ 13 | 'Cons', 14 | 𛰙ᐥtemplate_stringsᐥꓹ_ᐟCons𛰙ᐥexperimentalᐥꓹ_, 15 | ] 16 | ;({sql: ᐥINSERT_INTO_language_VALUES_, args: ᐟCons𛰙ᐥtemplate_stringsᐥꓹ_}) 17 | -------------------------------------------------------------------------------- /examples/template-strings.out: -------------------------------------------------------------------------------- 1 | {sql = "INSERT INTO language VALUES (?, ?)", args = ["template strings", "experimental"]} 2 | -------------------------------------------------------------------------------- /examples/type-gadt-using-eq-witnesses.fom: -------------------------------------------------------------------------------- 1 | # GADT type encoding using type equality witnesses 2 | 3 | include "lib/types" 4 | 5 | let «eq, Eq» = import "lib/eq" 6 | 7 | type μType = λτ. 8 | | 'Bool (Bool τ) 9 | | 'Int (Int τ) 10 | | 'String (String τ) 11 | | 'Alt ∃α.∃β.Alt τ α β 12 | | 'Pair ∃α.∃β.Pair τ α β 13 | | 'Iso ∃α.∃β.Iso τ α β 14 | and μBool = λτ.eq bool τ 15 | and μInt = λτ.eq int τ 16 | and μString = λτ.eq string τ 17 | and μAlt = λτ.λα.λβ.(eq (alt α β) τ, Type α, Type β) 18 | and μPair = λτ.λα.λβ.(eq (α, β) τ, Type α, Type β) 19 | and μIso = λτ.λα.λβ.(eq α τ, iso α β, Type β) 20 | 21 | let bool: Type bool = 'Bool Eq.refl«bool» 22 | let int: Type int = 'Int Eq.refl«int» 23 | let string: Type string = 'String Eq.refl«string» 24 | let alt: ∀α.∀β.Type α → Type β → Type (alt α β) = Λα.Λβ.λta.λtb. 25 | 'Alt «α, «β, (Eq.refl«alt α β», ta, tb)»» 26 | let pair: ∀α.∀β.Type α → Type β → Type (α, β) = Λα.Λβ.λta.λtb. 27 | 'Pair «α, «β, (Eq.refl«(α, β)», ta, tb)»» 28 | let iso: ∀α.∀β.iso α β → Type β → Type α = Λα.Λβ.λaIb.λtb. 29 | 'Iso «α, «β, (Eq.refl«α», aIb, tb)»» 30 | 31 | let String = import "lib/string" 32 | and Int = import "lib/int" 33 | and Bool = import "lib/bool" 34 | 35 | let μto_string: ∀τ.Type τ → τ → string = Λτ.case { 36 | Bool = λeq.λx. 37 | Bool.to_string ◁ Eq.from«bool»«τ» eq x 38 | Int = λeq.λx. 39 | Int.to_string ◁ Eq.from«int»«τ» eq x 40 | String = λeq.λx. 41 | String.to_literal ◁ Eq.from«string»«τ» eq x 42 | Alt = λ«α, «β, (eq, ta, tb)»». 43 | let to_string_a = to_string«α» ta 44 | let to_string_b = to_string«β» tb 45 | λt.Eq.from«alt α β»«τ» eq t ▷ case { 46 | In1 = λa."'In1(\(to_string_a a))" 47 | In2 = λb."'In2(\(to_string_b b))" 48 | } 49 | Pair = λ«α, «β, (eq, ta, tb)»». 50 | let to_string_a = to_string«α» ta 51 | let to_string_b = to_string«β» tb 52 | λt. 53 | let (a, b) = Eq.from«(α, β)»«τ» eq t 54 | "(\(to_string_a a), \(to_string_b b))" 55 | Iso = λ«α, «β, (eq, (a2b, _), tb)»». 56 | let to_string_b = to_string«β» tb 57 | λt.to_string_b ◁ a2b ◁ Eq.from«α»«τ» eq t 58 | } 59 | 60 | to_string«(bool, alt string int)» 61 | (pair«bool»«alt string int» bool (alt«string»«int» string int)) 62 | (false, 'In1 "foo") 63 | -------------------------------------------------------------------------------- /examples/type-gadt-using-eq-witnesses.fomi: -------------------------------------------------------------------------------- 1 | string 2 | -------------------------------------------------------------------------------- /examples/type-gadt-using-eq-witnesses.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const 𝛌xꓸx = x => x 3 | const ᐟBool𛰙𝛌xꓸx𛰚 = ['Bool', 𝛌xꓸx] 4 | const ᐟString𛰙𝛌xꓸx𛰚 = ['String', 𝛌xꓸx] 5 | const ᐟInt𛰙𝛌xꓸx𛰚 = ['Int', 𝛌xꓸx] 6 | const 𛰙𝛌xꓸxꓹ_ᐟString𛰙𝛌xꓸx𛰚ꓹ_ᐟInt𛰙𝛌xꓸx𛰚𛰚 = { 7 | 1: 𝛌xꓸx, 8 | 2: ᐟString𛰙𝛌xꓸx𛰚, 9 | 3: ᐟInt𛰙𝛌xꓸx𛰚, 10 | } 11 | const ᐟAlt𛰙𝛌xꓸxꓹ_ᐟString𛰙𝛌xꓸx𛰚ꓹ_ = ['Alt', 𛰙𝛌xꓸxꓹ_ᐟString𛰙𝛌xꓸx𛰚ꓹ_ᐟInt𛰙𝛌xꓸx𛰚𛰚] 12 | const 𛰙𝛌xꓸxꓹ_ᐟBool𛰙𝛌xꓸx𛰚ꓹ_ᐟAlt𛰙𝛌xꓸxꓹ_ = { 13 | 1: 𝛌xꓸx, 14 | 2: ᐟBool𛰙𝛌xꓸx𛰚, 15 | 3: ᐟAlt𛰙𝛌xꓸxꓹ_ᐟString𛰙𝛌xꓸx𛰚ꓹ_, 16 | } 17 | const ᐟPair𛰙𝛌xꓸxꓹ_ᐟBool𛰙𝛌xꓸx𛰚ꓹ_ = ['Pair', 𛰙𝛌xꓸxꓹ_ᐟBool𛰙𝛌xꓸx𛰚ꓹ_ᐟAlt𛰙𝛌xꓸxꓹ_] 18 | const ᐥfooᐥ = 'foo' 19 | const ᐟIn1𛰙ᐥfooᐥ𛰚 = ['In1', ᐥfooᐥ] 20 | const 𛰙falseꓹ_ᐟIn1𛰙ᐥfooᐥ𛰚𛰚 = {1: false, 2: ᐟIn1𛰙ᐥfooᐥ𛰚} 21 | const target_ꓯαꓸα_𐙤_string_ᐥx_ꘌᐳ_ = x => '' + x 22 | const target_string_𐙤_string_ᐥJSONꓸstringifyᐥ = JSON.stringify 23 | const ᐥᐟIn1𛰙ᐥ = "'In1(" 24 | const ᐥ𛰚ᐥ = ')' 25 | const ᐥᐟIn2𛰙ᐥ = "'In2(" 26 | const ᐥ𛰙ᐥ = '(' 27 | const ᐥꓹ_ᐥ = ', ' 28 | const _to_string = ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_ => { 29 | const [tag_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_, val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_] = 30 | ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_ 31 | switch (tag_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_) { 32 | case 'String': { 33 | return x => 34 | target_string_𐙤_string_ᐥJSONꓸstringifyᐥ( 35 | val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_(𝛌xꓸx)(x) 36 | ) 37 | } 38 | case 'Pair': { 39 | const to_string_a = _to_string(val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[2]) 40 | const to_string_b = _to_string(val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[3]) 41 | return t => { 42 | const _𛰙aꓹ_b𛰚 = val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[1](𝛌xꓸx)(t) 43 | const s = to_string_b(_𛰙aꓹ_b𛰚[2]) 44 | return ᐥ𛰙ᐥ + to_string_a(_𛰙aꓹ_b𛰚[1]) + ᐥꓹ_ᐥ + s + ᐥ𛰚ᐥ 45 | } 46 | } 47 | case 'Iso': { 48 | const to_string_b = _to_string(val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[3]) 49 | return t => 50 | to_string_b( 51 | val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[2][1]( 52 | val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[1](𝛌xꓸx)(t) 53 | ) 54 | ) 55 | } 56 | case 'Alt': { 57 | const to_string_a = _to_string(val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[2]) 58 | const to_string_b = _to_string(val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[3]) 59 | return t => { 60 | const [ 61 | tag_𛰙𛰙val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_, 62 | val_𛰙𛰙val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_, 63 | ] = val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_[1](𝛌xꓸx)(t) 64 | if (tag_𛰙𛰙val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ === 'In2') { 65 | return ᐥᐟIn2𛰙ᐥ + to_string_b(val_𛰙𛰙val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_) + ᐥ𛰚ᐥ 66 | } else { 67 | return ᐥᐟIn1𛰙ᐥ + to_string_a(val_𛰙𛰙val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_) + ᐥ𛰚ᐥ 68 | } 69 | } 70 | } 71 | default: { 72 | return x => 73 | target_ꓯαꓸα_𐙤_string_ᐥx_ꘌᐳ_(val_ᐟBool_ǀ_ᐟInt_ǀ_ᐟString_ǀ_(𝛌xꓸx)(x)) 74 | } 75 | } 76 | } 77 | _to_string(ᐟPair𛰙𝛌xꓸxꓹ_ᐟBool𛰙𝛌xꓸx𛰚ꓹ_)(𛰙falseꓹ_ᐟIn1𛰙ᐥfooᐥ𛰚𛰚) 78 | -------------------------------------------------------------------------------- /examples/type-gadt-using-eq-witnesses.out: -------------------------------------------------------------------------------- 1 | "(false, 'In1(\"foo\"))" 2 | -------------------------------------------------------------------------------- /examples/type-indexed-trie.fom: -------------------------------------------------------------------------------- 1 | # Type-indexed trie 2 | 3 | include "lib/types" 4 | 5 | type μTrie = λκ.λν.∀ρ.Cases ρ → ρ κ ν 6 | 7 | and μCases = λρ.{ 8 | Unit: ∀ν. opt ν → ρ () ν 9 | Alt: ∀ν.∀κ1.∀κ2.Trie κ1 ν → Trie κ2 ν → ρ (alt κ1 κ2) ν 10 | Pair: ∀ν.∀κ1.∀κ2. Trie κ1 (Trie κ2 ν) → ρ (κ1, κ2) ν 11 | } 12 | 13 | let {Unit, Alt, Pair}: Cases Trie = { 14 | Unit = Λν.λv.λcs.cs.Unit«ν» v 15 | Alt = Λν.Λκ1.Λκ2.λt1.λt2.λcs.cs.Alt«ν»«κ1»«κ2» t1 t2 16 | Pair = Λν.Λκ1.Λκ2.λt.λcs.cs.Pair«ν»«κ1»«κ2» t 17 | } 18 | 19 | let match = Λρ.λcs: Cases ρ.Λκ.Λν.λt: Trie κ ν.t«ρ» cs 20 | 21 | let μlookup: ∀κ.∀ν.Trie κ ν → κ → opt ν = match«λκ.λν.κ → opt ν» { 22 | Unit = λv.λ().v 23 | Alt = Λν.Λκ1.Λκ2.λt1.λt2.case { 24 | In1 = λk1.lookup«κ1»«ν» t1 k1 25 | In2 = λk2.lookup«κ2»«ν» t2 k2 26 | } 27 | Pair = Λν.Λκ1.Λκ2.λt.λ(k1, k2). 28 | lookup«κ1»«Trie κ2 ν» t k1 ▷ case { 29 | None = λ().'None 30 | Some = λt.lookup«κ2»«ν» t k2 31 | } 32 | } 33 | 34 | let aTrie = Alt«int»«()»«()» Unit«int»('Some 101) Unit«int»('Some 42) 35 | 36 | lookup«alt () ()»«int» aTrie 'In2 37 | -------------------------------------------------------------------------------- /examples/type-indexed-trie.fomi: -------------------------------------------------------------------------------- 1 | 'None | 'Some int 2 | -------------------------------------------------------------------------------- /examples/type-indexed-trie.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const ᐟSome𛰙101𛰚 = ['Some', 101] 3 | const 𝛌csꓸcsꓸUnit_ᐟSome𛰙101𛰚 = cs => cs.Unit(ᐟSome𛰙101𛰚) 4 | const ᐟSome𛰙42𛰚 = ['Some', 42] 5 | const 𝛌csꓸcsꓸUnit_ᐟSome𛰙42𛰚 = cs => cs.Unit(ᐟSome𛰙42𛰚) 6 | const 𝛌csꓸ𛰙csꓸAlt_𛰙𝛌csꓸcsꓸUnit_ = cs => 7 | cs.Alt(𝛌csꓸcsꓸUnit_ᐟSome𛰙101𛰚)(𝛌csꓸcsꓸUnit_ᐟSome𛰙42𛰚) 8 | const ᐟIn2 = ['In2'] 9 | const 𝛌vꓸλ_𛰙𛰚ꓸv = v => _𛰙𛰚 => v 10 | const ᐟNone = ['None'] 11 | const _lookup = t => 12 | t({ 13 | Unit: 𝛌vꓸλ_𛰙𛰚ꓸv, 14 | Alt: t1 => t2 => ᐟIn1_ǀ_ᐟIn2 => { 15 | const [tag_ᐟIn1_ǀ_ᐟIn2, val_ᐟIn1_ǀ_ᐟIn2] = ᐟIn1_ǀ_ᐟIn2 16 | if (tag_ᐟIn1_ǀ_ᐟIn2 === 'In2') { 17 | return _lookup(t2)(val_ᐟIn1_ǀ_ᐟIn2) 18 | } else { 19 | return _lookup(t1)(val_ᐟIn1_ǀ_ᐟIn2) 20 | } 21 | }, 22 | Pair: t$1 => _𛰙k1ꓹ_k2𛰚 => { 23 | const [tag_𛰙𛰙_lookup𛰚_t𛰚_𛰙_𛰙k1ꓹ_k2𛰚𛰚ꓸ1, val_𛰙𛰙_lookup𛰚_t𛰚_𛰙_𛰙k1ꓹ_k2𛰚𛰚ꓸ1] = 24 | _lookup(t$1)(_𛰙k1ꓹ_k2𛰚[1]) 25 | if (tag_𛰙𛰙_lookup𛰚_t𛰚_𛰙_𛰙k1ꓹ_k2𛰚𛰚ꓸ1 === 'Some') { 26 | return _lookup(val_𛰙𛰙_lookup𛰚_t𛰚_𛰙_𛰙k1ꓹ_k2𛰚𛰚ꓸ1)(_𛰙k1ꓹ_k2𛰚[2]) 27 | } else { 28 | return ᐟNone 29 | } 30 | }, 31 | }) 32 | _lookup(𝛌csꓸ𛰙csꓸAlt_𛰙𝛌csꓸcsꓸUnit_)(ᐟIn2) 33 | -------------------------------------------------------------------------------- /examples/type-indexed-trie.out: -------------------------------------------------------------------------------- 1 | 'Some 42 2 | -------------------------------------------------------------------------------- /examples/type-level-programming.fom: -------------------------------------------------------------------------------- 1 | # Type level programming in Fωμ 2 | 3 | # Fωμ does not have kind polymorphism. However, in this variant of Fωμ there is 4 | # kind inference and type definitions are roughly treated as templates to be 5 | # instantiated at every use. This combination gives a kind of ML-style or 6 | # Let-polymorphism at the kind level. 7 | 8 | # Pairs 9 | 10 | type Pair = λl.λr.λf.f l r 11 | 12 | type Fst = λp.p λl.λ_.l 13 | type Snd = λp.p λ_.λr.r 14 | 15 | type Cross = λf.λg.λp. 16 | type l = f (Fst p) 17 | type r = g (Snd p) 18 | Pair l r 19 | 20 | # Booleans 21 | 22 | type T = λt.λ_.t 23 | type F = λ_.λf.f 24 | 25 | type Not = λb.λt.λf.b f t 26 | 27 | type And = λl.λr.λt.λf.l (r t f) f 28 | type Or = λl.λr.λt.λf.l t (r t f) 29 | 30 | # Natural numbers 31 | 32 | type Succ = λn.λs.λz.s (n s z) 33 | 34 | type 𝟘 = λ_.λz.z 35 | type 𝟙 = Succ 𝟘 36 | type 𝟚 = Succ 𝟙 37 | type 𝟛 = Succ 𝟚 38 | 39 | # Lists 40 | 41 | type Nil = λn.λ_.n 42 | type Cons = λh.λt.λn.λc.c h (t n c) 43 | 44 | type Map = λf.λxs.λn.λc.xs n λx.c (f x) 45 | 46 | # 47 | 48 | λ_: Map λt.(t, t) 49 | (Cons int (Cons string (Cons bool Nil))) 50 | () 51 | λh.λt.(h, t).() 52 | -------------------------------------------------------------------------------- /examples/type-level-programming.fomi: -------------------------------------------------------------------------------- 1 | ((int, int), ((string, string), ((bool, bool), ()))) → () 2 | -------------------------------------------------------------------------------- /examples/type-level-programming.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | _ => {} 3 | -------------------------------------------------------------------------------- /examples/type-level-programming.out: -------------------------------------------------------------------------------- 1 | λ_ 2 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "f-omega-mu" 3 | version: "0.0" 4 | synopsis: "Fωμ type checker and compiler" 5 | maintainer: "Vesa Karvonen " 6 | authors: "Vesa Karvonen" 7 | license: "MIT" 8 | homepage: "https://github.com/polytypic/f-omega-mu" 9 | bug-reports: "https://github.com/polytypic/f-omega-mu/issues" 10 | dev-repo: "git+https://github.com/polytypic/f-omega-mu.git" 11 | depends: [ 12 | "bignum" 13 | "cohttp-lwt-jsoo" 14 | "cohttp-lwt-unix" 15 | "dune" 16 | "lwt_ssl" 17 | "menhir" 18 | "ocaml" 19 | "pprint" 20 | "rea" 21 | "sedlex" 22 | "stdlibplus" 23 | ] 24 | -------------------------------------------------------------------------------- /regression/123.fom: -------------------------------------------------------------------------------- 1 | let warn = λs: string.target«string → impure ()» "_ => {}" s ▷ keep«()» 2 | 3 | warn "1" 4 | let fn = λ{b: bool}. 5 | let b = 6 | warn "3" 7 | b 8 | if b then 9 | warn "4" 10 | else 11 | warn "5" 12 | warn "6" 13 | fn { 14 | b = warn "2" 15 | true 16 | } 17 | warn "7" 18 | warn "8" 19 | fn 20 | -------------------------------------------------------------------------------- /regression/123.fomi: -------------------------------------------------------------------------------- 1 | {b: bool} → () 2 | -------------------------------------------------------------------------------- /regression/123.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const target_string_𐙤_impure_𛰙𛰚_ = _ => {} 3 | const ᐥ6ᐥ = '6' 4 | const ᐥ4ᐥ = '4' 5 | const ᐥ5ᐥ = '5' 6 | const ᐥ3ᐥ = '3' 7 | const 𝛌_𛰝b_ꘌ_b𛰞ꓸ𛰙λ_Seqꓸ𛰙λ_Seqꓸkeep𖩇α𖩉𛰙𛰙target_ = _𛰝b_ꘌ_b𛰞 => { 8 | target_string_𐙤_impure_𛰙𛰚_(ᐥ3ᐥ) 9 | if (_𛰝b_ꘌ_b𛰞.b) { 10 | target_string_𐙤_impure_𛰙𛰚_(ᐥ4ᐥ) 11 | } else { 12 | target_string_𐙤_impure_𛰙𛰚_(ᐥ5ᐥ) 13 | } 14 | return target_string_𐙤_impure_𛰙𛰚_(ᐥ6ᐥ) 15 | } 16 | const ᐥ8ᐥ = '8' 17 | const ᐥ7ᐥ = '7' 18 | const ᐥ2ᐥ = '2' 19 | const ᐥ1ᐥ = '1' 20 | target_string_𐙤_impure_𛰙𛰚_(ᐥ1ᐥ) 21 | target_string_𐙤_impure_𛰙𛰚_(ᐥ2ᐥ) 22 | target_string_𐙤_impure_𛰙𛰚_(ᐥ3ᐥ) 23 | target_string_𐙤_impure_𛰙𛰚_(ᐥ4ᐥ) 24 | target_string_𐙤_impure_𛰙𛰚_(ᐥ6ᐥ) 25 | target_string_𐙤_impure_𛰙𛰚_(ᐥ7ᐥ) 26 | target_string_𐙤_impure_𛰙𛰚_(ᐥ8ᐥ) 27 | 𝛌_𛰝b_ꘌ_b𛰞ꓸ𛰙λ_Seqꓸ𛰙λ_Seqꓸkeep𖩇α𖩉𛰙𛰙target_ 28 | -------------------------------------------------------------------------------- /regression/123.out: -------------------------------------------------------------------------------- 1 | λ𝛌_𛰝b_ꘌ_b𛰞ꓸ𛰙λ_Seqꓸ𛰙λ_Seqꓸkeep𖩇α𖩉𛰙𛰙target_ 2 | -------------------------------------------------------------------------------- /regression/let-hoisting.fom: -------------------------------------------------------------------------------- 1 | let {log} = import "../examples/lib/console" 2 | 3 | let f = λb: bool. 4 | if (log "1"; b) ∨ (log "2"; b) then 5 | (log "3"; 1) + (log "4"; 2) 6 | else 7 | -(log "5"; 3) 8 | 9 | λb: bool. 10 | f (log "6"; b) 11 | -------------------------------------------------------------------------------- /regression/let-hoisting.fomi: -------------------------------------------------------------------------------- 1 | bool → int 2 | -------------------------------------------------------------------------------- /regression/let-hoisting.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | const target_string_𐙤_impure_𛰙𛰚_ = console.log 3 | const ᐥ2ᐥ = '2' 4 | const ᐥ4ᐥ = '4' 5 | const ᐥ3ᐥ = '3' 6 | const ᐥ5ᐥ = '5' 7 | const ᐥ1ᐥ = '1' 8 | const ᐥ6ᐥ = '6' 9 | b => { 10 | target_string_𐙤_impure_𛰙𛰚_(ᐥ6ᐥ) 11 | target_string_𐙤_impure_𛰙𛰚_(ᐥ1ᐥ) 12 | if (b || (_Seq$2 => b)(target_string_𐙤_impure_𛰙𛰚_(ᐥ2ᐥ))) { 13 | target_string_𐙤_impure_𛰙𛰚_(ᐥ3ᐥ) 14 | target_string_𐙤_impure_𛰙𛰚_(ᐥ4ᐥ) 15 | return 3 16 | } else { 17 | target_string_𐙤_impure_𛰙𛰚_(ᐥ5ᐥ) 18 | return -3 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /regression/let-hoisting.out: -------------------------------------------------------------------------------- 1 | λ_ 2 | -------------------------------------------------------------------------------- /src/main/FomAST/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomAST) 3 | (libraries FomSource stdlibplus bignum)) 4 | -------------------------------------------------------------------------------- /src/main/FomAnnot/FomAnnot.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomSource 4 | open FomAST 5 | 6 | (* *) 7 | 8 | module Annot = struct 9 | module LocSet = Set.Make (Loc) 10 | module LocMap = Map.Make (Loc) 11 | 12 | type map = 13 | < annot : 14 | [ `Label of Label.t * Typ.Core.t 15 | | `ExpId of Exp.Var.t * Typ.Core.t 16 | | `TypId of Typ.Var.t * Kind.t ] 17 | ; def : Loc.t 18 | ; uses : LocSet.t > 19 | LocMap.t 20 | 21 | type t = map Mut.t 22 | type m = t Prop.t 23 | 24 | let field r : m = r#annot 25 | let empty () = Mut.create LocMap.empty 26 | let scoping op = setting field (empty ()) op 27 | 28 | class con annot = 29 | object 30 | val mutable annot = annot 31 | method annot : m = prop (fun () -> annot) (fun x -> annot <- x) 32 | end 33 | 34 | let make def uses annot = 35 | object 36 | method def = def 37 | method uses = uses 38 | method annot = annot 39 | end 40 | 41 | let merge lhs rhs = 42 | LocMap.merge 43 | ( Map.combining_with @@ fun lhs rhs -> 44 | make lhs#def (LocSet.union lhs#uses rhs#uses) lhs#annot ) 45 | lhs rhs 46 | 47 | let add_def at annot = 48 | do_unless (Loc.is_empty at) 49 | (mutate field @@ LocMap.update at 50 | @@ function None -> Some (make at LocSet.empty annot) | some -> some) 51 | 52 | let add_use use def = 53 | do_unless (Loc.is_empty use) 54 | (mutate field @@ LocMap.update def @@ Option.map 55 | @@ fun o -> make o#def (LocSet.add use o#uses) o#annot) 56 | 57 | module Label = struct 58 | open Label 59 | 60 | let def id typ = 61 | if is_fresh id || is_numeric id then unit 62 | else add_def (at id) @@ `Label (id, typ) 63 | 64 | let use id def = 65 | if is_fresh id || is_numeric id then unit else add_use (at id) def 66 | end 67 | 68 | module Exp = struct 69 | open Exp.Var 70 | 71 | let def id typ = 72 | if is_fresh id || is_numeric id then unit 73 | else add_def (at id) @@ `ExpId (id, typ) 74 | 75 | let use id def = 76 | if is_fresh id || is_numeric id then unit else add_use (at id) def 77 | end 78 | 79 | module Typ = struct 80 | open Typ.Var 81 | 82 | let resolve resolve_kind = 83 | try_mutate field 84 | (LocMap.bindings 85 | >>> List.map_er (fun (at, v) -> 86 | match v#annot with 87 | | `TypId (id, kind) -> 88 | let+ kind = resolve_kind kind in 89 | (at, make v#def v#uses @@ `TypId (id, kind)) 90 | | _ -> pure (at, v)) 91 | >-> LocMap.of_list) 92 | 93 | let def id kind = add_def (at id) @@ `TypId (id, kind) 94 | let use id = add_use @@ at id 95 | end 96 | end 97 | -------------------------------------------------------------------------------- /src/main/FomAnnot/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomAnnot) 3 | (libraries FomAST)) 4 | -------------------------------------------------------------------------------- /src/main/FomCST/FomCST.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomPPrint 4 | open FomAST 5 | open FomSource 6 | 7 | (* *) 8 | 9 | module Kind = Kind 10 | module Label = Label 11 | module Row = Row 12 | module Tuple = Tuple 13 | 14 | module Aggr = struct 15 | let cons = "Cons" 16 | let nil = "Nil" 17 | end 18 | 19 | module Typ = struct 20 | include Typ 21 | 22 | module Def = struct 23 | type 't f = 24 | [ `TypPar of (Var.t * Kind.t * 't) list 25 | | `TypRec of (Var.t * Kind.t * 't) list 26 | | `Include of Loc.t * JsonString.t ] 27 | end 28 | 29 | type 't f = 30 | [ ('t, Kind.t) Typ.f 31 | | `Let of Loc.t * 't Def.f * 't 32 | | `Annot of Loc.t * 't * Kind.t 33 | | `Import of Loc.t * JsonString.t ] 34 | 35 | type t = t f 36 | 37 | let at = function 38 | | `Let (at, _, _) | `Annot (at, _, _) | `Import (at, _) -> at 39 | | #Typ.f as ast -> Typ.at ast 40 | 41 | module Defs = struct 42 | type 't f = 43 | [ 't Def.f 44 | | `In of Loc.t * 't Def.f * 't f 45 | | `LocalIn of Loc.t * 't Def.f * 't f ] 46 | end 47 | 48 | let aggr at' xs tl = 49 | List.fold_right 50 | (fun x ys -> sum at' [(Label.of_string at' Aggr.cons, tuple at' [x; ys])]) 51 | xs 52 | (match tl with 53 | | Some typ -> typ 54 | | None -> atom (Label.of_string at' Aggr.nil)) 55 | end 56 | 57 | module Exp = struct 58 | include Exp 59 | 60 | module Pat = struct 61 | type t = 62 | [ `Var of Loc.t * Var.t 63 | | `Const of Loc.t * [`Unit] 64 | | `Annot of Loc.t * t * Typ.t 65 | | `Product of Loc.t * t Row.t 66 | | `Pack of Loc.t * t * Typ.Var.t * Kind.t ] 67 | 68 | let check p = 69 | eta'0 @@ fun () -> 70 | let rec collect (ts, is) = function 71 | | `Var (_, i) -> (ts, i :: is) 72 | | `Const (_, `Unit) -> (ts, is) 73 | | `Annot (_, p, _) -> collect (ts, is) p 74 | | `Product (_, ps) -> 75 | ps 76 | |> List.fold_left (fun (ts, is) (_, p) -> collect (ts, is) p) (ts, is) 77 | | `Pack (_, p, t, _) -> collect (t :: ts, is) p 78 | in 79 | let ts, is = collect ([], []) p in 80 | let check_ts = 81 | ts 82 | |> List.find_dup_opt Typ.Var.compare 83 | |> Option.iter_er @@ fun (i2, i1) -> 84 | fail @@ `Error_duplicated_typ_bind (Typ.Var.at i2, i1) 85 | in 86 | let check_is = 87 | is 88 | |> List.find_dup_opt Var.compare 89 | |> Option.iter_er @@ fun (i2, i1) -> 90 | fail @@ `Error_duplicated_bind (Var.at i2, i1) 91 | in 92 | check_ts >> check_is 93 | 94 | let rec pp = function 95 | | `Var (_, i) -> Var.pp i 96 | | `Const (_, `Unit) -> unit' 97 | | `Annot (_, p, _) -> pp p 98 | | `Product (_, ls) -> 99 | if Row.is_tuple ls then 100 | ls 101 | |> List.map (snd >>> pp) 102 | |> separate comma_break_1 |> egyptian parens 2 103 | else 104 | ls 105 | |> List.map (function 106 | | l, `Var (_, i) when Label.equal l (Var.to_label i) -> 107 | Label.pp l 108 | | l, p -> Label.pp l ^^ space_equals_space ^^ pp p) 109 | |> separate comma_break_1 |> egyptian braces 2 110 | | `Pack (_, p, _, _) -> pp p 111 | 112 | let to_string p = p |> pp |> to_string 113 | 114 | let at = function 115 | | `Var (at, _) 116 | | `Const (at, _) 117 | | `Annot (at, _, _) 118 | | `Product (at, _) 119 | | `Pack (at, _, _, _) -> 120 | at 121 | 122 | let tuple at = function 123 | | [] -> `Const (at, `Unit) 124 | | [p] -> p 125 | | ps -> `Product (at, Tuple.labels at ps) 126 | end 127 | 128 | type 'e tstr_elem = [`Exp of Label.t * 'e | `Str of JsonString.t] 129 | 130 | module Def = struct 131 | type 'e f = 132 | [ Typ.t Typ.Def.f 133 | | `PatPar of (Pat.t * 'e) list 134 | | `PatRec of (Pat.t * 'e) list ] 135 | end 136 | 137 | type 'e f = 138 | [ ('e, Typ.t, Kind.t) Exp.f 139 | | `AppL of Loc.t * 'e * 'e 140 | | `AppR of Loc.t * 'e * 'e 141 | | `Let of Loc.t * 'e Def.f * 'e 142 | | `Seq of Loc.t * 'e * 'e 143 | | `Import of Loc.t * JsonString.t 144 | | `LamPat of Loc.t * Pat.t * 'e 145 | | `Tstr of Loc.t * Var.t * 'e tstr_elem list 146 | | `Annot of Loc.t * 'e * Typ.t ] 147 | 148 | type t = t f 149 | 150 | let at = function 151 | | `AppL (at, _, _) 152 | | `AppR (at, _, _) 153 | | `Let (at, _, _) 154 | | `Seq (at, _, _) 155 | | `Import (at, _) 156 | | `LamPat (at, _, _) 157 | | `Tstr (at, _, _) 158 | | `Annot (at, _, _) -> 159 | at 160 | | #Exp.f as ast -> Exp.at ast 161 | 162 | let aggr at' xs tl = 163 | List.fold_right 164 | (fun x ys -> 165 | `Inject (at', Label.of_string at' Aggr.cons, Exp.tuple at' [x; ys])) 166 | xs 167 | (match tl with 168 | | Some exp -> exp 169 | | None -> Exp.atom (Label.of_string at' Aggr.nil)) 170 | end 171 | 172 | module Annot = struct 173 | let opt at = Option.fold ~none:id ~some:(fun a x -> `Annot (at a, x, a)) 174 | end 175 | -------------------------------------------------------------------------------- /src/main/FomCST/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomCST) 3 | (libraries FomAST FomError)) 4 | -------------------------------------------------------------------------------- /src/main/FomChecker/FomChecker.ml: -------------------------------------------------------------------------------- 1 | module Exp = Exp 2 | module Kind = Kind 3 | module Row = Row 4 | module Typ = Typ 5 | -------------------------------------------------------------------------------- /src/main/FomChecker/Kind.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | 4 | (* *) 5 | include FomAST.Kind 6 | 7 | let rec resolve k = 8 | k 9 | |> keep_eq_er @@ function 10 | | `Star _ as k -> pure k 11 | | `Arrow (at', d, c) -> 12 | let+ d' = resolve d and+ c' = resolve c in 13 | `Arrow (at', d', c') 14 | | `Unk (_, v) as k -> ( 15 | UnkEnv.find_opt v >>= function 16 | | None -> pure k 17 | | Some k -> 18 | let* k' = resolve k in 19 | if k == k' then pure k else UnkEnv.add v k' >> pure k') 20 | 21 | let rec ground k = 22 | k 23 | |> keep_eq @@ function 24 | | `Star _ as k -> k 25 | | `Arrow (at', d, c) -> `Arrow (at', ground d, ground c) 26 | | `Unk (at', _) -> `Star at' 27 | 28 | let rec occurs_check at' v = 29 | eta'1 @@ function 30 | | `Star _ -> unit 31 | | `Arrow (_, d, c) -> occurs_check at' v d >> occurs_check at' v c 32 | | `Unk (_, v') -> 33 | if Unk.equal v v' then fail @@ `Error_cyclic_kind at' else unit 34 | 35 | let rec unify at' lhs rhs = 36 | eta'0 @@ fun () -> 37 | match (lhs, rhs) with 38 | | `Star _, `Star _ -> unit 39 | | `Arrow (_, ld, lc), `Arrow (_, rd, rc) -> 40 | unify at' ld rd >> (resolve lc <*> resolve rc >>= uncurry @@ unify at') 41 | | `Unk (_, l), `Unk (_, r) when Unk.equal l r -> unit 42 | | `Unk (_, v), t | t, `Unk (_, v) -> occurs_check at' v t >> UnkEnv.add v t 43 | | _ -> fail @@ `Error_kind_mismatch (at', lhs, rhs) 44 | 45 | let unify at' lhs rhs = resolve lhs <*> resolve rhs >>= uncurry @@ unify at' 46 | -------------------------------------------------------------------------------- /src/main/FomChecker/Label.ml: -------------------------------------------------------------------------------- 1 | include FomAST.Label 2 | -------------------------------------------------------------------------------- /src/main/FomChecker/LabelMap.ml: -------------------------------------------------------------------------------- 1 | include FomAST.LabelMap 2 | -------------------------------------------------------------------------------- /src/main/FomChecker/Row.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | include FomAST.Row 4 | 5 | let check fs = 6 | fs |> List.map fst |> List.find_dup_opt Label.compare |> function 7 | | None -> unit 8 | | Some (l1, l2) -> fail @@ `Error_duplicated_label (Label.at l2, l1) 9 | -------------------------------------------------------------------------------- /src/main/FomChecker/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomChecker) 3 | (libraries FomAST FomPP FomAnnot FomError stdlibplus)) 4 | -------------------------------------------------------------------------------- /src/main/FomCommand/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name FomCommand) 3 | (libraries FomEnv FomElab FomParser FomToJsC FomDiag cohttp-lwt-unix)) 4 | -------------------------------------------------------------------------------- /src/main/FomDiag/Diagnostic.mli: -------------------------------------------------------------------------------- 1 | open Rea 2 | open FomSource 3 | open FomPPrint 4 | open FomError 5 | open FomChecker 6 | 7 | type t = Loc.t * document 8 | 9 | val of_error : 10 | [< Error.t] -> 11 | ( 'R, 12 | 'e, 13 | t * t list, 14 | (< ('R, 'D) async' 15 | ; Kind.UnkEnv.con 16 | ; Typ.Goals.con 17 | ; Typ.Solved.con 18 | ; [> `Kind of Kind.t] Typ.VarEnv.con 19 | ; .. > 20 | as 21 | 'D) ) 22 | er 23 | 24 | val pp : t * t list -> document 25 | -------------------------------------------------------------------------------- /src/main/FomDiag/FomDiag.ml: -------------------------------------------------------------------------------- 1 | module Typ = Typ 2 | module Diagnostic = Diagnostic 3 | -------------------------------------------------------------------------------- /src/main/FomDiag/Typ.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomChecker 4 | 5 | (* *) 6 | 7 | include FomPP.Typ 8 | include FomChecker.Typ 9 | include FomChecker.Typ.Core 10 | 11 | (* Transforms to make types more legible - Not needed for type checking *) 12 | 13 | module TypSet = Set.Make (Core) 14 | 15 | let rec contract t = 16 | let* s, t = contract_base t in 17 | let* t_opt = s |> TypSet.to_seq |> Seq.find_opt_er (is_equal_of_norm t) in 18 | let s, u = 19 | match t_opt with 20 | | Some t -> (s, t) 21 | | None -> ( 22 | match unapp t with `Mu _, _ -> (TypSet.add t s, t) | _ -> (s, t)) 23 | in 24 | match t with 25 | | `Lam (_, i, _, _) -> TypSet.filter_er (is_free i >-> not) s <*> pure u 26 | | _ -> pure (s, u) 27 | 28 | and contract_base t = 29 | let+ s, t' = 30 | match t with 31 | | `Mu (at', e) -> contract e >>- fun (s, e') -> (s, `Mu (at', e')) 32 | | (`Const _ | `Var _) as t -> pure (TypSet.empty, t) 33 | | `Lam (at', x, k, e) -> 34 | contract e >>- fun (s, e') -> (s, `Lam (at', x, k, e')) 35 | | `App (at', f, x) -> 36 | let+ fs, f' = contract f and+ xs, x' = contract x in 37 | (TypSet.union fs xs, `App (at', f', x')) 38 | | `Arrow (at', d, c) -> 39 | let+ ds, d' = contract d and+ cs, c' = contract c in 40 | (TypSet.union ds cs, `Arrow (at', d', c')) 41 | | `For (at', q, e) -> contract e >>- fun (s, e') -> (s, `For (at', q, e')) 42 | | `Row (at', m, ls) -> 43 | contract_labels ls >>- fun (s, ls') -> (s, `Row (at', m, ls')) 44 | in 45 | (s, keep_eq' t t') 46 | 47 | and contract_labels ls = 48 | let+ sls' = ls |> Row.map_er contract in 49 | let ls' = 50 | sls' |> Row.map snd 51 | |> List.share_eq (Pair.share_eq (fun _ x -> x) (fun _ x -> x)) ls 52 | in 53 | let s = 54 | sls' 55 | |> List.fold_left (fun s (_, (s', _)) -> TypSet.union s s') TypSet.empty 56 | in 57 | (s, ls') 58 | 59 | let contract t = contract t >>- snd 60 | 61 | (* *) 62 | 63 | let rec collect_mus_closed bvs t mus = 64 | match t with 65 | | `Mu (_, `Lam (_, i, _, e)) as t -> 66 | let mus, e_vs = collect_mus_closed (VarSet.add i bvs) e mus in 67 | let e_vs = VarSet.remove i e_vs in 68 | let mus = if VarSet.disjoint bvs e_vs then TypSet.add t mus else mus in 69 | (mus, e_vs) 70 | | `Mu (_, e) -> collect_mus_closed bvs e mus 71 | | `Const _ -> (mus, VarSet.empty) 72 | | `Var (_, i) -> (mus, VarSet.singleton i) 73 | | `App (_, f, x) -> 74 | let mus, f_vs = collect_mus_closed bvs f mus in 75 | let mus, x_vs = collect_mus_closed bvs x mus in 76 | (mus, VarSet.union f_vs x_vs) 77 | | `Lam (_, i, _, e) -> 78 | let mus, vs = collect_mus_closed (VarSet.add i bvs) e mus in 79 | (mus, VarSet.remove i vs) 80 | | `For (_, _, e) -> collect_mus_closed bvs e mus 81 | | `Arrow (_, d, c) -> 82 | let mus, d_vs = collect_mus_closed bvs d mus in 83 | let mus, c_vs = collect_mus_closed bvs c mus in 84 | (mus, VarSet.union d_vs c_vs) 85 | | `Row (_, _, ls) -> 86 | ls 87 | |> List.fold_left 88 | (fun (mus, vs) (_, t) -> 89 | let mus, t_vs = collect_mus_closed bvs t mus in 90 | (mus, VarSet.union vs t_vs)) 91 | (mus, VarSet.empty) 92 | 93 | let rec replace_closed_mus m = 94 | keep_eq @@ function 95 | | `Mu (at'', `Lam (at', i, k, e)) as t -> 96 | if TypSet.mem t m then `Var (at', i) 97 | else `Mu (at'', `Lam (at', i, k, replace_closed_mus m e)) 98 | | t -> map_eq (replace_closed_mus m) t 99 | -------------------------------------------------------------------------------- /src/main/FomDiag/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomDiag) 3 | (libraries FomError FomChecker FomPP)) 4 | -------------------------------------------------------------------------------- /src/main/FomElab/FomElab.mli: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomSource 4 | open FomAnnot 5 | open FomError 6 | open FomChecker 7 | 8 | module Path : sig 9 | val inc_ext : string 10 | val sig_ext : string 11 | val mod_ext : string 12 | 13 | (* *) 14 | 15 | val ensure_ext : string -> string -> string 16 | 17 | (* *) 18 | 19 | val is_http : string -> bool 20 | val coalesce : Loc.t -> JsonString.t -> string 21 | end 22 | 23 | module Fetch : sig 24 | type e = [Error.file_doesnt_exist | Error.io_error] 25 | 26 | class ['R, 'D] con : 27 | object 28 | method fetch : 29 | 'E. 30 | Loc.t -> 31 | string -> 32 | ('R, ([> e] as 'E), string, (('R, 'D) #fail' as 'D)) er 33 | end 34 | end 35 | 36 | module Parameters : sig 37 | type m 38 | 39 | class con : 40 | object 41 | method parameters : m 42 | end 43 | end 44 | 45 | module TypIncludes : sig 46 | type 'R t 47 | 48 | val create : unit -> 'R t 49 | 50 | class ['R] con : 51 | 'R t 52 | -> object 53 | method typ_includes : 'R t 54 | end 55 | end 56 | 57 | module TypImports : sig 58 | type 'R t 59 | 60 | val create : unit -> 'R t 61 | 62 | class ['R] con : 63 | 'R t 64 | -> object 65 | method typ_imports : 'R t 66 | end 67 | end 68 | 69 | module ExpImports : sig 70 | type 'R t 71 | 72 | class ['R] con : 73 | 'R t 74 | -> object 75 | method exp_imports : 'R t 76 | end 77 | 78 | val create : unit -> 'R t 79 | 80 | val get : 81 | string -> 82 | ( 'R, 83 | [> Error.t], 84 | (Exp.Var.t * Exp.Core.t * Typ.Core.t * string list) * Annot.map, 85 | (< 'R con ; ('R, 'D) async' ; .. > as 'D) ) 86 | er 87 | end 88 | 89 | module ImportChain : sig 90 | type m 91 | 92 | class con : 93 | object 94 | method chain : m 95 | end 96 | end 97 | 98 | val elaborate_typ : 99 | FomCST.Typ.t -> 100 | ( 'R, 101 | [> Error.t], 102 | Typ.t, 103 | (< 'R TypImports.con 104 | ; 'R TypIncludes.con 105 | ; ('R, 'D) Fetch.con 106 | ; ('R, 'D) async' 107 | ; Annot.con 108 | ; ImportChain.con 109 | ; Kind.UnkEnv.con 110 | ; Parameters.con 111 | ; Typ.Goals.con 112 | ; Typ.Solved.con 113 | ; [`Kind of Kind.t | `Typ of Typ.t] Typ.VarEnv.con 114 | ; .. > 115 | as 116 | 'D) ) 117 | er 118 | 119 | val elaborate : 120 | FomCST.Exp.t -> 121 | ( 'R, 122 | [> Error.t], 123 | Exp.Core.t * Typ.Core.t * string list, 124 | (< 'R ExpImports.con 125 | ; 'R TypImports.con 126 | ; 'R TypIncludes.con 127 | ; ('R, 'D) Fetch.con 128 | ; ('R, 'D) async' 129 | ; Annot.con 130 | ; Exp.VarEnv.con 131 | ; ImportChain.con 132 | ; Kind.UnkEnv.con 133 | ; Parameters.con 134 | ; Typ.Goals.con 135 | ; Typ.Solved.con 136 | ; [`Kind of Kind.t | `Typ of Typ.t] Typ.VarEnv.con 137 | ; .. > 138 | as 139 | 'D) ) 140 | er 141 | -------------------------------------------------------------------------------- /src/main/FomElab/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomElab) 3 | (libraries FomCST FomChecker FomParser FomAnnot)) 4 | -------------------------------------------------------------------------------- /src/main/FomEnv/FomEnv.ml: -------------------------------------------------------------------------------- 1 | open FomAnnot 2 | open FomChecker 3 | open FomElab 4 | open FomToJsC 5 | 6 | module Env = struct 7 | class ['R, 'D, 't] empty ?(annot = Annot.empty ()) 8 | ?(exp_imports = ExpImports.create ()) ?(mod_in_js = ModInJs.create ()) 9 | ?(mod_simplified = ModSimplified.create ()) 10 | ?(typ_imports = TypImports.create ()) 11 | ?(typ_includes = TypIncludes.create ()) () = 12 | object 13 | inherit Annot.con annot 14 | inherit Exp.VarEnv.con 15 | inherit ['R] ExpImports.con exp_imports 16 | inherit ['R, 'D] Fetch.con 17 | inherit ImportChain.con 18 | inherit Kind.UnkEnv.con 19 | inherit ['R] ModInJs.con mod_in_js 20 | inherit ['R] ModSimplified.con mod_simplified 21 | inherit Parameters.con 22 | inherit Typ.Goals.con 23 | inherit Typ.Solved.con 24 | inherit ['t] Typ.VarEnv.con 25 | inherit ['R] TypImports.con typ_imports 26 | inherit ['R] TypIncludes.con typ_includes 27 | end 28 | end 29 | -------------------------------------------------------------------------------- /src/main/FomEnv/FomEnv.mli: -------------------------------------------------------------------------------- 1 | open FomAnnot 2 | open FomChecker 3 | open FomElab 4 | open FomToJsC 5 | 6 | module Env : sig 7 | class ['R, 'D, 't] empty : 8 | ?annot:Annot.t 9 | -> ?exp_imports:'R ExpImports.t 10 | -> ?mod_in_js:'R ModInJs.t 11 | -> ?mod_simplified:'R ModSimplified.t 12 | -> ?typ_imports:'R TypImports.t 13 | -> ?typ_includes:'R TypIncludes.t 14 | -> unit 15 | -> object 16 | inherit Annot.con 17 | inherit Exp.VarEnv.con 18 | inherit ['R] ExpImports.con 19 | inherit ['R, 'D] Fetch.con 20 | inherit ImportChain.con 21 | inherit Kind.UnkEnv.con 22 | inherit ['R] ModInJs.con 23 | inherit ['R] ModSimplified.con 24 | inherit Parameters.con 25 | inherit Typ.Goals.con 26 | inherit Typ.Solved.con 27 | inherit ['R] TypImports.con 28 | inherit ['R] TypIncludes.con 29 | inherit ['t] Typ.VarEnv.con 30 | end 31 | end 32 | -------------------------------------------------------------------------------- /src/main/FomEnv/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomEnv) 3 | (libraries FomToJsC FomElab FomChecker FomAnnot)) 4 | -------------------------------------------------------------------------------- /src/main/FomError/Error.ml: -------------------------------------------------------------------------------- 1 | open FomSource 2 | open FomAST 3 | 4 | (* IO errors *) 5 | 6 | type io_error = [`Error_io of Loc.t * exn] 7 | 8 | (* Syntax errors *) 9 | 10 | type lexeme = [`Error_lexeme of Loc.t * string] 11 | type grammar = [`Error_grammar of Loc.t * string] 12 | type duplicated_label = [`Error_duplicated_label of Loc.t * Label.t] 13 | type duplicated_typ_bind = [`Error_duplicated_typ_bind of Loc.t * Typ.Var.t] 14 | type duplicated_bind = [`Error_duplicated_bind of Loc.t * Exp.Var.t] 15 | 16 | type syntax_errors = 17 | [lexeme | grammar | duplicated_label | duplicated_typ_bind | duplicated_bind] 18 | 19 | (* Source errors *) 20 | 21 | type file_doesnt_exist = [`Error_file_doesnt_exist of Loc.t * string] 22 | type cyclic_includes = [`Error_cyclic_includes of Loc.t * string * Loc.t] 23 | type cyclic_imports = [`Error_cyclic_imports of Loc.t * string * Loc.t] 24 | type source_errors = [file_doesnt_exist | cyclic_includes | cyclic_imports] 25 | 26 | (* Kind errors *) 27 | 28 | type kind_mismatch = [`Error_kind_mismatch of Loc.t * Kind.t * Kind.t] 29 | type cyclic_kind = [`Error_cyclic_kind of Loc.t] 30 | type mu_nested = [`Error_mu_nested of Loc.t * Typ.t * Typ.t] 31 | type mu_non_contractive = [`Error_mu_non_contractive of Loc.t * Typ.t * Typ.t] 32 | type typ_var_unbound = [`Error_typ_var_unbound of Loc.t * Typ.Var.t] 33 | 34 | type kind_errors = 35 | [ kind_mismatch 36 | | cyclic_kind 37 | | mu_nested 38 | | mu_non_contractive 39 | | typ_var_unbound ] 40 | 41 | (* Type errors *) 42 | 43 | type var_unbound = [`Error_var_unbound of Loc.t * Exp.Var.t] 44 | type typ_mismatch = [`Error_typ_mismatch of Loc.t * Typ.t * Typ.t] 45 | type typ_unrelated = [`Error_typ_unrelated of Loc.t * Typ.t * Typ.t] 46 | type typ_unexpected = [`Error_typ_unexpected of Loc.t * string * Typ.Core.t] 47 | type product_lacks = [`Error_product_lacks of Loc.t * Typ.Core.t * Label.t] 48 | type sum_lacks = [`Error_sum_lacks of Loc.t * Typ.Core.t * Label.t] 49 | type label_missing = [`Error_label_missing of Loc.t * Label.t * Typ.t * Typ.t] 50 | type typ_var_escapes = [`Error_typ_var_escapes of Loc.t * Typ.Var.t * Typ.Core.t] 51 | 52 | type non_disjoint_merge = 53 | [`Error_non_disjoint_merge of Loc.t * Typ.Core.t * Typ.Core.t] 54 | 55 | type pat_lacks_annot = [`Error_pat_lacks_annot of Loc.t] 56 | type exp_lacks_annot = [`Error_exp_lacks_annot of Loc.t] 57 | 58 | type type_errors = 59 | [ var_unbound 60 | | typ_mismatch 61 | | typ_unrelated 62 | | typ_unexpected 63 | | product_lacks 64 | | sum_lacks 65 | | label_missing 66 | | typ_var_escapes 67 | | non_disjoint_merge 68 | | pat_lacks_annot 69 | | exp_lacks_annot ] 70 | 71 | type t = [io_error | syntax_errors | source_errors | kind_errors | type_errors] 72 | -------------------------------------------------------------------------------- /src/main/FomError/FomError.ml: -------------------------------------------------------------------------------- 1 | module Error = Error 2 | -------------------------------------------------------------------------------- /src/main/FomError/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomError) 3 | (libraries FomAST)) 4 | -------------------------------------------------------------------------------- /src/main/FomPP/FomPP.mli: -------------------------------------------------------------------------------- 1 | open FomPPrint 2 | 3 | module Kind : sig 4 | module Numbering : sig 5 | type t 6 | 7 | val create : unit -> t 8 | end 9 | 10 | val pp : ?numbering:Numbering.t -> FomAST.Kind.t -> document 11 | val pp_annot : ?numbering:Numbering.t -> FomAST.Kind.t -> document 12 | val to_string : ?numbering:Numbering.t -> FomAST.Kind.t -> string 13 | end 14 | 15 | module Label : sig 16 | val pp : FomAST.Label.t -> document 17 | end 18 | 19 | module Typ : sig 20 | module Const : sig 21 | val pp : FomAST.Typ.Const.t -> document 22 | end 23 | 24 | module Var : sig 25 | val pp : ?hr:bool -> FomAST.Typ.Var.t -> document 26 | end 27 | 28 | val hanging : 29 | ([> ('t, 'k) FomAST.Typ.Core.f] as 't) -> (document * document) option 30 | 31 | val pp : 32 | ?hr:bool -> 33 | ?pp_annot:(FomAST.Kind.t -> document) -> 34 | ([< ('t, FomAST.Kind.t) FomAST.Typ.f > `App `Const `For `Lam `Mu `Row `Var] 35 | as 36 | 't) -> 37 | document 38 | 39 | val to_string : 40 | ([< ('t, FomAST.Kind.t) FomAST.Typ.f > `App `Const `For `Lam `Mu `Row `Var] 41 | as 42 | 't) -> 43 | string 44 | end 45 | 46 | module Exp : sig 47 | module Var : sig 48 | val pp : ?hr:bool -> FomAST.Exp.Var.t -> document 49 | end 50 | 51 | module Const : sig 52 | val pp' : 53 | ('nat -> document) -> 54 | ('t -> document) -> 55 | ('nat, 't) FomAST.Exp.Const.t -> 56 | document 57 | 58 | val pp : (Bigint.t, FomAST.Typ.t) FomAST.Exp.Const.t -> document 59 | end 60 | end 61 | -------------------------------------------------------------------------------- /src/main/FomPP/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomPP) 3 | (libraries FomParser FomPPrint bignum)) 4 | -------------------------------------------------------------------------------- /src/main/FomPPrint/FomPPrint.ml: -------------------------------------------------------------------------------- 1 | open StdlibPlus 2 | include PPrint 3 | 4 | (* Constants *) 5 | 6 | let arrow_right = utf8string "→" 7 | let double_angle_quote_lhs = utf8string "«" 8 | let double_angle_quote_rhs = utf8string "»" 9 | let exists = utf8string "∃" 10 | let for_all = utf8string "∀" 11 | let greater_equal = utf8string "≥" 12 | let less_equal = utf8string "≤" 13 | let logical_and = utf8string "∧" 14 | let logical_not = utf8string "¬" 15 | let logical_or = utf8string "∨" 16 | let not_equal = utf8string "≠" 17 | let pipe = utf8string "|" 18 | let tick = utf8string "'" 19 | 20 | (* Greek *) 21 | 22 | let alpha_lower = utf8format "α" 23 | let kappa_lower = utf8string "κ" 24 | let lambda_lower = utf8string "λ" 25 | let lambda_upper = utf8string "Λ" 26 | let mu_lower = utf8string "μ" 27 | 28 | (* Bracketing *) 29 | 30 | let empties = (empty, empty) 31 | let spaces = (space, space) 32 | let angles = (langle, rangle) 33 | let braces = (lbrace, rbrace) 34 | let brackets = (lbracket, rbracket) 35 | let double_angle_quotes = (double_angle_quote_lhs, double_angle_quote_rhs) 36 | let parens = (lparen, rparen) 37 | 38 | (* *) 39 | 40 | let softbreak_1 = group (break 1) 41 | 42 | let text = 43 | String.split_on_char ' ' >>> List.map utf8string >>> separate softbreak_1 44 | 45 | let textf fmt = Printf.ksprintf text fmt 46 | 47 | (* Rendering *) 48 | 49 | let to_string ?(max_width = 0) doc = 50 | let buffer = Buffer.create 1000 in 51 | if max_width <= 0 then ToBuffer.compact buffer doc 52 | else ToBuffer.pretty 1.0 max_width buffer doc; 53 | Buffer.sub buffer 0 (Buffer.length buffer) 54 | 55 | (* Keywords *) 56 | 57 | let bool' = utf8string "bool" 58 | let case' = utf8string "case" 59 | let else' = utf8string "else" 60 | let false' = utf8string "false" 61 | let if' = utf8string "if" 62 | let in' = utf8string "in" 63 | let int' = utf8string "int" 64 | let keep' = utf8string "keep" 65 | let let' = utf8string "let" 66 | let string' = utf8string "string" 67 | let target' = utf8string "target" 68 | let then' = utf8string "then" 69 | let true' = utf8string "true" 70 | let type' = utf8string "type" 71 | let unit' = utf8string "()" 72 | 73 | (* Optimizations *) 74 | 75 | let break_0 = break 0 76 | let break_0_0 = break_0 ^^ break_0 77 | let break_1 = break 1 78 | let break_1_0 = break_1 ^^ break_0 79 | let pipe_space = pipe ^^ space 80 | let break_1_pipe_space = break_1 ^^ pipe_space 81 | let colon_break_1 = colon ^^ break_1 82 | let colon_break_1_0 = colon_break_1 ^^ break_0 83 | let comma_break_0 = comma ^^ break_0 84 | let comma_break_1 = comma ^^ break_1 85 | let comma_break_1_or_break_0 = ifflat comma_break_1 break_0 86 | let comma_break_1_or_break_0_0 = ifflat comma_break_1 break_0_0 87 | let let_space = let' ^^ space 88 | let space_arrow_right = space ^^ arrow_right 89 | let space_arrow_right_break_1 = space_arrow_right ^^ break_1 90 | let space_equals = space ^^ equals 91 | let space_equals_space = space_equals ^^ space 92 | let space_in = space ^^ in' 93 | 94 | (* *) 95 | 96 | let egyptian (lhs, rhs) indent doc = 97 | group (lhs ^^ nest indent (break_0 ^^ doc) ^^ break_0 ^^ rhs) 98 | 99 | let gnest n d = group @@ nest n d 100 | 101 | (* *) 102 | 103 | let sub_digit = [|"₀"; "₁"; "₂"; "₃"; "₄"; "₅"; "₆"; "₇"; "₈"; "₉"|] 104 | 105 | let subscript n = 106 | if n < 0 then failwith "subscript"; 107 | let rec loop s n = 108 | if n = 0 then if String.length s = 0 then sub_digit.(0) else s 109 | else 110 | let d = n mod 10 in 111 | let n = n / 10 in 112 | let s = sub_digit.(d) ^ s in 113 | loop s n 114 | in 115 | loop "" n |> utf8string 116 | -------------------------------------------------------------------------------- /src/main/FomPPrint/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomPPrint) 3 | (libraries stdlibplus pprint)) 4 | -------------------------------------------------------------------------------- /src/main/FomParser/Buffer.ml: -------------------------------------------------------------------------------- 1 | open StdlibPlus 2 | 3 | type state = [`Initial | `Open | `TstrStr | `TstrEsc | `TstrExp] list 4 | type t = {mutable state : state; lexbuf : Sedlexing.lexbuf} 5 | 6 | let loc {lexbuf; _} = Sedlexing.lexing_positions lexbuf 7 | let lexeme_utf_8 {lexbuf; _} = Sedlexing.Utf8.lexeme lexbuf 8 | 9 | let init path lexbuf = 10 | Sedlexing.set_filename lexbuf path; 11 | Sedlexing.set_position lexbuf 12 | {Lexing.pos_fname = path; pos_lnum = 1; pos_bol = 0; pos_cnum = 0} 13 | 14 | let from_utf_8 ?(path = "") input = 15 | let lexbuf = input |> UTF.UTF8.to_uchar_array |> Sedlexing.from_uchar_array in 16 | init path lexbuf; 17 | {state = []; lexbuf} 18 | -------------------------------------------------------------------------------- /src/main/FomParser/FomParser.ml: -------------------------------------------------------------------------------- 1 | module Buffer = Buffer 2 | module Lexer = Lexer 3 | module Tokenizer = Tokenizer 4 | 5 | module Grammar = struct 6 | include Grammar 7 | 8 | type 'a t = (Lexing.lexbuf -> token) -> Lexing.lexbuf -> 'a 9 | end 10 | 11 | module Parser = Parser 12 | -------------------------------------------------------------------------------- /src/main/FomParser/FomParser.mli: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomCST 4 | open FomError 5 | 6 | module Buffer : sig 7 | type t 8 | 9 | val from_utf_8 : ?path:string -> string -> t 10 | (** Create a new buffer from UTF-8 string. *) 11 | end 12 | 13 | module Lexer : sig 14 | type t 15 | 16 | val plain : t 17 | (** Lexical syntax without offside rules. *) 18 | 19 | val offside : t 20 | (** Lexical syntax with offside rules. *) 21 | 22 | val is_id : string -> bool 23 | (** Determine whether the string would be a valid id. *) 24 | 25 | val is_id_or_nat : string -> bool 26 | (** Determine whether the string would be a valid id or natural number. *) 27 | 28 | val is_nat : string -> bool 29 | (** Determine whether the string would be a valid natural number. *) 30 | 31 | val coerce_to_id : string -> string 32 | (** Translate arbitrary UTF-8 string to valid id character by character. *) 33 | end 34 | 35 | module Tokenizer : sig 36 | module State : sig 37 | type t 38 | 39 | val initial : t 40 | end 41 | 42 | type token_info = {begins : int; ends : int; name : string; state : State.t} 43 | (** Describes a token for syntax highlighting purposes. *) 44 | 45 | val token_info_utf_8 : State.t -> string -> token_info 46 | (** Parse info of first single token from given UTF-8 string input. *) 47 | 48 | val offset_as_utf_16 : string -> int -> int 49 | (** Convert UTF-32 character offset to UTF-16 character offset with respect to 50 | given UTF-8 string. *) 51 | 52 | val offset_as_utf_32 : string -> int -> int 53 | (** Convert UTF-16 character offset to UTF-32 character offset with respect to 54 | given UTF-8 string. *) 55 | 56 | val synonyms : < unicode : string ; ascii : string ; bop : bool > list 57 | (** List of unicode symbols and their ascii alternatives. *) 58 | 59 | val keywords : string list 60 | (** List of keywords. *) 61 | 62 | val pervasives : string list 63 | (** List of identifiers implicitly available in every module. *) 64 | 65 | val identifiers : string -> string Seq.t 66 | (** Parse a list of all identifiers in the given string. *) 67 | end 68 | 69 | module Grammar : sig 70 | type 'a t 71 | 72 | val mods : Exp.t t 73 | (** Grammar of Fωμ expressions or modules. *) 74 | 75 | val sigs : Typ.t t 76 | (** Grammar of Fωμ type expressions or signatures. *) 77 | 78 | val incs : Typ.t Typ.Defs.f t 79 | (** Grammar of Fωμ type definitions or includes. *) 80 | end 81 | 82 | module Parser : sig 83 | module Error : sig 84 | type t = [Error.lexeme | Error.grammar] 85 | end 86 | 87 | val parse : 88 | 'a Grammar.t -> 89 | Lexer.t -> 90 | Buffer.t -> 91 | ('R, [> Error.t], 'a, (('R, 'D) #sync' as 'D)) er 92 | (** Parse from buffer using given grammar and lexical syntax. *) 93 | 94 | val parse_utf_8 : 95 | 'a Grammar.t -> 96 | Lexer.t -> 97 | ?path:string -> 98 | string -> 99 | ('R, [> Error.t], 'a, (('R, 'D) #sync' as 'D)) er 100 | (** Parse from UTF-8 string using given grammar and lexical syntax. *) 101 | end 102 | -------------------------------------------------------------------------------- /src/main/FomParser/LexTrn.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | 4 | type 't t = 't * Pos.t * Pos.t 5 | type 't env = (Buffer.t -> 't t) * Buffer.t 6 | type 't state = bool * 't t option 7 | 8 | type ('t, 'a) m = 't env -> 't t -> 't state -> ('t, 'a) result * 't state 9 | and ('t, 'a) result = Emit of 't t * ('t, 'a) m | Return of 'a 10 | 11 | (* *) 12 | 13 | type 't r 14 | 15 | external to_rea : ('t, 'a) m -> ('t r, 'e, 'a) s = "%identity" 16 | external of_rea : ('t r, 'e, 'a) s -> ('t, 'a) m = "%identity" 17 | 18 | let unit' _ _ state = (Return (), state) 19 | 20 | class ['f] methods = 21 | let rec ( >>= ) xM xyM env last_pos state = 22 | match xM env last_pos state with 23 | | Emit (tok, xM), state -> (Emit (tok, xM >>= xyM), state) 24 | | Return x, state -> 25 | let yM = xyM x in 26 | yM env last_pos state 27 | in 28 | object (d : 'D) 29 | inherit ['f r, 'D] monad'd 30 | method pure' value = to_rea @@ fun _ _ state -> (Return value, state) 31 | method bind' xF xyF = to_rea (of_rea (xF d) >>= fun x -> of_rea (xyF x d)) 32 | end 33 | 34 | (* *) 35 | 36 | let left_of (_, (p : Pos.t), _) = p.pos_cnum - p.pos_bol 37 | let right_of (_, _, (p : Pos.t)) = p.pos_cnum - p.pos_bol 38 | let tok_of (t, _, _) = t 39 | let set token (_, s, (e : Pos.t)) = (token, s, {e with pos_bol = e.pos_bol - 1}) 40 | 41 | (* *) 42 | 43 | let get _ = 44 | to_rea @@ fun (get_tok, buffer) _ -> function 45 | | is_typ, Some tok -> (Return tok, (is_typ, None)) 46 | | state -> (Return (get_tok buffer), state) 47 | 48 | let unget tok _ = 49 | to_rea @@ fun _ _ (is_typ, tok_opt) -> 50 | match tok_opt with 51 | | Some _ -> failwith "unget" 52 | | None -> (Return (), (is_typ, Some tok)) 53 | 54 | (* *) 55 | 56 | let emit tok _ = to_rea @@ fun _ _ state -> (Emit (tok, unit'), state) 57 | let emit_if bool tok = if bool then emit tok else unit 58 | let emit_before token tok = unget tok >> emit (set token tok) 59 | 60 | (* *) 61 | 62 | let is_typ _ = to_rea @@ fun _ _ ((is_typ, _) as state) -> (Return is_typ, state) 63 | 64 | let set_is_typ is_typ _ = 65 | to_rea @@ fun _ _ (_, tok_opt) -> (Return (), (is_typ, tok_opt)) 66 | 67 | let as_typ op = 68 | let* was = is_typ in 69 | set_is_typ true >> op >>= fun res -> set_is_typ was >> pure res 70 | 71 | (* *) 72 | 73 | let loc _ = 74 | to_rea @@ fun (_, buffer) _ state -> (Return (Buffer.loc buffer), state) 75 | 76 | let last_tok _ = to_rea @@ fun _ last_tok state -> (Return last_tok, state) 77 | 78 | let new_line (_, (p : Pos.t), _) _ = 79 | to_rea @@ fun _ (_, _, (last_pos : Pos.t)) state -> 80 | (Return (last_pos.pos_bol <> p.pos_bol), state) 81 | 82 | let with_indent rule m = 83 | to_rea @@ fun env last_pos state -> 84 | match of_rea (get m) env last_pos state with 85 | | Return tok, state -> of_rea (rule (left_of tok) tok m) env tok state 86 | | _ -> failwith "with_indent" 87 | 88 | (* *) 89 | 90 | let init token start buffer = 91 | let tok = token buffer in 92 | let env = (token, buffer) 93 | and continue' = ref @@ of_rea @@ start @@ new methods 94 | and last_tok' = ref tok 95 | and state' = ref (false, Some tok) in 96 | fun () -> 97 | match !continue' env !last_tok' !state' with 98 | | Emit (tok, continue), state -> 99 | continue' := continue; 100 | last_tok' := tok; 101 | state' := state; 102 | tok 103 | | Return (), _ -> failwith "return" 104 | -------------------------------------------------------------------------------- /src/main/FomParser/LexTrn.mli: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomSource 4 | 5 | type 't t = 't * Pos.t * Pos.t 6 | type ('t, 'a) m 7 | type 't r 8 | 9 | val to_rea : ('t, 'a) m -> ('t r, 'e, 'a) s 10 | val of_rea : ('t r, 'e, 'a) s -> ('t, 'a) m 11 | 12 | (* *) 13 | 14 | val left_of : 't t -> int 15 | val right_of : 't t -> int 16 | val tok_of : 't t -> 't 17 | val set : 't -> 't t -> 't t 18 | 19 | (* *) 20 | 21 | val get : ('t r, 't, 't t, (('t r, 'D) #monad' as 'D)) er 22 | val unget : 't t -> ('t r, 't, unit, (('t r, 'D) #monad' as 'D)) er 23 | 24 | (* *) 25 | 26 | val emit : 't t -> ('t r, 't, unit, (('t r, 'D) #monad' as 'D)) er 27 | val emit_if : bool -> 't t -> ('t r, 't, unit, (('t r, 'D) #monad' as 'D)) er 28 | val emit_before : 't -> 't t -> ('t r, 't, unit, (('t r, 'D) #monad' as 'D)) er 29 | 30 | (* *) 31 | 32 | val is_typ : ('t r, 't, bool, (('t r, 'D) #monad' as 'D)) er 33 | 34 | val as_typ : 35 | ('t r, 't, 'a, (('t r, 'D) #monad' as 'D)) er -> 36 | ('t r, 't, 'a, (('t r, 'D) #monad' as 'D)) er 37 | 38 | (* *) 39 | 40 | val loc : ('t r, 't, Loc.t, (('t r, 'D) #monad' as 'D)) er 41 | val last_tok : ('t r, 't, 't t, (('t r, 'D) #monad' as 'D)) er 42 | val new_line : 't t -> ('t r, 't, bool, (('t r, 'D) #monad' as 'D)) er 43 | 44 | val with_indent : 45 | (int -> 't t -> ('t r, 't, 'a, (('t r, 'D) #monad' as 'D)) er) -> 46 | ('t r, 't, 'a, (('t r, 'D) #monad' as 'D)) er 47 | 48 | (* *) 49 | 50 | val init : 51 | (Buffer.t -> 't t) -> 52 | ('t r, 't, unit, (('t r, 'D) monad' as 'D)) er -> 53 | Buffer.t -> 54 | unit -> 55 | 't t 56 | -------------------------------------------------------------------------------- /src/main/FomParser/Offside.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open Grammar 3 | open Parser 4 | open LexTrn 5 | 6 | let error message = loc >>= fun loc -> raise @@ Exn_lexeme (loc, message) 7 | 8 | let expect exp = 9 | get >>= fun tok -> if tok_of tok <> exp then error "unexpected" else emit tok 10 | 11 | (* *) 12 | 13 | let is_closing = function 14 | | And | BraceRhs | BracketRhs | Comma | DoubleAngleQuoteRhs | EOF | Else | In 15 | | ParenRhs | Then -> 16 | true 17 | | _ -> false 18 | 19 | let is_bop tok = 20 | match tok_of tok with 21 | | Caret | Comma | Diamond | DoubleComma | Equal | Greater | GreaterEqual 22 | | Less | LessEqual | LogicalAnd | LogicalOr | NotEqual | Percent | Plus 23 | | Semicolon | Slash | Star | TriangleLhs | TriangleRhs -> 24 | true 25 | | _ -> false 26 | 27 | let is_continued tok = 28 | match tok_of tok with Comma | In | Semicolon -> true | _ -> false 29 | 30 | let classify indent tok and_then = 31 | let column = left_of tok in 32 | if column < indent then and_then `Dedent 33 | else if column = indent && not (is_bop tok) then 34 | let* last_tok = last_tok and* new_line = new_line tok in 35 | if new_line && not (is_continued last_tok) then and_then `Indent 36 | else and_then `Inside 37 | else and_then `Inside 38 | 39 | let ns tok tok_ns = 40 | let* last_tok = last_tok in 41 | match tok_of last_tok with 42 | | (Id _ | BraceRhs | BracketRhs | DoubleAngleQuoteRhs | ParenRhs) 43 | when right_of last_tok = left_of tok -> 44 | emit (set tok_ns tok) 45 | | _ -> emit tok 46 | 47 | let rec nest tok = 48 | (match tok_of tok with 49 | | ForAll | Exists | MuLower -> 50 | get >>= fun tok' -> 51 | if tok_of tok' <> ParenLhs then 52 | emit (set ParenLhs tok) 53 | >> unget tok' >> emit tok 54 | >> as_typ (with_indent (insert_semis emit)) 55 | >> with_indent (insert_semis ~dedent:true (emit_before ParenRhs)) 56 | else unget tok' >> emit tok 57 | | LambdaLower | LambdaUpper -> 58 | emit (set ParenLhs tok) 59 | >> emit tok 60 | >> as_typ (with_indent (insert_semis emit)) 61 | >> with_indent (insert_semis ~dedent:true (emit_before ParenRhs)) 62 | | DoubleAngleQuoteLhs -> 63 | ns tok DoubleAngleQuoteLhsNS 64 | >> as_typ (with_indent (insert_semis emit)) 65 | >> last_tok 66 | >>= fun tok -> 67 | if tok_of tok = Comma then with_indent (insert_semis emit) else unit 68 | | Include -> ( 69 | emit tok 70 | >> with_indent @@ insert_semis ~dedent:true 71 | @@ fun tok -> 72 | match tok_of tok with In | EOF -> emit tok | _ -> emit_before In tok) 73 | | Type -> emit tok >> as_typ (get >>= binding) 74 | | Let -> emit tok >> get >>= binding 75 | | Colon -> 76 | emit tok 77 | >> emit (set ParenLhs tok) 78 | >> as_typ (with_indent (insert_semis ~dedent:true (emit_before ParenRhs))) 79 | | BraceLhs -> 80 | ns tok BraceLhsNS 81 | >> with_indent (insert_commas ~equal:true ~closing:BraceRhs) 82 | | BracketLhs -> 83 | ns tok BracketLhsNS 84 | >> with_indent (insert_commas ~equal:false ~closing:BracketRhs) 85 | | ParenLhs -> 86 | ns tok ParenLhsNS >> with_indent (insert_semis ~commas:true emit) 87 | | If -> 88 | emit (set ParenLhs tok) 89 | >> emit tok 90 | >> with_indent (insert_semis emit) 91 | >> with_indent (insert_semis emit) 92 | >> with_indent (insert_semis ~dedent:true (emit_before ParenRhs)) 93 | | _ -> emit tok) 94 | >> get 95 | 96 | and insert_commas ~equal ~closing indent tok = 97 | match tok_of tok with 98 | | t when t = closing -> emit tok 99 | | Comma -> ( 100 | classify indent tok @@ function 101 | | `Dedent -> error "offside" 102 | | _ -> emit tok >> get >>= insert_commas ~equal ~closing indent) 103 | | Equal when equal -> 104 | emit tok 105 | >> with_indent 106 | @@ insert_semis ~dedent:true (insert_commas ~equal ~closing indent) 107 | | _ -> ( 108 | classify indent tok @@ function 109 | | `Dedent -> error "offside" 110 | | `Indent -> 111 | emit (set Comma tok) >> nest tok >>= insert_commas ~equal ~closing indent 112 | | _ -> nest tok >>= insert_commas ~equal ~closing indent) 113 | 114 | and pattern form tok = 115 | match tok_of tok with 116 | | Equal -> ( 117 | emit tok 118 | >> with_indent @@ insert_semis ~dedent:true 119 | @@ fun tok -> 120 | match tok_of tok with 121 | | In | EOF -> emit tok 122 | | And -> 123 | emit tok 124 | >> (match form with `Rec -> expect MuLower >> get | `Par -> get) 125 | >>= pattern form 126 | | _ -> emit_before In tok) 127 | | _ -> nest tok >>= pattern form 128 | 129 | and binding tok = 130 | match tok_of tok with 131 | | MuLower -> emit tok >> get >>= pattern `Rec 132 | | _ -> pattern `Par tok 133 | 134 | and insert_semis ?(commas = false) ?(dedent = false) on_exit indent tok = 135 | let* is_typ = is_typ in 136 | match tok_of tok with 137 | | Comma when commas -> ( 138 | classify indent tok @@ function 139 | | `Dedent -> error "offside" 140 | | _ -> emit tok >> get >>= insert_semis ~commas ~dedent on_exit indent) 141 | | t when is_closing t -> on_exit tok 142 | | (Dot | Equal) when is_typ -> on_exit tok 143 | | _ -> ( 144 | classify indent tok @@ function 145 | | `Dedent -> if dedent then on_exit tok else error "offside" 146 | | `Indent when not is_typ -> 147 | emit (set Semicolon tok) 148 | >> nest tok 149 | >>= insert_semis ~commas ~dedent on_exit indent 150 | | _ -> nest tok >>= insert_semis ~commas ~dedent on_exit indent) 151 | -------------------------------------------------------------------------------- /src/main/FomParser/Parser.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open FomSource 3 | 4 | exception Exn_lexeme of Loc.t * string 5 | 6 | module Error = struct 7 | open FomError 8 | 9 | type t = [Error.lexeme | Error.grammar] 10 | end 11 | 12 | let parse grammar lexer buffer d = 13 | try 14 | lexer buffer 15 | |> pure'2 MenhirLib.Convert.Simplified.traditional2revised grammar 16 | |> run d 17 | with 18 | | Grammar.Error -> 19 | fail @@ `Error_grammar (Buffer.loc buffer, Buffer.lexeme_utf_8 buffer) 20 | |> run d 21 | | Exn_lexeme (at, lexeme) -> fail @@ `Error_lexeme (at, lexeme) |> run d 22 | 23 | let parse_utf_8 grammar lexer ?(path = "") input = 24 | Buffer.from_utf_8 ~path input |> parse grammar lexer 25 | -------------------------------------------------------------------------------- /src/main/FomParser/Token.ml: -------------------------------------------------------------------------------- 1 | open Grammar 2 | 3 | let[@warning "-32"] to_string = function 4 | | And -> "and" 5 | | ArrowRight -> "→" 6 | | BraceLhs -> "{" 7 | | BraceLhsNS -> "{" 8 | | BraceRhs -> "}" 9 | | BracketLhs -> "[" 10 | | BracketLhsNS -> "[" 11 | | BracketRhs -> "]" 12 | | Caret -> "^" 13 | | Case -> "case" 14 | | Colon -> ":" 15 | | Comma -> "," 16 | | Comment _ -> "# ..." 17 | | Diamond -> "◇" 18 | | Dot -> "." 19 | | DoubleAngleQuoteLhs -> "«" 20 | | DoubleAngleQuoteLhsNS -> "«" 21 | | DoubleAngleQuoteRhs -> "»" 22 | | DoubleComma -> "„" 23 | | EOF -> "" 24 | | Ellipsis -> "…" 25 | | Else -> "else" 26 | | Equal -> "=" 27 | | Escape s -> s 28 | | Exists -> "∃" 29 | | ForAll -> "∀" 30 | | Greater -> ">" 31 | | GreaterEqual -> "≥" 32 | | Id id -> id 33 | | IdDollar id -> id 34 | | IdSub id -> id 35 | | IdTyp id -> id 36 | | If -> "if" 37 | | Import -> "import" 38 | | In -> "in" 39 | | Include -> "include" 40 | | LambdaLower -> "λ" 41 | | LambdaUpper -> "Λ" 42 | | Less -> "<" 43 | | LessEqual -> "≤" 44 | | Let -> "let" 45 | | LitNat n -> Bigint.to_string n 46 | | Local -> "local" 47 | | LogicalAnd -> "∧" 48 | | LogicalNot -> "¬" 49 | | LogicalOr -> "∨" 50 | | Minus -> "-" 51 | | MuLower -> "μ" 52 | | NotEqual -> "≠" 53 | | ParenLhs -> "(" 54 | | ParenLhsNS -> "(" 55 | | ParenRhs -> ")" 56 | | Percent -> "%" 57 | | Pipe -> "|" 58 | | Plus -> "+" 59 | | Semicolon -> ";" 60 | | Slash -> "/" 61 | | Star -> "*" 62 | | Target -> "target" 63 | | Then -> "then" 64 | | Tick -> "'" 65 | | TriangleLhs -> "◁" 66 | | TriangleRhs -> "▷" 67 | | TstrClose -> "\"...\"" 68 | | TstrEsc _ -> "\"...\"" 69 | | TstrOpen _ -> "\"...\"" 70 | | TstrOpenRaw -> "\"...\"" 71 | | TstrStr _ -> "\"...\"" 72 | | TstrStrPart -> "\"...\"" 73 | | Type -> "type" 74 | | Underscore -> "_" 75 | -------------------------------------------------------------------------------- /src/main/FomParser/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomParser) 3 | (libraries FomCST FomError menhirLib sedlex) 4 | (preprocess 5 | (pps sedlex.ppx))) 6 | 7 | (menhir 8 | (modules Grammar) 9 | (flags --no-dollars 10 | --unused-token Comment 11 | --unused-token Escape 12 | --unused-token TstrStrPart 13 | --unused-token IdDollar 14 | --unused-token IdSub)) 15 | -------------------------------------------------------------------------------- /src/main/FomSandbox/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name FomSandbox) 3 | (modes js) 4 | (libraries FomEnv FomElab FomParser FomToJsC FomDiag cohttp-lwt-jsoo) 5 | (preprocess (pps js_of_ocaml-ppx)) 6 | (js_of_ocaml 7 | (flags ; --debug-info 8 | ; --pretty 9 | ; --source-map-inline 10 | ))) 11 | -------------------------------------------------------------------------------- /src/main/FomSource/FomSource.ml: -------------------------------------------------------------------------------- 1 | module Id = Id 2 | module Loc = Loc 3 | -------------------------------------------------------------------------------- /src/main/FomSource/Id.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomPPrint 4 | 5 | module Name : sig 6 | type t = int 7 | 8 | val of_string : string -> t 9 | val to_string : t -> string 10 | 11 | (* *) 12 | 13 | val compare : t cmp 14 | 15 | (* *) 16 | 17 | val underscore : t 18 | val fresh : t 19 | end = struct 20 | type t = int 21 | 22 | let id_to_int = Hashtbl.create 1000 23 | let int_to_id = Hashtbl.create 1000 24 | 25 | let of_string id = 26 | match Hashtbl.find_opt id_to_int id with 27 | | None -> 28 | let n = Hashtbl.length id_to_int in 29 | Hashtbl.replace id_to_int id n; 30 | Hashtbl.replace int_to_id n id; 31 | n 32 | | Some n -> n 33 | 34 | let to_string = Hashtbl.find int_to_id 35 | 36 | (* *) 37 | 38 | let compare = Int.compare 39 | 40 | (* *) 41 | 42 | let underscore = of_string "_" 43 | let fresh = of_string "" 44 | end 45 | 46 | module Counter : sig 47 | type t = int 48 | 49 | val compare : t cmp 50 | 51 | (* *) 52 | 53 | val next : unit -> int 54 | end = struct 55 | include Int 56 | 57 | let counter = ref 0 58 | 59 | let next () = 60 | let c = !counter + 1 in 61 | counter := c; 62 | c 63 | end 64 | 65 | module type S = sig 66 | type t = {name : Name.t; n : Counter.t; at : Loc.t} 67 | 68 | val at : t -> Loc.t 69 | val set_at : Loc.t -> t -> t 70 | val name : t -> Name.t 71 | 72 | (* Special *) 73 | 74 | val is_numeric : t -> bool 75 | val is_fresh : t -> bool 76 | val is_underscore : t -> bool 77 | 78 | (* Comparison *) 79 | 80 | val equal : t -> t -> bool 81 | val compare : t -> t -> int 82 | 83 | (* Formatting *) 84 | 85 | val to_string : t -> string 86 | val pp : ?hr:bool -> t -> document 87 | 88 | (* Constructors *) 89 | 90 | val underscore : Loc.t -> t 91 | val of_string : Loc.t -> string -> t 92 | val of_name : Loc.t -> Name.t -> t 93 | val of_number : Loc.t -> Bigint.t -> t 94 | 95 | (* Generated *) 96 | 97 | val fresh : Loc.t -> t 98 | 99 | (* Freshening *) 100 | 101 | val freshen : t -> t 102 | 103 | module Unsafe : sig 104 | val set_counter : int -> t -> t 105 | 106 | val smallest : 107 | (t -> ('R, 'e, bool, (('R, 'D) #monad' as 'D)) er) -> 108 | t -> 109 | ('R, 'e, t, 'D) er 110 | end 111 | end 112 | 113 | module Make () : S = struct 114 | type t = {name : Name.t; n : Counter.t; at : Loc.t} 115 | 116 | (* *) 117 | 118 | let at {at; _} = at 119 | let name {name; _} = name 120 | 121 | let is_numeric {name; _} = 122 | let s = Name.to_string name in 123 | 0 < String.length s && '0' <= s.[0] && s.[0] <= '9' 124 | 125 | let set_at at {name; n; _} = {at; name; n} 126 | 127 | (* Comparison *) 128 | 129 | let equal lhs rhs = lhs.name = rhs.name && lhs.n = rhs.n 130 | 131 | let compare lhs rhs = 132 | Int.compare lhs.name rhs.name <>? fun () -> Int.compare lhs.n rhs.n 133 | 134 | (* Formatting *) 135 | 136 | let to_string {name; n; _} = 137 | let it = Name.to_string name in 138 | if n = 0 then it else Printf.sprintf "%s$%d" it n 139 | 140 | let pp ?(hr = true) {name; n; _} = 141 | let it = Name.to_string name |> utf8string in 142 | if n = 0 || name = Name.underscore then it 143 | else if hr then it ^^ subscript n 144 | else it ^^ utf8format "$%d" n 145 | 146 | (* Freshening *) 147 | 148 | let freshen {name; at; _} = {name; n = Counter.next (); at} 149 | 150 | (* Constructors *) 151 | 152 | let of_name at name = 153 | let n = 154 | if name = Name.underscore || name = Name.fresh then Counter.next () else 0 155 | in 156 | {name; n; at} 157 | 158 | let of_string at s = of_name at (Name.of_string s) 159 | let of_number at n = of_string at (Bigint.to_string n) 160 | 161 | (* Generated *) 162 | 163 | let is_fresh {name; n; _} = 164 | name = Name.fresh || (n <> 0 && (Name.to_string name).[0] = '_') 165 | 166 | let fresh at = {name = Name.fresh; n = Counter.next (); at} 167 | 168 | (* Underscore *) 169 | 170 | let is_underscore {name; _} = Name.underscore = name 171 | let underscore at = {name = Name.underscore; n = Counter.next (); at} 172 | 173 | module Unsafe = struct 174 | let set_counter n t = {t with n} 175 | 176 | let smallest is_free i = 177 | let rec loop c = 178 | let u = set_counter c i in 179 | is_free u >>= function false -> pure u | true -> loop (c + 1) 180 | in 181 | loop 0 182 | end 183 | end 184 | -------------------------------------------------------------------------------- /src/main/FomSource/Id.mli: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomPPrint 4 | 5 | module Counter : sig 6 | type t 7 | 8 | val compare : t cmp 9 | end 10 | 11 | module Name : sig 12 | type t 13 | 14 | val compare : t cmp 15 | 16 | (* *) 17 | 18 | val underscore : t 19 | val fresh : t 20 | end 21 | 22 | module type S = sig 23 | type t = {name : Name.t; n : Counter.t; at : Loc.t} 24 | 25 | val at : t -> Loc.t 26 | val set_at : Loc.t -> t -> t 27 | val name : t -> Name.t 28 | 29 | (* Special *) 30 | 31 | val is_numeric : t -> bool 32 | val is_fresh : t -> bool 33 | val is_underscore : t -> bool 34 | 35 | (* Comparison *) 36 | 37 | val equal : t -> t -> bool 38 | val compare : t -> t -> int 39 | 40 | (* Formatting *) 41 | 42 | val to_string : t -> string 43 | val pp : ?hr:bool -> t -> document 44 | 45 | (* Constructors *) 46 | 47 | val underscore : Loc.t -> t 48 | val of_string : Loc.t -> string -> t 49 | val of_name : Loc.t -> Name.t -> t 50 | val of_number : Loc.t -> Bigint.t -> t 51 | 52 | (* Generated *) 53 | 54 | val fresh : Loc.t -> t 55 | 56 | (* Freshening *) 57 | 58 | val freshen : t -> t 59 | 60 | module Unsafe : sig 61 | val set_counter : int -> t -> t 62 | 63 | val smallest : 64 | (t -> ('R, 'e, bool, (('R, 'D) #monad' as 'D)) er) -> 65 | t -> 66 | ('R, 'e, t, 'D) er 67 | end 68 | end 69 | 70 | module Make () : S 71 | -------------------------------------------------------------------------------- /src/main/FomSource/Loc.ml: -------------------------------------------------------------------------------- 1 | open StdlibPlus 2 | include Loc 3 | open FomPPrint 4 | 5 | let pp ((lhs, rhs) : t) = 6 | let format_range lhs rhs = 7 | if lhs = rhs then Printf.sprintf " %d" lhs 8 | else Printf.sprintf "s %d-%d" lhs rhs 9 | in 10 | let file_info = 11 | if lhs.pos_fname = "" then empty 12 | else 13 | let filename = 14 | lhs.pos_fname |> JsonString.of_utf8 |> JsonString.to_utf8_json 15 | |> utf8string 16 | in 17 | text "in file" 18 | ^^ group (nest 2 (break_1_0 ^^ filename) ^^ comma_break_1_or_break_0_0) 19 | in 20 | file_info 21 | ^^ textf "on line%s, column%s" 22 | (format_range lhs.pos_lnum rhs.pos_lnum) 23 | (format_range (Pos.column_of lhs) (Pos.column_of rhs)) 24 | 25 | let to_string = pp >>> to_string 26 | -------------------------------------------------------------------------------- /src/main/FomSource/Loc.mli: -------------------------------------------------------------------------------- 1 | include module type of StdlibPlus.Loc 2 | open FomPPrint 3 | 4 | val pp : t -> document 5 | val to_string : t -> string 6 | -------------------------------------------------------------------------------- /src/main/FomSource/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomSource) 3 | (libraries FomPPrint stdlibplus bignum rea)) 4 | -------------------------------------------------------------------------------- /src/main/FomToJs/FomToJs.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | 3 | (* *) 4 | 5 | module Lam = struct 6 | include Lam 7 | module Var = LamToJs.Var 8 | end 9 | 10 | let in_env op = 11 | op 12 | |> mapping_env @@ fun o -> 13 | object 14 | inherit [_, _, _] async'of o 15 | inherit Lam.Env.con 16 | inherit Lam.Limit.con 17 | inherit Lam.Seen.con 18 | inherit Lam.Renumbering.con 19 | end 20 | 21 | let erase = FomToLam.erase 22 | 23 | let simplify exp = 24 | exp |> LamSimplify.to_fixed_point >>= LamHoist.constants_to_top |> in_env 25 | 26 | let to_js ~top exp = 27 | LamToJs.to_js_stmts 28 | (top :> [`Body | `Return | `Seq | `Tail of _ | `Top]) 29 | Lam.VarSet.empty exp 30 | |> in_env 31 | -------------------------------------------------------------------------------- /src/main/FomToJs/FomToJs.mli: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomAST 4 | 5 | module Lam : sig 6 | module Var : sig 7 | val to_js : Exp.Var.t -> Cats.t 8 | end 9 | 10 | type t = 11 | [ `App of t * t 12 | | `Case of t 13 | | `Const of (int32, Typ.Core.t) Exp.Const.t 14 | | `IfElse of t * t * t 15 | | `Inject of Label.t * t 16 | | `Lam of Exp.Var.t * t 17 | | `Mu of t 18 | | `Product of (Label.t * t) list 19 | | `Select of t * t 20 | | `Var of Exp.Var.t ] 21 | end 22 | 23 | val erase : Exp.Core.t -> Lam.t 24 | (** Erase (most) types from given Fωμ expression. Note that this does not type 25 | check the expression. *) 26 | 27 | val simplify : Lam.t -> ('R, 'e, Lam.t, (('R, 'D) #async' as 'D)) er 28 | (** Simplify erased expression. *) 29 | 30 | val to_js : 31 | top: 32 | [< `Body 33 | | `Return 34 | | `Seq 35 | | `Tail of Exp.Var.t * Exp.Var.t list * Exp.Var.t list * [`Exit | `Case] 36 | | `Top ] -> 37 | Lam.t -> 38 | ('R, 'e, Cats.t, (('R, 'D) #async' as 'D)) er 39 | (** Transpile erased expression to JavaScript. *) 40 | -------------------------------------------------------------------------------- /src/main/FomToJs/FomToLam.ml: -------------------------------------------------------------------------------- 1 | open FomAST 2 | include Lam 3 | 4 | module Const = struct 5 | include Const 6 | 7 | let bi_2_pow_31, bi_2_pow_32, bi_2_pow_32_minus_1 = 8 | let open Bigint in 9 | ( shift_left (of_int 1) 31, 10 | shift_left (of_int 1) 32, 11 | shift_left (of_int 1) 32 - of_int 1 ) 12 | 13 | let erase = function 14 | | `Nat nat -> 15 | let open Bigint in 16 | let nat = bit_and nat bi_2_pow_32_minus_1 in 17 | (* TODO: Warn when literal is truncated. *) 18 | `Nat 19 | (Int32.of_string 20 | (if nat < bi_2_pow_31 then to_string nat 21 | else nat - bi_2_pow_32 |> to_string)) 22 | | ( `Bool _ | `String _ | `Unit | `OpArithAdd | `OpArithDiv | `OpArithMinus 23 | | `OpArithMul | `OpArithPlus | `OpArithRem | `OpArithSub | `OpCmpGt 24 | | `OpCmpGtEq | `OpCmpLt | `OpCmpLtEq | `OpEq _ | `OpEqNot _ 25 | | `OpLogicalAnd | `OpLogicalNot | `OpLogicalOr | `OpStringCat | `Keep _ 26 | | `Target _ ) as other -> 27 | other 28 | end 29 | 30 | let rec erase = function 31 | | `Const (_, c) -> `Const (Const.erase c) 32 | | `Var (_, i) -> `Var i 33 | | `Lam (_, i, _, e) -> `Lam (i, erase e) 34 | | `App (_, f, x) -> `App (erase f, erase x) 35 | | `UnpackIn (_, _, _, i, v, e) -> `App (`Lam (i, erase e), erase v) 36 | | `Mu (_, e) -> `Mu (erase e) 37 | | `IfElse (_, c, t, e) -> `IfElse (erase c, erase t, erase e) 38 | | `Product (_, fs) -> `Product (fs |> Row.map erase) 39 | | `Select (_, e, l) -> `Select (erase e, erase l) 40 | | `Inject (_, l, e) -> `Inject (l, erase e) 41 | | `Case (_, cs) -> `Case (erase cs) 42 | | `Gen (_, _, _, e) | `Inst (_, e, _) | `Pack (_, _, e, _) -> erase e 43 | -------------------------------------------------------------------------------- /src/main/FomToJs/Js.ml: -------------------------------------------------------------------------------- 1 | open StdlibPlus 2 | open FomParser 3 | 4 | let is_identity = ( = ) (JsonString.of_utf8 "x => x") (* TODO *) 5 | 6 | module StringSet = Set.Make (String) 7 | 8 | (* See: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Lexical_grammar *) 9 | 10 | let reserved = 11 | StringSet.of_list 12 | [ 13 | "break"; 14 | "case"; 15 | "catch"; 16 | "class"; 17 | "const"; 18 | "continue"; 19 | "debugger"; 20 | "default"; 21 | "delete"; 22 | "do"; 23 | "else"; 24 | "export"; 25 | "extends"; 26 | "finally"; 27 | "for"; 28 | "function"; 29 | "if"; 30 | "import"; 31 | "in"; 32 | "instanceof"; 33 | "new"; 34 | "return"; 35 | "super"; 36 | "switch"; 37 | "this"; 38 | "throw"; 39 | "try"; 40 | "typeof"; 41 | "var"; 42 | "void"; 43 | "while"; 44 | "with"; 45 | "yield"; 46 | ] 47 | 48 | let strict_mode_reserved = 49 | StringSet.of_list 50 | [ 51 | "implements"; 52 | "interface"; 53 | "let"; 54 | "package"; 55 | "private"; 56 | "protected"; 57 | "public"; 58 | "static"; 59 | "yield"; 60 | ] 61 | 62 | let future_always_reserved = StringSet.of_list ["enum"] 63 | let future_module_reserved = StringSet.of_list ["await"] 64 | let literal = StringSet.of_list ["false"; "null"; "true"] 65 | let special_identifier = StringSet.of_list ["arguments"; "eval"; "get"; "set"] 66 | 67 | let illegal_id = 68 | [ 69 | reserved; 70 | strict_mode_reserved; 71 | future_always_reserved; 72 | future_module_reserved; 73 | literal; 74 | special_identifier; 75 | ] 76 | |> List.fold_left StringSet.union StringSet.empty 77 | 78 | let is_illegal_id name = 79 | StringSet.mem name illegal_id 80 | || match name.[0] with '0' .. '9' -> true | _ -> false 81 | 82 | let max_safe_nat = "9007199254740991" 83 | 84 | let is_safe_nat s = 85 | Lexer.is_nat s 86 | && (String.length s < String.length max_safe_nat 87 | || (String.length s = String.length max_safe_nat && s <= max_safe_nat)) 88 | -------------------------------------------------------------------------------- /src/main/FomToJs/Js.mli: -------------------------------------------------------------------------------- 1 | open StdlibPlus 2 | 3 | val is_identity : JsonString.t -> bool 4 | 5 | val is_illegal_id : string -> bool 6 | (** Tests whether given name should be considered illegal identifier in JS. *) 7 | 8 | val is_safe_nat : string -> bool 9 | -------------------------------------------------------------------------------- /src/main/FomToJs/LamHoist.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomSource 4 | open FomParser 5 | open FomAST 6 | open Lam 7 | 8 | let constants_to_top inn = 9 | let cs = ref LamMap.empty in 10 | let add c = 11 | match LamMap.find_opt c !cs with 12 | | None -> 13 | let i = 14 | to_string c |> Lexer.coerce_to_id |> Var.of_string Loc.dummy 15 | |> Var.freshen 16 | in 17 | cs := LamMap.add c (i, LamMap.cardinal !cs, ref 1) !cs; 18 | `Var i 19 | | Some (i, _, n) -> 20 | n := !n + 1; 21 | `Var i 22 | in 23 | let rec analyze ~skip = 24 | let consider vs r = 25 | let+ may_hoist = if skip then pure false else is_total r in 26 | match r with 27 | | _ when not may_hoist -> (vs, r) 28 | | `Const (`Keep _ | `Bool _ | `Nat _ | `Unit) | `Var _ -> (vs, r) 29 | | _ -> (vs, if VarSet.is_empty vs then add r else r) 30 | in 31 | function 32 | | `Const _ as r -> r |> consider VarSet.empty 33 | | `Var i as r -> r |> consider @@ VarSet.singleton i 34 | | `App (`Lam (i, e), x) -> 35 | let* evs, e = analyze ~skip:false e and* xvs, x = analyze ~skip:true x in 36 | `App (`Lam (i, e), x) 37 | |> consider @@ VarSet.union (VarSet.remove i evs) xvs 38 | | `App (`App (`Const c, x), y) when Const.is_bop c && Const.is_total c -> 39 | let* xvs, x = analyze ~skip:false x and* yvs, y = analyze ~skip:false y in 40 | `App (`App (`Const c, x), y) |> consider @@ VarSet.union xvs yvs 41 | | `App (`Const c, x) when Const.is_uop c && Const.is_total c -> 42 | let* vs, x = analyze ~skip:false x in 43 | `App (`Const c, x) |> consider vs 44 | | `App (f, x) -> 45 | let* fvs, f = analyze ~skip:false f and* xvs, x = analyze ~skip:false x in 46 | `App (f, x) |> consider @@ VarSet.union fvs xvs 47 | | `IfElse (c, t, e) -> 48 | let* cvs, c = analyze ~skip:false c 49 | and* tvs, t = analyze ~skip:false t 50 | and* evs, e = analyze ~skip:false e in 51 | `IfElse (c, t, e) |> consider @@ VarSet.union cvs (VarSet.union tvs evs) 52 | | `Product fs -> 53 | let* vs, fs = analyze_product ~skip:false fs in 54 | `Product fs |> consider vs 55 | | `Mu (`Lam (f, e)) -> 56 | let* vs, e = analyze ~skip:true e in 57 | `Mu (`Lam (f, e)) |> consider @@ VarSet.remove f vs 58 | | `Mu (`Case (`Product fs)) -> 59 | let* vs, fs = analyze_product ~skip:true fs in 60 | `Mu (`Case (`Product fs)) |> consider vs 61 | | `Mu e -> 62 | let* vs, e = analyze ~skip:false e in 63 | `Mu e |> consider vs 64 | | `Lam (i, e) -> 65 | let* vs, e = analyze ~skip:false e in 66 | `Lam (i, e) |> consider @@ VarSet.remove i vs 67 | | `Inject (l, e) -> 68 | let* vs, e = analyze ~skip:false e in 69 | `Inject (l, e) |> consider vs 70 | | `Select (e, `Inject (l, `Const `Unit)) -> 71 | let* vs, e = analyze ~skip:false e in 72 | `Select (e, `Inject (l, `Const `Unit)) |> consider vs 73 | | `Select (e, l) -> 74 | let* evs, e = analyze ~skip:false e and* lvs, l = analyze ~skip:false l in 75 | `Select (e, l) |> consider @@ VarSet.union evs lvs 76 | | `Case (`Product fs) -> 77 | let* vs, fs = analyze_product ~skip:true fs in 78 | `Case (`Product fs) |> consider vs 79 | | `Case cs -> 80 | let* vs, cs = analyze ~skip:false cs in 81 | `Case cs |> consider vs 82 | and analyze_product ~skip fs = 83 | let+ fs = fs |> Row.map_er (analyze ~skip) in 84 | ( fs |> List.fold_left (fun s (_, (vs, _)) -> VarSet.union s vs) VarSet.empty, 85 | fs |> Row.map snd ) 86 | in 87 | let+ _, e = analyze ~skip:true inn in 88 | !cs |> LamMap.bindings 89 | |> List.sort (fun (_, (_, l, _)) (_, (_, r, _)) -> Int.compare r l) 90 | |> List.fold_left (fun e (v, (i, _, _)) -> `App (`Lam (i, e), v)) e 91 | -------------------------------------------------------------------------------- /src/main/FomToJs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomToJs) 3 | (libraries FomAST FomPP FomParser stdlibplus)) 4 | -------------------------------------------------------------------------------- /src/main/FomToJsC/FomToJsC.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | 4 | (* *) 5 | 6 | open Cats 7 | 8 | (* *) 9 | 10 | module ModSimplified = struct 11 | type 'R t = (string, ('R, nothing, FomToJs.Lam.t) Memo.t) Hashtbl.t 12 | 13 | let create () = Hashtbl.create 100 14 | let field r = r#mod_simplified 15 | 16 | let get_or_put path compute = 17 | let* (hashtbl : 'R t) = env_as field in 18 | match Hashtbl.find_opt hashtbl path with 19 | | None -> 20 | let* var = Memo.create compute in 21 | Hashtbl.replace hashtbl path var; 22 | Memo.eval var |> gen_error 23 | | Some var -> Memo.eval var |> gen_error 24 | 25 | class ['R] con (mod_simplified : 'R t) = 26 | object 27 | method mod_simplified = mod_simplified 28 | end 29 | end 30 | 31 | module ModInJs = struct 32 | type 'R t = (string, ('R, nothing, Cats.t) Memo.t) Hashtbl.t 33 | 34 | let create () = Hashtbl.create 100 35 | let field r = r#mod_in_js 36 | 37 | let get_or_put path compute = 38 | let* (hashtbl : 'R t) = env_as field in 39 | match Hashtbl.find_opt hashtbl path with 40 | | None -> 41 | let* var = Memo.create compute in 42 | Hashtbl.replace hashtbl path var; 43 | Memo.eval var |> gen_error 44 | | Some var -> Memo.eval var |> gen_error 45 | 46 | class ['R] con (mod_in_js : 'R t) = 47 | object 48 | method mod_in_js = mod_in_js 49 | end 50 | end 51 | 52 | let topological_deps paths = 53 | let added = Hashtbl.create 100 in 54 | let deps = ref [] in 55 | let rec loop path = 56 | if Hashtbl.mem added path then unit 57 | else 58 | let* (_, _, _, paths), _ = FomElab.ExpImports.get path in 59 | paths |> List.iter_er loop >>- fun () -> 60 | if not (Hashtbl.mem added path) then ( 61 | Hashtbl.replace added path (); 62 | deps := path :: !deps) 63 | in 64 | paths |> List.iter_er loop >>- fun () -> !deps 65 | 66 | let erase_and_simplify_all paths = 67 | paths 68 | |> List.map_er @@ fun path -> 69 | let* (id, ast, _, _), _ = FomElab.ExpImports.get path in 70 | let+ erased = 71 | ModSimplified.get_or_put path 72 | (eta'0 @@ fun () -> ast |> FomToJs.erase |> FomToJs.simplify) 73 | in 74 | (id, path, erased) 75 | 76 | let whole_program_to_js ~top ast paths = 77 | let+ js = 78 | paths |> topological_deps >>= erase_and_simplify_all 79 | >>- List.fold_left 80 | (fun prg (id, _, erased) -> `App (`Lam (id, prg), erased)) 81 | (FomToJs.erase ast) 82 | >>= FomToJs.simplify >>= FomToJs.to_js ~top 83 | in 84 | to_string @@ match top with `Top -> str "'use strict';; " ^ js | `Body -> js 85 | 86 | let compile_to_js_all paths = 87 | paths |> erase_and_simplify_all 88 | >>= List.map_er @@ fun (id, path, erased) -> 89 | ModInJs.get_or_put path 90 | ( erased |> FomToJs.to_js ~top:`Body >>- fun js -> 91 | str "// " ^ str path ^ str "\n" ^ str "const " 92 | ^ FomToJs.Lam.Var.to_js id ^ str " = (() => " ^ js ^ str ")()" ) 93 | 94 | let modules_to_js ~top ast paths = 95 | let* paths = topological_deps paths in 96 | let* modules = compile_to_js_all paths in 97 | let+ prg = ast |> FomToJs.erase |> FomToJs.simplify >>= FomToJs.to_js ~top in 98 | let js = 99 | modules 100 | |> List.fold_left 101 | (fun prg js -> js ^ str "\n\n" ^ prg) 102 | (str "// main\n" ^ prg) 103 | in 104 | to_string 105 | @@ match top with `Top -> str "'use strict';;\n\n" ^ js | `Body -> js 106 | 107 | let to_js ~whole ~top = 108 | if whole then whole_program_to_js ~top else modules_to_js ~top 109 | -------------------------------------------------------------------------------- /src/main/FomToJsC/FomToJsC.mli: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open FomAST 4 | open FomError 5 | open FomElab 6 | 7 | module ModSimplified : sig 8 | type 'R t 9 | 10 | val create : unit -> 'R t 11 | 12 | class ['R] con : 13 | 'R t 14 | -> object 15 | method mod_simplified : 'R t 16 | end 17 | end 18 | 19 | module ModInJs : sig 20 | type 'R t 21 | 22 | val create : unit -> 'R t 23 | 24 | class ['R] con : 25 | 'R t 26 | -> object 27 | method mod_in_js : 'R t 28 | end 29 | end 30 | 31 | val to_js : 32 | whole:bool -> 33 | top:[`Top | `Body] -> 34 | Exp.Core.t -> 35 | string List.t -> 36 | ( 'R, 37 | [> Error.t], 38 | string, 39 | (< 'R ExpImports.con 40 | ; 'R ModInJs.con 41 | ; 'R ModSimplified.con 42 | ; ('R, 'D) async' 43 | ; .. > 44 | as 45 | 'D) ) 46 | er 47 | -------------------------------------------------------------------------------- /src/main/FomToJsC/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FomToJsC) 3 | (libraries FomElab FomError FomToJs)) 4 | -------------------------------------------------------------------------------- /src/main/FomToJsRT/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name FomToJsRT) 3 | (modes js) 4 | (libraries FomParser) 5 | (preprocess (pps js_of_ocaml-ppx)) 6 | (js_of_ocaml 7 | (flags ; --debug-info 8 | ; --pretty 9 | ; --source-map-inline 10 | ))) 11 | -------------------------------------------------------------------------------- /src/test/FomAST/FomASTTest.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open MuTest 4 | open FomPPrint 5 | open FomParser 6 | 7 | let parse_typ utf_8 = 8 | Buffer.from_utf_8 utf_8 |> Parser.parse Grammar.sigs Lexer.offside 9 | 10 | let () = 11 | test "Typ.to_string" @@ fun () -> 12 | let original = "∀x:*.μxs:*.(x→(x→x))→xs" in 13 | parse_typ original >>= FomElab.elaborate_typ 14 | |> mapping_env (fun o -> 15 | object 16 | inherit [_, _, _] async'of o 17 | inherit [_, _, _] FomEnv.Env.empty () 18 | end) 19 | >>- FomPP.Typ.pp >>- to_string 20 | |> tryin 21 | (fun _ -> verify false) 22 | (fun formatted -> verify (formatted = "∀x.μxs.(x → x → x) → xs")) 23 | 24 | let () = 25 | let open JsonString in 26 | test "LitString" @@ fun () -> 27 | verify 28 | (to_utf8 @@ of_utf8 "foo\tbar\n" 29 | = to_utf8 @@ of_utf8_json "\"foo\\tbar\\n\"") 30 | -------------------------------------------------------------------------------- /src/test/FomAST/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name FomASTTest) 3 | (libraries FomElab FomEnv FomParser FomPP mutest)) 4 | -------------------------------------------------------------------------------- /src/test/FomChecker/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name FomCheckerTest) 3 | (libraries FomChecker FomEnv FomElab FomParser FomDiag mutest)) 4 | -------------------------------------------------------------------------------- /src/test/FomElab/FomElabTest.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open StdlibPlus 3 | open MuTest 4 | open FomSource 5 | 6 | let () = 7 | test "Path.coalesce" @@ fun () -> 8 | [ 9 | ("/foo/bar.fom", "baz", "/foo/baz"); 10 | ("/foo/bar.fom", "/lol/bal", "/lol/bal"); 11 | ("/foo/bar.fom", "https://lol/foo/../../bal.fom", "https://lol/../bal.fom"); 12 | ("https://host/foo.fom", "https://lol/../bal", "https://lol/../bal"); 13 | ("https://host:80/foo/bar.fom", "../baz", "https://host:80/baz"); 14 | ("https://host:80/foo/bar.fom", "/baz", "https://host:80/baz"); 15 | ("https://host:80/foo/bar.fom", "baz", "https://host:80/foo/baz"); 16 | ] 17 | |> List.iter_er @@ fun (loc, path, expected) -> 18 | let actual = 19 | FomElab.Path.coalesce (Loc.of_path loc) (JsonString.of_utf8 path) 20 | in 21 | if actual <> expected then 22 | failuref "Expected: %s\nActual: %s\n" expected actual 23 | else unit 24 | -------------------------------------------------------------------------------- /src/test/FomElab/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name FomElabTest) 3 | (libraries FomElab mutest)) 4 | -------------------------------------------------------------------------------- /src/test/FomParser/FomParserTest.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open MuTest 3 | open FomAST 4 | open FomParser 5 | 6 | let test_parses_as name source check = 7 | test name @@ fun () -> 8 | source 9 | |> Parser.parse_utf_8 Grammar.mods Lexer.offside 10 | |> tryin (fun _ -> verify false) check 11 | 12 | let () = 13 | test_parses_as "location info" "Λα:*.\n λx:α.x" @@ function 14 | | `Gen 15 | ( _, 16 | ({Typ.Var.at = {pos_lnum = 1; pos_bol = 0; pos_cnum = 1; _}, _; _} as 17 | alpha1), 18 | `Star _, 19 | `LamPat 20 | ( _, 21 | `Annot 22 | ( _, 23 | `Var 24 | ( _, 25 | ({ 26 | Exp.Var.at = 27 | {pos_lnum = 2; pos_bol = 6; pos_cnum = 9; _}, _; 28 | _; 29 | } as x1) ), 30 | `Var (_, alpha2) ), 31 | `Var (_, x2) ) ) -> 32 | verify (Typ.Var.to_string alpha1 = "α" && Typ.Var.equal alpha1 alpha2) 33 | >> verify (Exp.Var.to_string x1 = "x" && 0 = Exp.Var.compare x1 x2) 34 | | _ -> verify false 35 | 36 | let () = 37 | test_parses_as "symbolic" "Λt.μdiverge:t→t.λx:t.diverge x" @@ function 38 | | `Gen _ -> unit 39 | | _ -> verify false 40 | 41 | let () = 42 | test_parses_as "keywords" 43 | "gen t => rec diverge : t -> t => fun x : t => diverge x" 44 | @@ function 45 | | `Gen _ -> unit 46 | | _ -> verify false 47 | 48 | let () = 49 | test "parse error" @@ fun () -> 50 | "" 51 | |> Parser.parse_utf_8 Grammar.mods Lexer.offside 52 | |> tryin (fun _ -> pure ()) (fun _ -> verify false) 53 | -------------------------------------------------------------------------------- /src/test/FomParser/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name FomParserTest) 3 | (libraries FomParser mutest menhirLib sedlex)) 4 | -------------------------------------------------------------------------------- /src/test/FomSource/FomSourceTest.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open MuTest 3 | open FomSource 4 | 5 | let () = 6 | let module Id = Id.Make () in 7 | let x = Id.of_string Loc.dummy "x" in 8 | let x'0 = Id.freshen x in 9 | let x'1 = Id.freshen x'0 in 10 | test "fresh ids have equal names" (fun () -> 11 | verify (Id.name x = Id.name x'0) >> verify (Id.name x'0 = Id.name x'1)); 12 | test "fresh ids are not equal" (fun () -> 13 | verify (not (Id.equal x x'0)) 14 | >> verify (not (Id.equal x'0 x'1)) 15 | >> verify (not (Id.equal x'1 x))) 16 | -------------------------------------------------------------------------------- /src/test/FomSource/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name FomSourceTest) 3 | (libraries FomSource mutest)) 4 | -------------------------------------------------------------------------------- /src/test/FomToJs/FomToJsTest.ml: -------------------------------------------------------------------------------- 1 | open Rea 2 | open MuTest 3 | open FomParser 4 | open FomElab 5 | 6 | let parse_exp source and_then = 7 | source 8 | |> Parser.parse_utf_8 Grammar.mods Lexer.offside 9 | >>= elaborate 10 | |> tryin (fun _ -> verify false) and_then 11 | |> mapping_env @@ fun o -> 12 | object 13 | inherit [_, _, _] async'of o 14 | inherit [_, _, _] FomEnv.Env.empty () 15 | end 16 | 17 | let testCompiles name exp = 18 | test name @@ fun () -> 19 | parse_exp exp @@ fun (ast, _, _) -> 20 | let* _ = 21 | ast |> FomToJs.erase |> FomToJs.simplify >>= FomToJs.to_js ~top:`Top 22 | in 23 | verify true 24 | 25 | let () = 26 | testCompiles "fix via μ type unapplied" 27 | {| 28 | let Z = Λa.Λb. 29 | type μt = t → a → b 30 | λf:(a → b) → a → b.(λg:t.g g) λx:t.λn:a.f (x x) n 31 | let fact = Z«int»«int» λfact:int → int. 32 | λn:int.if n ≤ 0 then 1 else n*fact(n-1) 33 | fact 34 | |}; 35 | testCompiles "fix via μ type applied" 36 | {| 37 | let Z = Λa.Λb. 38 | type μt = t → a → b 39 | λf:(a → b) → a → b.(λg:t.g g) λx:t.λn:a.f (x x) n 40 | let fact = Z«int»«int» λfact:int → int. 41 | λn:int.if n ≤ 0 then 1 else n*fact(n-1) 42 | fact 5 43 | |}; 44 | testCompiles "non-terminating fix" 45 | {| 46 | let Z = Λa.Λb.λf:(a → b) → a → b. 47 | let z = λx:μt.t → a → b.f (x x) 48 | z z 49 | let fact = Z«int»«int» λfact:int → int. 50 | λn:int.if n ≤ 0 then 1 else n*fact(n-1) 51 | fact 5 52 | |}; 53 | testCompiles "inf non-terminating fix" 54 | {| 55 | let Z = Λa.Λb.λf:(a → b) → a → b. 56 | let z = λx:μt.t → a → b.f (x x) 57 | z z 58 | let fact = Z«int»«int» λfact:int → int. 59 | λn:int.if n =«int» 0 then 1 else n*fact(n-1) 60 | fact (-5) 61 | |}; 62 | () 63 | -------------------------------------------------------------------------------- /src/test/FomToJs/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name FomToJsTest) 3 | (libraries FomToJs FomEnv FomElab FomParser mutest)) 4 | --------------------------------------------------------------------------------