commit 358f9970652282cb69b3b85c35d00612ec2fcfef parent 4c5b8ae2e5b76efb21a2897c9deb7150d368aaac Author: AlexKnauth <alexander@knauth.org> Date: Tue, 28 Jun 2016 13:14:21 -0400 reorganize Diffstat:
| A | info.rkt | | | 9 | +++++++++ |
| R | tapl/README.md -> macrotypes/examples/README.md | | | 0 | |
| A | macrotypes/examples/exist.rkt | | | 74 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/ext-stlc.rkt | | | 134 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/fomega.rkt | | | 128 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/fomega2.rkt | | | 95 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/fomega3.rkt | | | 33 | +++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/fsub.rkt | | | 88 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | tapl/id-expand-experiment.rkt -> macrotypes/examples/id-expand-experiment.rkt | | | 0 | |
| A | macrotypes/examples/infer.rkt | | | 200 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | tapl/lam-testing.rkt -> macrotypes/examples/lam-testing.rkt | | | 0 | |
| R | tapl/mlish-do.rkt -> macrotypes/examples/mlish-do.rkt | | | 0 | |
| A | macrotypes/examples/mlish.rkt | | | 1365 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | tapl/notes.txt -> macrotypes/examples/notes.txt | | | 0 | |
| A | macrotypes/examples/stlc+box.rkt | | | 27 | +++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+cons.rkt | | | 91 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+effect.rkt | | | 138 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+lit.rkt | | | 39 | +++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+occurrence.rkt | | | 355 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+overloading.rkt | | | 164 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+rec-iso.rkt | | | 70 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+reco+sub.rkt | | | 48 | ++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+reco+var.rkt | | | 132 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+sub.rkt | | | 97 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc+tup.rkt | | | 33 | +++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/stlc.rkt | | | 130 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/sysf.rkt | | | 29 | +++++++++++++++++++++++++++++ |
| A | macrotypes/examples/tests/infer-tests.rkt | | | 364 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | tapl/tests/lam-testing-tests.rkt -> macrotypes/examples/tests/lam-testing-tests.rkt | | | 0 | |
| A | macrotypes/examples/tests/stlc+occurrence-tests.rkt | | | 618 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | macrotypes/examples/tests/stlc+overloading-tests.rkt | | | 120 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | tapl/postfix-in.rkt -> macrotypes/postfix-in.rkt | | | 0 | |
| R | tapl/stx-utils.rkt -> macrotypes/stx-utils.rkt | | | 0 | |
| R | tapl/type-constraints.rkt -> macrotypes/type-constraints.rkt | | | 0 | |
| R | tapl/typecheck.rkt -> macrotypes/typecheck.rkt | | | 0 | |
| R | tapl/variance-constraints.rkt -> macrotypes/variance-constraints.rkt | | | 0 | |
| D | tapl/exist.rkt | | | 74 | -------------------------------------------------------------------------- |
| D | tapl/ext-stlc.rkt | | | 134 | ------------------------------------------------------------------------------- |
| D | tapl/fomega.rkt | | | 128 | ------------------------------------------------------------------------------- |
| D | tapl/fomega2.rkt | | | 95 | ------------------------------------------------------------------------------- |
| D | tapl/fomega3.rkt | | | 33 | --------------------------------- |
| D | tapl/fsub.rkt | | | 88 | ------------------------------------------------------------------------------- |
| D | tapl/infer.rkt | | | 200 | ------------------------------------------------------------------------------- |
| D | tapl/mlish.rkt | | | 1364 | ------------------------------------------------------------------------------- |
| D | tapl/stlc+box.rkt | | | 27 | --------------------------- |
| D | tapl/stlc+cons.rkt | | | 91 | ------------------------------------------------------------------------------- |
| D | tapl/stlc+effect.rkt | | | 138 | ------------------------------------------------------------------------------- |
| D | tapl/stlc+lit.rkt | | | 39 | --------------------------------------- |
| D | tapl/stlc+occurrence.rkt | | | 355 | ------------------------------------------------------------------------------- |
| D | tapl/stlc+overloading.rkt | | | 164 | ------------------------------------------------------------------------------- |
| D | tapl/stlc+rec-iso.rkt | | | 70 | ---------------------------------------------------------------------- |
| D | tapl/stlc+reco+sub.rkt | | | 48 | ------------------------------------------------ |
| D | tapl/stlc+reco+var.rkt | | | 132 | ------------------------------------------------------------------------------- |
| D | tapl/stlc+sub.rkt | | | 97 | ------------------------------------------------------------------------------- |
| D | tapl/stlc+tup.rkt | | | 33 | --------------------------------- |
| D | tapl/stlc.rkt | | | 130 | ------------------------------------------------------------------------------- |
| D | tapl/sysf.rkt | | | 29 | ----------------------------- |
| D | tapl/tests/exist-tests.rkt | | | 370 | ------------------------------------------------------------------------------- |
| D | tapl/tests/ext-stlc-tests.rkt | | | 170 | ------------------------------------------------------------------------------- |
| D | tapl/tests/fomega-tests.rkt | | | 211 | ------------------------------------------------------------------------------- |
| D | tapl/tests/fomega2-tests.rkt | | | 203 | ------------------------------------------------------------------------------- |
| D | tapl/tests/fomega3-tests.rkt | | | 200 | ------------------------------------------------------------------------------- |
| D | tapl/tests/fsub-tests.rkt | | | 153 | ------------------------------------------------------------------------------- |
| D | tapl/tests/infer-tests.rkt | | | 364 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish-tests.rkt | | | 778 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/ack.mlish | | | 27 | --------------------------- |
| D | tapl/tests/mlish/alex.mlish | | | 25 | ------------------------- |
| D | tapl/tests/mlish/ary.mlish | | | 26 | -------------------------- |
| D | tapl/tests/mlish/bg/basics-general.mlish | | | 59 | ----------------------------------------------------------- |
| D | tapl/tests/mlish/bg/basics.mlish | | | 370 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/bg/basics2.mlish | | | 138 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/bg/huffman.mlish | | | 278 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/bg/lambda.mlish | | | 95 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/bg/monad.mlish | | | 122 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/bg/okasaki.mlish | | | 1654 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/chameneos.mlish | | | 129 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/fannkuch.mlish | | | 54 | ------------------------------------------------------ |
| D | tapl/tests/mlish/fasta.mlish | | | 191 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/fibo.mlish | | | 22 | ---------------------- |
| D | tapl/tests/mlish/find.mlish | | | 87 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/hash.mlish | | | 19 | ------------------- |
| D | tapl/tests/mlish/infer-variances.mlish | | | 243 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/inst.mlish | | | 74 | -------------------------------------------------------------------------- |
| D | tapl/tests/mlish/knuc.mlish | | | 67 | ------------------------------------------------------------------- |
| D | tapl/tests/mlish/listpats.mlish | | | 70 | ---------------------------------------------------------------------- |
| D | tapl/tests/mlish/loop.mlish | | | 121 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/match2.mlish | | | 298 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/matrix.mlish | | | 73 | ------------------------------------------------------------------------- |
| D | tapl/tests/mlish/nbody.mlish | | | 185 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/polyrecur.mlish | | | 117 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/queens.mlish | | | 186 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/result.mlish | | | 129 | ------------------------------------------------------------------------------- |
| D | tapl/tests/mlish/sweet-map.rkt | | | 20 | -------------------- |
| D | tapl/tests/mlish/term.mlish | | | 295 | ------------------------------------------------------------------------------ |
| D | tapl/tests/mlish/trees-tests.mlish | | | 51 | --------------------------------------------------- |
| D | tapl/tests/mlish/trees.mlish | | | 8 | -------- |
| D | tapl/tests/mlish/value-restriction-example.mlish | | | 25 | ------------------------- |
| D | tapl/tests/rackunit-typechecking.rkt | | | 92 | ------------------------------------------------------------------------------- |
| D | tapl/tests/run-all-tests.rkt | | | 37 | ------------------------------------- |
| D | tapl/tests/stlc+box-tests.rkt | | | 239 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+cons-tests.rkt | | | 229 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+effect-tests.rkt | | | 241 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+lit-tests.rkt | | | 65 | ----------------------------------------------------------------- |
| D | tapl/tests/stlc+occurrence-tests.rkt | | | 618 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+overloading-tests.rkt | | | 120 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+rec-iso-tests.rkt | | | 247 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+reco+sub-tests.rkt | | | 113 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+reco+var-tests.rkt | | | 232 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc+sub-tests.rkt | | | 63 | --------------------------------------------------------------- |
| D | tapl/tests/stlc+tup-tests.rkt | | | 107 | ------------------------------------------------------------------------------- |
| D | tapl/tests/stlc-tests.rkt | | | 13 | ------------- |
| D | tapl/tests/sysf-tests.rkt | | | 76 | ---------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/exist.rkt | | | 75 | --------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/ext-stlc.rkt | | | 145 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/fomega.rkt | | | 116 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/fomega2.rkt | | | 94 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/fomega3.rkt | | | 33 | --------------------------------- |
| D | tapl/typed-lang-builder/fsub.rkt | | | 92 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/lang/reader.rkt | | | 2 | -- |
| D | tapl/typed-lang-builder/mlish.rkt | | | 1430 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/stlc+box.rkt | | | 32 | -------------------------------- |
| D | tapl/typed-lang-builder/stlc+cons.rkt | | | 81 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/stlc+effect.rkt | | | 117 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/stlc+lit.rkt | | | 40 | ---------------------------------------- |
| D | tapl/typed-lang-builder/stlc+rec-iso.rkt | | | 51 | --------------------------------------------------- |
| D | tapl/typed-lang-builder/stlc+reco+sub.rkt | | | 52 | ---------------------------------------------------- |
| D | tapl/typed-lang-builder/stlc+reco+var.rkt | | | 175 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/stlc+sub.rkt | | | 107 | ------------------------------------------------------------------------------- |
| D | tapl/typed-lang-builder/stlc+tup.rkt | | | 35 | ----------------------------------- |
| D | tapl/typed-lang-builder/stlc.rkt | | | 53 | ----------------------------------------------------- |
| D | tapl/typed-lang-builder/sysf.rkt | | | 32 | -------------------------------- |
| D | tapl/typed-lang-builder/typed-lang-builder.rkt | | | 297 | ------------------------------------------------------------------------------- |
| A | typed-lang-builder/examples/exist.rkt | | | 75 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/ext-stlc.rkt | | | 145 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/fomega.rkt | | | 116 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/fomega2.rkt | | | 94 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/fomega3.rkt | | | 33 | +++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/fsub.rkt | | | 92 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | tapl/typed-lang-builder/mlish-do.rkt -> typed-lang-builder/examples/mlish-do.rkt | | | 0 | |
| A | typed-lang-builder/examples/mlish.rkt | | | 1430 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+box.rkt | | | 32 | ++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+cons.rkt | | | 81 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+effect.rkt | | | 117 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+lit.rkt | | | 40 | ++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+rec-iso.rkt | | | 51 | +++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+reco+sub.rkt | | | 52 | ++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+reco+var.rkt | | | 175 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+sub.rkt | | | 107 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc+tup.rkt | | | 35 | +++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/stlc.rkt | | | 53 | +++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/sysf.rkt | | | 32 | ++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/exist-tests.rkt | | | 370 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/ext-stlc-tests.rkt | | | 170 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/fomega-tests.rkt | | | 211 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/fomega2-tests.rkt | | | 203 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/fomega3-tests.rkt | | | 200 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/fsub-tests.rkt | | | 153 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish-tests.rkt | | | 778 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/ack.mlish | | | 27 | +++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/alex.mlish | | | 25 | +++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/ary.mlish | | | 26 | ++++++++++++++++++++++++++ |
| R | tapl/tests/mlish/bg/README.md -> typed-lang-builder/examples/tests/mlish/bg/README.md | | | 0 | |
| A | typed-lang-builder/examples/tests/mlish/bg/basics-general.mlish | | | 59 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/bg/basics.mlish | | | 370 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/bg/basics2.mlish | | | 138 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/bg/huffman.mlish | | | 278 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/bg/lambda.mlish | | | 95 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/bg/monad.mlish | | | 122 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/bg/okasaki.mlish | | | 1654 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/chameneos.mlish | | | 129 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/fannkuch.mlish | | | 54 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/fasta.mlish | | | 191 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/fibo.mlish | | | 22 | ++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/find.mlish | | | 87 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/hash.mlish | | | 19 | +++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/infer-variances.mlish | | | 243 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/inst.mlish | | | 74 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/knuc.mlish | | | 67 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/listpats.mlish | | | 70 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/loop.mlish | | | 121 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/match2.mlish | | | 298 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/matrix.mlish | | | 73 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/nbody.mlish | | | 185 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/polyrecur.mlish | | | 117 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/queens.mlish | | | 186 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/result.mlish | | | 129 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/sweet-map.rkt | | | 20 | ++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/term.mlish | | | 295 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/trees-tests.mlish | | | 51 | +++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/mlish/trees.mlish | | | 8 | ++++++++ |
| A | typed-lang-builder/examples/tests/mlish/value-restriction-example.mlish | | | 25 | +++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/rackunit-typechecking.rkt | | | 92 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| R | tapl/tests/run-all-mlish-tests.rkt -> typed-lang-builder/examples/tests/run-all-mlish-tests.rkt | | | 0 | |
| A | typed-lang-builder/examples/tests/run-all-tests.rkt | | | 37 | +++++++++++++++++++++++++++++++++++++ |
| R | tapl/tests/run-mlish-tests1.rkt -> typed-lang-builder/examples/tests/run-mlish-tests1.rkt | | | 0 | |
| R | tapl/tests/run-mlish-tests2.rkt -> typed-lang-builder/examples/tests/run-mlish-tests2.rkt | | | 0 | |
| R | tapl/tests/run-mlish-tests3.rkt -> typed-lang-builder/examples/tests/run-mlish-tests3.rkt | | | 0 | |
| R | tapl/tests/run-mlish-tests4.rkt -> typed-lang-builder/examples/tests/run-mlish-tests4.rkt | | | 0 | |
| A | typed-lang-builder/examples/tests/stlc+box-tests.rkt | | | 239 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+cons-tests.rkt | | | 229 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+effect-tests.rkt | | | 241 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+lit-tests.rkt | | | 65 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+rec-iso-tests.rkt | | | 247 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+reco+sub-tests.rkt | | | 113 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+reco+var-tests.rkt | | | 232 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+sub-tests.rkt | | | 63 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc+tup-tests.rkt | | | 107 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/examples/tests/stlc-tests.rkt | | | 13 | +++++++++++++ |
| A | typed-lang-builder/examples/tests/sysf-tests.rkt | | | 76 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | typed-lang-builder/lang/reader.rkt | | | 2 | ++ |
| A | typed-lang-builder/typed-lang-builder.rkt | | | 297 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
211 files changed, 16737 insertions(+), 16727 deletions(-)
diff --git a/info.rkt b/info.rkt @@ -0,0 +1,9 @@ +#lang info + +(define collection 'multi) + +(define deps + '("base" + "sweet-exp" + )) + diff --git a/tapl/README.md b/macrotypes/examples/README.md diff --git a/macrotypes/examples/exist.rkt b/macrotypes/examples/exist.rkt @@ -0,0 +1,74 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+reco+var.rkt") +(reuse #:from "stlc+rec-iso.rkt") ; want type=?, but only need to load current-type=? + +;; existential types +;; Types: +;; - types from stlc+reco+var.rkt +;; - ∃ +;; Terms: +;; - terms from stlc+reco+var.rkt +;; - pack and open +;; Other: type=? from stlc+rec-iso.rkt + + +(define-type-constructor ∃ #:bvs = 1) + +(define-typed-syntax pack + [(pack (τ:type e) as ∃τ:type) + #:with (~∃* (τ_abstract) τ_body) #'∃τ.norm + #:with [e- τ_e] (infer+erase #'e) + #:when (typecheck? #'τ_e (subst #'τ.norm #'τ_abstract #'τ_body)) + (⊢ e- : ∃τ.norm)]) + +(define-typed-syntax open #:datum-literals (<=) + [(open ([(tv:id x:id) <= e_packed]) e) + #:with [e_packed- ((τ_abstract) (τ_body))] (⇑ e_packed as ∃) + ;; The subst below appears to be a hack, but it's not really. + ;; It's the (TaPL) type rule itself that is fast and loose. + ;; Leveraging the macro system's management of binding reveals this. + ;; + ;; Specifically, here is the TaPL Unpack type rule, fig24-1, p366: + ;; Γ ⊢ t_1 : {∃X,T_12} + ;; Γ,X,x:T_12 ⊢ t_2 : T_2 + ;; ------------------------------ + ;; Γ ⊢ let {X,x}=t_1 in t_2 : T_2 + ;; + ;; There's *two* separate binders, the ∃ and the let, + ;; which the rule conflates. + ;; + ;; Here's the rule rewritten to distinguish the two binding positions: + ;; Γ ⊢ t_1 : {∃X_1,T_12} + ;; Γ,X_???,x:T_12 ⊢ t_2 : T_2 + ;; ------------------------------ + ;; Γ ⊢ let {X_2,x}=t_1 in t_2 : T_2 + ;; + ;; The X_1 binds references to X in T_12. + ;; The X_2 binds references to X in t_2. + ;; What should the X_??? be? + ;; + ;; A first guess might be to replace X_??? with both X_1 and X_2, + ;; so all the potentially referenced type vars are bound. + ;; Γ ⊢ t_1 : {∃X_1,T_12} + ;; Γ,X_1,X_2,x:T_12 ⊢ t_2 : T_2 + ;; ------------------------------ + ;; Γ ⊢ let {X_2,x}=t_1 in t_2 : T_2 + ;; + ;; But this example demonstrates that the rule above doesnt work: + ;; (open ([x : X_2 (pack (Int 0) as (∃ (X_1) X_1))]) + ;; ((λ ([y : X_2]) y) x) + ;; Here, x has type X_1, y has type X_2, but they should be the same thing, + ;; so we need to replace all X_1's with X_2 + ;; + ;; Here's the fixed rule, which is implemented here + ;; + ;; Γ ⊢ t_1 : {∃X_1,T_12} + ;; Γ,X_2,x:[X_2/X_1]T_12 ⊢ t_2 : T_2 + ;; ------------------------------ + ;; Γ ⊢ let {X_2,x}=t_1 in t_2 : T_2 + ;; + #:with [_ (x-) (e-) (τ_e)] + (infer #'(e) + #:tvctx #'([tv : #%type]) + #:ctx #`([x : #,(subst #'tv #'τ_abstract #'τ_body)])) + (⊢ (let- ([x- e_packed-]) e-) : τ_e)]) diff --git a/macrotypes/examples/ext-stlc.rkt b/macrotypes/examples/ext-stlc.rkt @@ -0,0 +1,134 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+lit.rkt" #:except #%datum) +(provide (for-syntax current-join)) + +;; Simply-Typed Lambda Calculus, plus extensions (TAPL ch11) +;; Types: +;; - types from stlc+lit.rkt +;; - Bool, String +;; - Unit +;; Terms: +;; - terms from stlc+lit.rkt +;; - literals: bool, string +;; - boolean prims, numeric prims +;; - if +;; - prim void : (→ Unit) +;; - begin +;; - ascription (ann) +;; - let, let*, letrec + +(define-base-type Bool) +(define-base-type String) +(define-base-type Float) +(define-base-type Char) + +(define-typed-syntax #%datum + [(#%datum . b:boolean) (⊢ #,(syntax/loc stx (#%datum- . b)) : Bool)] + [(#%datum . s:str) (⊢ #,(syntax/loc stx (#%datum- . s)) : String)] + [(#%datum . f) #:when (flonum? (syntax-e #'f)) (⊢ #,(syntax/loc stx (#%datum- . f)) : Float)] + [(#%datum . c:char) (⊢ #,(syntax/loc stx (#%datum- . c)) : Char)] + [(#%datum . x) (syntax/loc stx (stlc+lit:#%datum . x))]) + +(define-primop zero? : (→ Int Bool)) +(define-primop = : (→ Int Int Bool)) +(define-primop - : (→ Int Int Int)) +(define-primop add1 : (→ Int Int)) +(define-primop sub1 : (→ Int Int)) +(define-primop not : (→ Bool Bool)) + +(define-typed-syntax and + [(and e1 e2) + #:with e1- (⇑ e1 as Bool) + #:with e2- (⇑ e2 as Bool) + (⊢ (and- e1- e2-) : Bool)]) + +(define-typed-syntax or + [(or e ...) + #:with (e- ...) (⇑s (e ...) as Bool) +; #:with e1- (⇑ e1 as Bool) +; #:with e2- (⇑ e2 as Bool) +; (⊢ (or- e1- e2-) : Bool)]) + (⊢ (or- e- ...) : Bool)]) + +(begin-for-syntax + (define current-join + (make-parameter + (λ (x y) + (unless (typecheck? x y) + (type-error + #:src x + #:msg "branches have incompatible types: ~a and ~a" x y)) + x)))) + +(define-typed-syntax if + [(if e_tst e1 e2) + #:with τ-expected (get-expected-type stx) +; #:with e_tst- (⇑ e_tst as Bool) + #:with [e_tst- _] (infer+erase #'e_tst) + #:with e1_ann #'(add-expected e1 τ-expected) + #:with e2_ann #'(add-expected e2 τ-expected) + #:with (e1- τ1) (infer+erase #'e1_ann) + #:with (e2- τ2) (infer+erase #'e2_ann) + #:with τ-out ((current-join) #'τ1 #'τ2) + (⊢ (if- e_tst- e1- e2-) : τ-out)]) + +(define-base-type Unit) +(define-primop void : (→ Unit)) + +(define-typed-syntax begin + [(begin e_unit ... e) + #:with ([e_unit- _] ...) (infers+erase #'(e_unit ...)) ;(⇑s (e_unit ...) as Unit) + #:with (e- τ) (infer+erase #'e) + (⊢ (begin- e_unit- ... e-) : τ)]) + +(define-typed-syntax ann + #:datum-literals (:) + [(ann e : ascribed-τ:type) + #:with (e- τ) (infer+erase #'(add-expected e ascribed-τ.norm)) + #:fail-unless (typecheck? #'τ #'ascribed-τ.norm) + (format "~a does not have type ~a\n" + (syntax->datum #'e) (syntax->datum #'ascribed-τ)) + (⊢ e- : ascribed-τ)]) + +(define-typed-syntax let + [(let ([x e] ...) e_body) + #:with τ-expected (get-expected-type stx) + #:with ((e- τ) ...) (infers+erase #'(e ...)) + #:with ((x- ...) e_body- τ_body) (infer/ctx+erase #'([x τ] ...) #'(add-expected e_body τ-expected)) + #:fail-unless (or (not (syntax-e #'τ-expected)) ; no expected type + (typecheck? #'τ_body ((current-type-eval) #'τ-expected))) + (format "let body has type ~a, which does not match expected type ~a" + (type->str #'τ_body) (type->str #'τ-expected)) + (⊢ (let- ([x- e-] ...) e_body-) : τ_body)]) + +; dont need to manually transfer expected type +; result template automatically propagates properties +; - only need to transfer expected type when local expanding an expression +; - see let/tc +(define-typed-syntax let* + [(let* () e_body) + #:with τ-expected (get-expected-type stx) + #'e_body] + [(let* ([x e] [x_rst e_rst] ...) e_body) + #:with τ-expected (get-expected-type stx) + #'(let ([x e]) (let* ([x_rst e_rst] ...) e_body))]) + +(define-typed-syntax letrec + [(letrec ([b:type-bind e] ...) e_body) + #:with ((x- ...) (e- ... e_body-) (τ ... τ_body)) + (infers/ctx+erase #'(b ...) #'((add-expected e b.type) ... e_body)) + #:fail-unless (typechecks? #'(b.type ...) #'(τ ...)) + (type-error #:src stx + #:msg (string-append + "letrec: type check fail, args have wrong type:\n" + (string-join + (stx-map + (λ (e τ τ-expect) + (format + "~a has type ~a, expected ~a" + (syntax->datum e) (type->str τ) (type->str τ-expect))) + #'(e ...) #'(τ ...) #'(b.type ...)) + "\n"))) + (⊢ (letrec- ([x- e-] ...) e_body-) : τ_body)]) + + diff --git a/macrotypes/examples/fomega.rkt b/macrotypes/examples/fomega.rkt @@ -0,0 +1,128 @@ +#lang s-exp macrotypes/typecheck +(extends "sysf.rkt" #:except #%datum ∀ Λ inst) +(reuse String #%datum #:from "stlc+reco+var.rkt") + +;; System F_omega +;; Type relation: +;; Types: +;; - types from sysf.rkt +;; - String from stlc+reco+var +;; Terms: +;; - extend ∀ Λ inst from sysf +;; - add tyλ and tyapp +;; - #%datum from stlc+reco+var + +(define-syntax-category kind) + +; want #%type to be equiv to★ +; => edit current-kind? so existing #%type annotations (with no #%kind tag) +; are treated as kinds +; <= define ★ as rename-transformer expanding to #%type +(begin-for-syntax + (current-kind? (λ (k) (or (#%type? k) (kind? k)))) + ;; Try to keep "type?" backward compatible with its uses so far, + ;; eg in the definition of λ or previous type constuctors. + ;; (However, this is not completely possible, eg define-type-alias) + ;; So now "type?" no longer validates types, rather it's a subset. + ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) + (current-type? (λ (t) + (define k (typeof t)) + #;(or (type? t) (★? (typeof t)) (∀★? (typeof t))) + (and ((current-kind?) k) (not (⇒? k)))))) + +; must override, to handle kinds +(provide define-type-alias) +(define-syntax define-type-alias + (syntax-parser + [(_ alias:id τ) + #:with (τ- k_τ) (infer+erase #'τ) + #:fail-unless ((current-kind?) #'k_τ) (format "not a valid type: ~a\n" (type->str #'τ)) + #'(define-syntax alias (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))])) + +(provide ★ (for-syntax ★?)) +(define-for-syntax ★? #%type?) +(define-syntax ★ (make-rename-transformer #'#%type)) +(define-kind-constructor ⇒ #:arity >= 1) +(define-kind-constructor ∀★ #:arity >= 0) + +(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) + +;; alternative: normalize before type=? +; but then also need to normalize in current-promote +(begin-for-syntax + (define (normalize τ) + (syntax-parse τ #:literals (#%plain-app #%plain-lambda) + [x:id #'x] + [(#%plain-app + (#%plain-lambda (tv ...) τ_body) τ_arg ...) + (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] + [(#%plain-lambda (x ...) . bodys) + #:with bodys_norm (stx-map normalize #'bodys) + (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] + [(#%plain-app x:id . args) + #:with args_norm (stx-map normalize #'args) + (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] + [(#%plain-app . args) + #:with args_norm (stx-map normalize #'args) + #:with res (normalize #'(#%plain-app . args_norm)) + (transfer-stx-props #'res τ #:ctx τ)] + [_ τ])) + + (define old-eval (current-type-eval)) + (define (type-eval τ) (normalize (old-eval τ))) + (current-type-eval type-eval) + + (define old-type=? (current-type=?)) + ; ty=? == syntax eq and syntax prop eq + (define (type=? t1 t2) + (let ([k1 (typeof t1)][k2 (typeof t2)]) + (and (or (and (not k1) (not k2)) + (and k1 k2 ((current-type=?) k1 k2))) + (old-type=? t1 t2)))) + (current-type=? type=?) + (current-typecheck-relation (current-type=?))) + +(define-typed-syntax Λ + [(Λ bvs:kind-ctx e) + #:with ((tv- ...) e- τ_e) (infer/ctx+erase #'bvs #'e) + (⊢ e- : (∀ ([tv- : bvs.kind] ...) τ_e))]) + +(define-typed-syntax inst + [(inst e τ ...) + #:with (e- (([tv k] ...) (τ_body))) (⇑ e as ∀) + #:with ([τ- k_τ] ...) (infers+erase #'(τ ...)) + #:when (stx-andmap + (λ (t k) (or ((current-kind?) k) + (type-error #:src t #:msg "not a valid type: ~a" t))) + #'(τ ...) #'(k_τ ...)) + #:when (typechecks? #'(k_τ ...) #'(k ...)) + (⊢ e- : #,(substs #'(τ- ...) #'(tv ...) #'τ_body))]) + +;; TODO: merge with regular λ and app? +;; - see fomega2.rkt +(define-typed-syntax tyλ + [(tyλ bvs:kind-ctx τ_body) + #:with (tvs- τ_body- k_body) (infer/ctx+erase #'bvs #'τ_body) + #:fail-unless ((current-kind?) #'k_body) + (format "not a valid type: ~a\n" (type->str #'τ_body)) + (⊢ (λ- tvs- τ_body-) : (⇒ bvs.kind ... k_body))]) + +(define-typed-syntax tyapp + [(tyapp τ_fn τ_arg ...) + #:with [τ_fn- (k_in ... k_out)] (⇑ τ_fn as ⇒) + #:with ([τ_arg- k_arg] ...) (infers+erase #'(τ_arg ...)) + #:fail-unless (typechecks? #'(k_arg ...) #'(k_in ...)) + (string-append + (format "~a (~a:~a) Arguments to function ~a have wrong kinds(s), " + (syntax-source stx) (syntax-line stx) (syntax-column stx) + (syntax->datum #'τ_fn)) + "or wrong number of arguments:\nGiven:\n" + (string-join + (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line + (syntax->datum #'(τ_arg ...)) + (stx-map type->str #'(k_arg ...))) + "\n" #:after-last "\n") + (format "Expected: ~a arguments with type(s): " + (stx-length #'(k_in ...))) + (string-join (stx-map type->str #'(k_in ...)) ", ")) + (⊢ (#%app- τ_fn- τ_arg- ...) : k_out)]) diff --git a/macrotypes/examples/fomega2.rkt b/macrotypes/examples/fomega2.rkt @@ -0,0 +1,95 @@ +#lang s-exp macrotypes/typecheck +(extends "sysf.rkt" #:except #%datum ∀ Λ inst);#:rename [~∀ ~sysf:∀]) +(reuse String #%datum #:from "stlc+reco+var.rkt") + +; same as fomega.rkt except here λ and #%app works as both type and terms +; - uses definition from stlc, but tweaks type? and kind? predicates +;; → is also both type and kind + +;; System F_omega +;; Type relation: +;; Types: +;; - types from sysf.rkt +;; - String from stlc+reco+var +;; Terms: +;; - extend ∀ Λ inst from sysf +;; - #%datum from stlc+reco+var + +(define-syntax-category kind) + +(begin-for-syntax + (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) + ;; Try to keep "type?" backward compatible with its uses so far, + ;; eg in the definition of λ or previous type constuctors. + ;; (However, this is not completely possible, eg define-type-alias) + ;; So now "type?" no longer validates types, rather it's a subset. + ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) + (current-type? (λ (t) (or (type? t) + (let ([k (typeof t)]) + (or (★? k) (∀★? k))) + ((current-kind?) t))))) + +; must override +(provide define-type-alias) +(define-syntax define-type-alias + (syntax-parser + [(_ alias:id τ) + #:with (τ- k_τ) (infer+erase #'τ) + #'(define-syntax alias (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))])) + +(define-base-kind ★) +(define-kind-constructor ∀★ #:arity >= 0) +(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) + +;; alternative: normalize before type=? +; but then also need to normalize in current-promote +(begin-for-syntax + (define (normalize τ) + (syntax-parse τ #:literals (#%plain-app #%plain-lambda) + [x:id #'x] + [(#%plain-app + (#%plain-lambda (tv ...) τ_body) τ_arg ...) + (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] + [(#%plain-lambda (x ...) . bodys) + #:with bodys_norm (stx-map normalize #'bodys) + (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] + [(#%plain-app x:id . args) + #:with args_norm (stx-map normalize #'args) + (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] + [(#%plain-app . args) + #:with args_norm (stx-map normalize #'args) + (transfer-stx-props (normalize #'(#%plain-app . args_norm)) τ #:ctx τ)] + [_ τ])) + + (define old-eval (current-type-eval)) + (define (type-eval τ) (normalize (old-eval τ))) + (current-type-eval type-eval) + + (define old-type=? (current-type=?)) + (define (type=? t1 t2) + (or (and (★? t1) (#%type? t2)) + (and (#%type? t1) (★? t2)) + (and (syntax-parse (list t1 t2) #:datum-literals (:) + [((~∀ ([tv1 : k1]) tbody1) + (~∀ ([tv2 : k2]) tbody2)) + ((current-type=?) #'k1 #'k2)] + [_ #t]) + (old-type=? t1 t2)))) + (current-type=? type=?) + (current-typecheck-relation (current-type=?))) + +(define-typed-syntax Λ + [(Λ bvs:kind-ctx e) + #:with ((tv- ...) e- τ_e) + (infer/ctx+erase #'bvs #'e) + (⊢ e- : (∀ ([tv- : bvs.kind] ...) τ_e))]) + +(define-typed-syntax inst + [(inst e τ ...) + #:with (e- (([tv k] ...) (τ_body))) (⇑ e as ∀) + #:with ([τ- k_τ] ...) (infers+erase #'(τ ...)) + #:when (stx-andmap (λ (t k) (or ((current-kind?) k) + (type-error #:src t #:msg "not a valid type: ~a" t))) + #'(τ ...) #'(k_τ ...)) + #:when (typechecks? #'(k_τ ...) #'(k ...)) + (⊢ e- : #,(substs #'(τ- ...) #'(tv ...) #'τ_body))]) diff --git a/macrotypes/examples/fomega3.rkt b/macrotypes/examples/fomega3.rkt @@ -0,0 +1,33 @@ +#lang s-exp macrotypes/typecheck +(extends "sysf.rkt" #:except #%datum ∀ Λ inst) +(reuse String #%datum #:from "stlc+reco+var.rkt") +(require (only-in "fomega.rkt" current-kind? ∀★? ★? kind?)) +(reuse ★ ∀ Λ inst define-type-alias ∀★ #:from "fomega.rkt") + +; same as fomega2.rkt --- λ and #%app works as both regular and type versions, +; → is both type and kind --- but reuses parts of fomega.rkt, +; ie removes the duplication in fomega2.rkt + +;; System F_omega +;; Type relation: +;; - redefine current-kind? and current-type so #%app and λ +;; work for both terms and types +;; Types: +;; - types from fomega.rkt +;; - String from stlc+reco+var +;; Terms: +;; - extend ∀ Λ inst from fomega.rkt +;; - #%datum from stlc+reco+var + +;; types and kinds are now mixed, due to #%app and λ +(begin-for-syntax + (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) + ;; Try to keep "type?" backward compatible with its uses so far, + ;; eg in the definition of λ or previous type constuctors. + ;; (However, this is not completely possible, eg define-type-alias) + ;; So now "type?" no longer validates types, rather it's a subset. + ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) + (current-type? (λ (t) (or (type? t) + (let ([k (typeof t)]) + (or (★? k) (∀★? k))) + ((current-kind?) t))))) diff --git a/macrotypes/examples/fsub.rkt b/macrotypes/examples/fsub.rkt @@ -0,0 +1,88 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+reco+sub.rkt" #:except +) +(require (rename-in (only-in "sysf.rkt" ∀? ∀ ~∀) [~∀ ~sysf:∀] [∀ sysf:∀])) + +;; System F<: +;; Types: +;; - types from sysf.rkt and stlc+reco+sub +;; - extend ∀ with bounds +;; Terms: +;; - terms from sysf.rkt and stlc+reco+sub +;; - extend Λ and inst +;; - redefine + with Nat +;; Other +;; - current-promote, expose +;; - extend current-sub? to call current-promote + +(define-primop + : (→ Nat Nat Nat)) + +; can't just call expose in type-eval, +; otherwise typevars will have bound as type, rather than instantiated type +; only need expose during +; 1) subtype checking +; 2) pattern matching -- including base types +(begin-for-syntax + (define (expose t) + (cond [(identifier? t) + (define sub (typeof t #:tag '<:)) + (if sub (expose sub) t)] + [else t])) + (current-promote expose) + (define stlc:sub? (current-sub?)) + (define (sub? t1 t2) + (stlc:sub? ((current-promote) t1) t2)) + (current-sub? sub?) + (current-typecheck-relation (current-sub?))) + +; quasi-kind, but must be type constructor because its arguments are types +(define-type-constructor <: #:arity >= 0) +(begin-for-syntax + (current-type? (λ (t) (or (type? t) (<:? (typeof t)))))) + +;; Type annotations used in two places: +;; 1) typechecking the body of +;; 2) instantiation of ∀ +;; Problem: need type annotations, even in expanded form +;; Solution: store type annotations in a (quasi) kind <: +(define-typed-syntax ∀ #:datum-literals (<:) + [(_ ([tv:id <: τ:type] ...) τ_body) + ; eval first to overwrite the old #%type + (⊢ #,((current-type-eval) #'(sysf:∀ (tv ...) τ_body)) : (<: τ.norm ...))]) +(begin-for-syntax + (define-syntax ~∀ + (pattern-expander + (syntax-parser #:datum-literals (<:) + [(_ ([tv:id <: τ_sub] ...) τ) + #'(~and ∀τ + (~parse (~sysf:∀ (tv ...) τ) #'∀τ) + (~parse (~<: τ_sub ...) (typeof #'∀τ)))] + [(_ . args) + #'(~and ∀τ + (~parse (~sysf:∀ (tv (... ...)) τ) #'∀τ) + (~parse (~<: τ_sub (... ...)) (typeof #'∀τ)) + (~parse args #'(([tv τ_sub] (... ...)) τ)))]))) + (define-syntax ~∀* + (pattern-expander + (syntax-parser #:datum-literals (<:) + [(_ . args) + #'(~or + (~∀ . args) + (~and any (~do + (type-error + #:src #'any + #:msg "Expected ∀ type, got: ~a" #'any))))])))) + +(define-typed-syntax Λ #:datum-literals (<:) + [(Λ ([tv:id <: τsub:type] ...) e) + ;; NOTE: store the subtyping relation of tv and τsub in another + ;; "environment", ie, a syntax property with another tag: '<: + ;; The "expose" function looks for this tag to enforce the bound, + ;; as in TaPL (fig 28-1) + #:with ((tv- ...) _ (e-) (τ_e)) (infer #'(e) #:tvctx #'([tv : #%type <: τsub] ...)) + (⊢ e- : (∀ ([tv- <: τsub] ...) τ_e))]) +(define-typed-syntax inst + [(inst e τ:type ...) + #:with (e- (([tv τ_sub] ...) τ_body)) (⇑ e as ∀) + #:when (typechecks? #'(τ.norm ...) #'(τ_sub ...)) + (⊢ e- : #,(substs #'(τ.norm ...) #'(tv ...) #'τ_body))]) + diff --git a/tapl/id-expand-experiment.rkt b/macrotypes/examples/id-expand-experiment.rkt diff --git a/macrotypes/examples/infer.rkt b/macrotypes/examples/infer.rkt @@ -0,0 +1,200 @@ +#lang s-exp macrotypes/typecheck +(extends "ext-stlc.rkt" #:except #%app λ → + - void = zero? sub1 add1 not + #:rename [~→ ~ext-stlc:→]) +(require (only-in "sysf.rkt" ∀ ~∀ ∀? Λ)) +(reuse cons [head hd] [tail tl] nil [isnil nil?] List list #:from "stlc+cons.rkt") +(require (only-in "stlc+cons.rkt" ~List)) +(reuse tup × proj #:from "stlc+tup.rkt") +(reuse define-type-alias #:from "stlc+reco+var.rkt") +(require (for-syntax "../type-constraints.rkt")) +(provide hd tl nil?) +(provide →) + +;; a language with partial (local) type inference using bidirectional type checking + +(define-syntax → ; wrapping → + (syntax-parser + [(→ (~and Xs {X:id ...}) . rst) + #:when (brace? #'Xs) + (add-orig #'(∀ (X ...) (ext-stlc:→ . rst)) (get-orig this-syntax))] + [(→ . rst) (add-orig #'(∀ () (ext-stlc:→ . rst)) (get-orig this-syntax))])) + +(define-primop + : (→ Int Int Int)) +(define-primop - : (→ Int Int Int)) +(define-primop void : (→ Unit)) +(define-primop = : (→ Int Int Bool)) +(define-primop zero? : (→ Int Bool)) +(define-primop sub1 : (→ Int Int)) +(define-primop add1 : (→ Int Int)) +(define-primop not : (→ Bool Bool)) +(define-primop abs : (→ Int Int)) + +(begin-for-syntax + ;; find-free-Xs : (Stx-Listof Id) Type -> (Listof Id) + ;; finds the free Xs in the type + (define (find-free-Xs Xs ty) + (for/list ([X (in-list (stx->list Xs))] + #:when (stx-contains-id? ty X)) + X)) + + ;; solve : (Stx-Listof Id) (Stx-Listof Stx) (Stx-Listof Type-Stx) + ;; -> (List Constraints (Listof (Stx-List Stx Type-Stx))) + ;; Solves for the Xs by inferring the type of each arg and unifying it against + ;; each corresponding expected-τ (which could have free Xs in them). + ;; It returns list of 2 values if successful, else throws a type error + ;; - the constraints for substituting the types + ;; - a list containing of all the arguments paired with their types + (define (solve Xs args expected-τs) + (let-values + ([(cs e+τs) + (for/fold ([cs #'()] [e+τs #'()]) + ([e_arg (syntax->list args)] + [τ_inX (syntax->list expected-τs)]) + (define τ_in (inst-type/cs Xs cs τ_inX)) + (define/with-syntax [e τ] + (infer+erase (if (empty? (find-free-Xs Xs τ_in)) + (add-expected-ty e_arg τ_in) + e_arg))) + ; (displayln #'(e τ)) + (define cs* (add-constraints Xs cs #`([#,τ_in τ]))) + (values cs* (cons #'[e τ] e+τs)))]) + (list cs (reverse (stx->list e+τs)))))) + +(define-typed-syntax define + [(define x:id e) + #:with (e- τ) (infer+erase #'e) + #:with y (generate-temporary) + #'(begin- + (define-syntax x (make-rename-transformer (⊢ y : τ))) + (define- y e-))] + [(define (~and Xs {X:id ...}) (f:id [x:id (~datum :) τ] ... (~datum →) τ_out) e) + #:when (brace? #'Xs) + #:with g (generate-temporary #'f) + #:with e_ann #'(add-expected e τ_out) + #'(begin- + (define-syntax f (make-rename-transformer + (⊢ g : #,(add-orig #'(∀ (X ...) (ext-stlc:→ τ ... τ_out)) + #'(→ τ ... τ_out))))) + (define- g (Λ (X ...) (ext-stlc:λ ([x : τ] ...) e_ann))))] + [(define (f:id [x:id (~datum :) τ] ... (~datum →) τ_out) e) + #:with g (generate-temporary #'f) + #:with e_ann #'(add-expected e τ_out) + #'(begin- + (define-syntax f (make-rename-transformer (⊢ g : (→ τ ... τ_out)))) + (define- g (ext-stlc:λ ([x : τ] ...) e_ann)))]) + +; all λs have type (∀ (X ...) (→ τ_in ... τ_out)) +(define-typed-syntax λ #:datum-literals (:) + [(λ (x:id ...) e) ; no annotations, try to infer from outer ctx, ie an application + #:with given-τ-args (syntax-property stx 'given-τ-args) + #:fail-unless (syntax-e #'given-τ-args) ; no inferred types or annotations, so error + (format "input types for ~a could not be inferred; add annotations" + (syntax->datum stx)) + #:with (τ_arg ...) #'given-τ-args + #:with [fn- τ_fn] (infer+erase #'(ext-stlc:λ ([x : τ_arg] ...) e)) + (⊢ fn- : #,(add-orig #'(∀ () τ_fn) (get-orig #'τ_fn)))] + [(_ (x:id ...) ~! e) ; no annotations, couldnt infer from ctx (eg, unapplied lam), try to infer from body + #:with (xs- e- τ_res) (infer/ctx+erase #'([x : x] ...) #'e) + #:with env (get-env #'e-) + #:fail-unless (syntax-e #'env) + (format "input types for ~a could not be inferred; add annotations" + (syntax->datum stx)) + #:with (τ_arg ...) (stx-map (λ (y) (lookup y #'env)) #'xs-) + #:fail-unless (stx-andmap syntax-e #'(τ_arg ...)) + (format "some input types for ~a could not be inferred; add annotations" + (syntax->datum stx)) + ;; propagate up inferred types of variables + #:with res (add-env #'(λ- xs- e-) #'env) +; #:with [fn- τ_fn] (infer+erase #'(ext-stlc:λ ([x : x] ...) e)) + (⊢ res : #,(add-orig #'(∀ () (ext-stlc:→ τ_arg ... τ_res)) + #`(→ #,@(stx-map get-orig #'(τ_arg ... τ_res)))))] + ;(⊢ (λ- xs- e-) : (∀ () (ext-stlc:→ τ_arg ... τ_res)))] + [(λ . rst) + #:with [fn- τ_fn] (infer+erase #'(ext-stlc:λ . rst)) + (⊢ fn- : #,(add-orig #'(∀ () τ_fn) (get-orig #'τ_fn)))]) + +(define-typed-syntax infer:#%app #:export-as #%app + [(_ e_fn e_arg ...) ; infer args first + ; #:when (printf "args first ~a\n" (syntax->datum stx)) + #:with maybe-inferred-τs (with-handlers ([exn:fail:type:infer? (λ _ #f)]) + (infers+erase #'(e_arg ...))) + #:when (syntax-e #'maybe-inferred-τs) + #:with ([e_arg- τ_arg] ...) #'maybe-inferred-τs + #:with e_fn_anno (syntax-property #'e_fn 'given-τ-args #'(τ_arg ...)) +; #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn_anno as →) + #:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn_anno as ∀) + #:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity + (type-error #:src stx + #:msg (string-append + (format "~a (~a:~a) Wrong number of arguments given to function ~a.\n" + (syntax-source stx) (syntax-line stx) (syntax-column stx) + (syntax->datum #'e_fn)) + (format "Expected: ~a arguments with types: " + (stx-length #'(τ_inX ...))) + (string-join (stx-map type->str #'(τ_inX ...)) ", " #:after-last "\n") + "Given:\n" + (string-join + (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line + (syntax->datum #'(e_arg ...)) + (stx-map type->str #'(τ_arg ...))) + "\n"))) + #:with cs (add-constraints #'(X ...) '() #'([τ_inX τ_arg] ...)) + #:with (τ_in ... τ_out) (inst-types/cs #'(X ...) #'cs #'(τ_inX ... τ_outX)) + ; some code duplication + #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) + (type-error #:src stx + #:msg (string-append + (format "~a (~a:~a) Arguments to function ~a have wrong type(s).\n" + (syntax-source stx) (syntax-line stx) (syntax-column stx) + (syntax->datum #'e_fn)) + "Given:\n" + (string-join + (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line + (syntax->datum #'(e_arg ...)) + (stx-map type->str #'(τ_arg ...))) + "\n" #:after-last "\n") + (format "Expected: ~a arguments with type(s): " + (stx-length #'(τ_in ...))) + (string-join (stx-map type->str #'(τ_in ...)) ", "))) + ; propagate inferred types for variables up + #:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e_arg- ...)))) + #:with result-app (add-env #'(#%app- e_fn- e_arg- ...) #'env) + ;(⊢ (#%app- e_fn- e_arg- ...) : τ_out)] + (⊢ result-app : τ_out)] + [(_ e_fn e_arg ...) ; infer fn first ------------------------- ; TODO: remove code dup +; #:when (printf "fn first ~a\n" (syntax->datum stx)) + #:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn as ∀) + #:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity + (type-error #:src stx + #:msg (string-append + (format "~a (~a:~a) Wrong number of arguments given to function ~a.\n" + (syntax-source stx) (syntax-line stx) (syntax-column stx) + (syntax->datum #'e_fn)) + (format "Expected: ~a arguments with types: " + (stx-length #'(τ_inX ...))) + (string-join (stx-map type->str #'(τ_inX ...)) ", " #:after-last "\n") + "Given args: " + (string-join (map ~a (syntax->datum #'(e_arg ...))) ", "))) +; #:with ([e_arg- τ_arg] ...) #'(infers+erase #'(e_arg ...)) + #:with (cs ([e_arg- τ_arg] ...)) + (solve #'(X ...) #'(e_arg ...) #'(τ_inX ...)) + #:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e_arg- ...)))) + #:with (τ_in ... τ_out) (inst-types/cs #'(X ...) #'cs #'(τ_inX ... τ_outX)) + ; some code duplication + #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) + (string-append + (format "~a (~a:~a) Arguments to function ~a have wrong type(s).\n" + (syntax-source stx) (syntax-line stx) (syntax-column stx) + (syntax->datum #'e_fn)) + "Given:\n" + (string-join + (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line + (syntax->datum #'(e_arg ...)) + (stx-map type->str #'(τ_arg ...))) + "\n" #:after-last "\n") + (format "Expected: ~a arguments with type(s): " + (stx-length #'(τ_in ...))) + (string-join (stx-map type->str #'(τ_in ...)) ", ")) + #:with result-app (add-env #'(#%app- e_fn- e_arg- ...) #'env) + ;(⊢ (#%app- e_fn- e_arg- ...) : τ_out)]) + (⊢ result-app : τ_out)]) diff --git a/tapl/lam-testing.rkt b/macrotypes/examples/lam-testing.rkt diff --git a/tapl/mlish-do.rkt b/macrotypes/examples/mlish-do.rkt diff --git a/macrotypes/examples/mlish.rkt b/macrotypes/examples/mlish.rkt @@ -0,0 +1,1365 @@ +#lang s-exp macrotypes/typecheck +(require racket/fixnum racket/flonum + (for-syntax macrotypes/type-constraints macrotypes/variance-constraints)) + +(extends "ext-stlc.rkt" #:except #%app λ → + - void = zero? sub1 add1 not let let* and #%datum begin + #:rename [~→ ~ext-stlc:→]) +(reuse inst #:from "sysf.rkt") +(require (only-in "ext-stlc.rkt" → →?)) +(require (only-in "sysf.rkt" ~∀ ∀ ∀? Λ)) +(reuse × tup proj define-type-alias #:from "stlc+rec-iso.rkt") +(require (only-in "stlc+rec-iso.rkt" ~× ×?)) ; using current-type=? from here +(provide (rename-out [ext-stlc:and and] [ext-stlc:#%datum #%datum])) +(reuse member length reverse list-ref cons nil isnil head tail list #:from "stlc+cons.rkt") +(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list cons nil))) +(require (only-in "stlc+cons.rkt" ~List List? List)) +(provide List) +(reuse ref deref := Ref #:from "stlc+box.rkt") +(require (rename-in (only-in "stlc+reco+var.rkt" tup proj ×) + [tup rec] [proj get] [× ××])) +(provide rec get ××) +;; for pattern matching +(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list))) +(require (prefix-in stlc+tup: (only-in "stlc+tup.rkt" tup))) + +(module+ test + (require (for-syntax rackunit))) + +(provide → →/test match2 define-type) + +;; ML-like language +;; - top level recursive functions +;; - user-definable algebraic datatypes +;; - pattern matching +;; - (local) type inference + +;; creating possibly polymorphic types +;; ?∀ only wraps a type in a forall if there's at least one type variable +(define-syntax ?∀ + (lambda (stx) + (syntax-case stx () + [(?∀ () body) + #'body] + [(?∀ (X ...) body) + #'(∀ (X ...) body)]))) + +;; ?Λ only wraps an expression in a Λ if there's at least one type variable +(define-syntax ?Λ + (lambda (stx) + (syntax-case stx () + [(?Λ () body) + #'body] + [(?Λ (X ...) body) + #'(Λ (X ...) body)]))) + +(begin-for-syntax + ;; matching possibly polymorphic types + (define-syntax ~?∀ + (pattern-expander + (lambda (stx) + (syntax-case stx () + [(?∀ vars-pat body-pat) + #'(~or (~∀ vars-pat body-pat) + (~and (~not (~∀ _ _)) + (~parse vars-pat #'()) + body-pat))])))) + + ;; find-free-Xs : (Stx-Listof Id) Type -> (Listof Id) + ;; finds the free Xs in the type + (define (find-free-Xs Xs ty) + (for/list ([X (in-list (stx->list Xs))] + #:when (stx-contains-id? ty X)) + X)) + + ;; solve for Xs by unifying quantified fn type with the concrete types of stx's args + ;; stx = the application stx = (#%app e_fn e_arg ...) + ;; tyXs = input and output types from fn type + ;; ie (typeof e_fn) = (-> . tyXs) + ;; It infers the types of arguments from left-to-right, + ;; and it expands and returns all of the arguments. + ;; It returns list of 3 values if successful, else throws a type error + ;; - a list of all the arguments, expanded + ;; - a list of all the type variables + ;; - the constraints for substituting the types + (define (solve Xs tyXs stx) + (syntax-parse tyXs + [(τ_inX ... τ_outX) + ;; generate initial constraints with expected type and τ_outX + #:with (~?∀ Vs expected-ty) (and (get-expected-type stx) + ((current-type-eval) (get-expected-type stx))) + (define initial-cs + (if (and (syntax-e #'expected-ty) (stx-null? #'Vs)) + (add-constraints Xs '() (list (list #'expected-ty #'τ_outX))) + #'())) + (syntax-parse stx + [(_ e_fn . args) + (define-values (as- cs) + (for/fold ([as- null] [cs initial-cs]) + ([a (in-list (syntax->list #'args))] + [tyXin (in-list (syntax->list #'(τ_inX ...)))]) + (define ty_in (inst-type/cs Xs cs tyXin)) + (define/with-syntax [a- ty_a] + (infer+erase (if (empty? (find-free-Xs Xs ty_in)) + (add-expected-ty a ty_in) + a))) + (values + (cons #'a- as-) + (add-constraints Xs cs (list (list ty_in #'ty_a)) + (list (list (inst-type/cs/orig + Xs cs ty_in + (λ (id1 id2) + (equal? (syntax->datum id1) + (syntax->datum id2)))) + #'ty_a)))))) + + (list (reverse as-) Xs cs)])])) + + (define (raise-app-poly-infer-error stx expected-tys given-tys e_fn) + (type-error #:src stx + #:msg (mk-app-err-msg stx #:expected expected-tys #:given given-tys + #:note (format "Could not infer instantiation of polymorphic function ~a." + (syntax->datum (get-orig e_fn)))))) + + ;; covariant-Xs? : Type -> Bool + ;; Takes a possibly polymorphic type, and returns true if all of the + ;; type variables are in covariant positions within the type, false + ;; otherwise. + (define (covariant-Xs? ty) + (syntax-parse ((current-type-eval) ty) + [(~?∀ Xs ty) + (for/and ([X (in-list (syntax->list #'Xs))]) + (covariant-X? X #'ty))])) + + ;; find-X-variance : Id Type [Variance] -> Variance + ;; Returns the variance of X within the type ty + (define (find-X-variance X ty [ctxt-variance covariant]) + (match (find-variances (list X) ty ctxt-variance) + [(list variance) variance])) + + ;; covariant-X? : Id Type -> Bool + ;; Returns true if every place X appears in ty is a covariant position, false otherwise. + (define (covariant-X? X ty) + (variance-covariant? (find-X-variance X ty covariant))) + + ;; contravariant-X? : Id Type -> Bool + ;; Returns true if every place X appears in ty is a contravariant position, false otherwise. + (define (contravariant-X? X ty) + (variance-contravariant? (find-X-variance X ty covariant))) + + ;; find-variances : (Listof Id) Type [Variance] -> (Listof Variance) + ;; Returns the variances of each of the Xs within the type ty, + ;; where it's already within a context represented by ctxt-variance. + (define (find-variances Xs ty [ctxt-variance covariant]) + (syntax-parse ty + [A:id + (for/list ([X (in-list Xs)]) + (cond [(free-identifier=? X #'A) ctxt-variance] + [else irrelevant]))] + [(~Any tycons) + (make-list (length Xs) irrelevant)] + [(~?∀ () (~Any tycons τ ...)) + #:when (get-arg-variances #'tycons) + #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) + (define τ-ctxt-variances + (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) + (variance-compose ctxt-variance arg-variance))) + (for/fold ([acc (make-list (length Xs) irrelevant)]) + ([τ (in-list (syntax->list #'[τ ...]))] + [τ-ctxt-variance (in-list τ-ctxt-variances)]) + (map variance-join + acc + (find-variances Xs τ τ-ctxt-variance)))] + [ty + #:when (not (for/or ([X (in-list Xs)]) + (stx-contains-id? #'ty X))) + (make-list (length Xs) irrelevant)] + [_ (make-list (length Xs) invariant)])) + + ;; find-variances/exprs : (Listof Id) Type [Variance-Expr] -> (Listof Variance-Expr) + ;; Like find-variances, but works with Variance-Exprs instead of + ;; concrete variance values. + (define (find-variances/exprs Xs ty [ctxt-variance covariant]) + (syntax-parse ty + [A:id + (for/list ([X (in-list Xs)]) + (cond [(free-identifier=? X #'A) ctxt-variance] + [else irrelevant]))] + [(~Any tycons) + (make-list (length Xs) irrelevant)] + [(~?∀ () (~Any tycons τ ...)) + #:when (get-arg-variances #'tycons) + #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) + (define τ-ctxt-variances + (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) + (variance-compose/expr ctxt-variance arg-variance))) + (for/fold ([acc (make-list (length Xs) irrelevant)]) + ([τ (in-list (syntax->list #'[τ ...]))] + [τ-ctxt-variance (in-list τ-ctxt-variances)]) + (map variance-join/expr + acc + (find-variances/exprs Xs τ τ-ctxt-variance)))] + [ty + #:when (not (for/or ([X (in-list Xs)]) + (stx-contains-id? #'ty X))) + (make-list (length Xs) irrelevant)] + [_ (make-list (length Xs) invariant)])) + + ;; current-variance-constraints : (U False (Mutable-Setof Variance-Constraint)) + ;; If this is false, that means that infer-variances should return concrete Variance values. + ;; If it's a mutable set, that means that infer-variances should mutate it and return false, + ;; and type constructors should return the list of variance vars. + (define current-variance-constraints (make-parameter #false)) + + ;; infer-variances : + ;; ((-> Stx) -> Stx) (Listof Variance-Var) (Listof Id) (Listof Type-Stx) + ;; -> (U False (Listof Variance)) + (define (infer-variances with-variance-vars-okay variance-vars Xs τs) + (cond + [(current-variance-constraints) + (define variance-constraints (current-variance-constraints)) + (define variance-exprs + (for/fold ([exprs (make-list (length variance-vars) irrelevant)]) + ([τ (in-list τs)]) + (define/syntax-parse (~?∀ Xs* τ*) + ;; This can mutate variance-constraints! + ;; This avoids causing an infinite loop by having the type + ;; constructors provide with-variance-vars-okay so that within + ;; this call they declare variance-vars for their variances. + (with-variance-vars-okay + (λ () ((current-type-eval) #`(∀ #,Xs #,τ))))) + (map variance-join/expr + exprs + (find-variances/exprs (syntax->list #'Xs*) #'τ* covariant)))) + (for ([var (in-list variance-vars)] + [expr (in-list variance-exprs)]) + (set-add! variance-constraints (variance= var expr))) + #f] + [else + (define variance-constraints (mutable-set)) + ;; This will mutate variance-constraints! + (parameterize ([current-variance-constraints variance-constraints]) + (infer-variances with-variance-vars-okay variance-vars Xs τs)) + (define mapping + (solve-variance-constraints variance-vars + (set->list variance-constraints) + (variance-mapping))) + (for/list ([var (in-list variance-vars)]) + (variance-mapping-ref mapping var))])) + + ;; make-arg-variances-proc : + ;; (Listof Variance-Var) (Listof Id) (Listof Type-Stx) -> (Stx -> (U (Listof Variance) + ;; (Listof Variance-Var))) + (define (make-arg-variances-proc arg-variance-vars Xs τs) + ;; variance-vars-okay? : (Parameterof Boolean) + ;; A parameter that determines whether or not it's okay for + ;; this type constructor to return a list of Variance-Vars + ;; for the variances. + (define variance-vars-okay? (make-parameter #false)) + ;; with-variance-vars-okay : (-> A) -> A + (define (with-variance-vars-okay f) + (parameterize ([variance-vars-okay? #true]) + (f))) + ;; arg-variances : (Boxof (U False (List Variance ...))) + ;; If false, means that the arg variances have not been + ;; computed yet. Otherwise, stores the complete computed + ;; variances for the arguments to this type constructor. + (define arg-variances (box #f)) + ;; arg-variances-proc : Stx -> (U (Listof Variance) (Listof Variance-Var)) + (define (arg-variance-proc stx) + (or (unbox arg-variances) + (cond + [(variance-vars-okay?) + arg-variance-vars] + [else + (define inferred-variances + (infer-variances + with-variance-vars-okay + arg-variance-vars + Xs + τs)) + (cond [inferred-variances + (set-box! arg-variances inferred-variances) + inferred-variances] + [else + arg-variance-vars])]))) + arg-variance-proc) + + ;; compute unbound tyvars in one unexpanded type ty + (define (compute-tyvar1 ty) + (syntax-parse ty + [X:id #'(X)] + [() #'()] + [(C t ...) (stx-appendmap compute-tyvar1 #'(t ...))])) + ;; computes unbound ids in (unexpanded) tys, to be used as tyvars + (define (compute-tyvars tys) + (define Xs (stx-appendmap compute-tyvar1 tys)) + (filter + (lambda (X) + (with-handlers + ([exn:fail:syntax:unbound? (lambda (e) #t)] + [exn:fail:type:infer? (lambda (e) #t)]) + (let ([X+ ((current-type-eval) X)]) + (not (or (tyvar? X+) (type? X+)))))) + (stx-remove-dups Xs)))) + +;; define -------------------------------------------------- +;; for function defs, define infers type variables +;; - since the order of the inferred type variables depends on expansion order, +;; which is not known to programmers, to make the result slightly more +;; intuitive, we arbitrarily sort the inferred tyvars lexicographically +(define-typed-syntax define + [(define x:id e) + #:with (e- τ) (infer+erase #'e) + #:with y (generate-temporary) + #'(begin- + (define-syntax x (make-rename-transformer (⊢ y : τ))) + (define- y e-))] + ; explicit "forall" + [(define Ys (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) + e_body ... e) + #:when (brace? #'Ys) + ;; TODO; remove this code duplication + #:with g (add-orig (generate-temporary #'f) #'f) + #:with e_ann #'(add-expected e τ_out) + #:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out)) + ;; TODO: check that specified return type is correct + ;; - currently cannot do it here; to do the check here, need all types of + ;; top-lvl fns, since they can call each other + #:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) + ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...))) + #`(begin- + (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) + (define- g + (Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))] + ;; alternate type sig syntax, after parameter names + [(define (f:id x:id ...) (~datum :) ty ... (~or (~datum ->) (~datum →)) ty_out . b) + #'(define (f [x : ty] ... -> ty_out) . b)] + [(define (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) + e_body ... e) + #:with Ys (compute-tyvars #'(τ ... τ_out)) + #:with g (add-orig (generate-temporary #'f) #'f) + #:with e_ann #'(add-expected e τ_out) ; must be macro bc t_out may have unbound tvs + #:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out)) + ;; TODO: check that specified return type is correct + ;; - currently cannot do it here; to do the check here, need all types of + ;; top-lvl fns, since they can call each other + #:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) + (set-stx-prop/preserved + ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...))) + 'orig + (list #'(→ τ+orig ...))) + #`(begin- + (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) + (define- g + (?Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]) + +;; define-type ----------------------------------------------- +;; TODO: should validate τ as part of define-type definition (before it's used) +;; - not completely possible, since some constructors may not be defined yet, +;; ie, mutually recursive datatypes +;; for now, validate types but punt if encountering unbound ids +(define-syntax (define-type stx) + (syntax-parse stx + [(define-type Name:id . rst) + #:with NewName (generate-temporary #'Name) + #:with Name2 (add-orig #'(NewName) #'Name) + #`(begin- + (define-type Name2 . #,(subst #'Name2 #'Name #'rst)) + (stlc+rec-iso:define-type-alias Name Name2))] + [(define-type (Name:id X:id ...) + ;; constructors must have the form (Cons τ ...) + ;; but the first ~or clause accepts 0-arg constructors as ids; + ;; the ~and is a workaround to bind the duplicate Cons ids (see Ryan's email) + (~and (~or (~and IdCons:id + (~parse (Cons [fld (~datum :) τ] ...) #'(IdCons))) + (Cons [fld (~datum :) τ] ...) + (~and (Cons τ ...) + (~parse (fld ...) (generate-temporaries #'(τ ...)))))) ...) + ;; validate tys + #:with (ty_flat ...) (stx-flatten #'((τ ...) ...)) + #:with (_ _ (_ _ (_ _ (_ _ ty+ ...)))) + (with-handlers + ([exn:fail:syntax:unbound? + (λ (e) + (define X (stx-car (exn:fail:syntax-exprs e))) + #`(lambda () (let-syntax () (let-syntax () (#%app void unbound)))))]) + (expand/df + #`(lambda (X ...) + (let-syntax + ([Name + (syntax-parser + [(_ X ...) (mk-type #'void)] + [stx + (type-error + #:src #'stx + #:msg + (format "Improper use of constructor ~a; expected ~a args, got ~a" + (syntax->datum #'Name) (stx-length #'(X ...)) + (stx-length (stx-cdr #'stx))))])] + [X (make-rename-transformer (⊢ X #%type))] ...) + (void ty_flat ...))))) + #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...))) + (stx-map + (lambda (t+ t) (unless (type? t+) + (type-error #:src t + #:msg "~a is not a valid type" t))) + #'(ty+ ...) #'(ty_flat ...))) + #:with NameExpander (format-id #'Name "~~~a" #'Name) + #:with NameExtraInfo (format-id #'Name "~a-extra-info" #'Name) + #:with (StructName ...) (generate-temporaries #'(Cons ...)) + #:with ((e_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) + #:with ((e_arg- ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) + #:with ((τ_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) + #:with ((exposed-acc ...) ...) + (stx-map + (λ (C fs) (stx-map (λ (f) (format-id C "~a-~a" C f)) fs)) + #'(Cons ...) #'((fld ...) ...)) + #:with ((acc ...) ...) (stx-map (λ (S fs) (stx-map (λ (f) (format-id S "~a-~a" S f)) fs)) + #'(StructName ...) #'((fld ...) ...)) + #:with (Cons? ...) (stx-map mk-? #'(StructName ...)) + #:with (exposed-Cons? ...) (stx-map mk-? #'(Cons ...)) + #`(begin- + (define-syntax (NameExtraInfo stx) + (syntax-parse stx + [(_ X ...) #'(('Cons 'StructName Cons? [acc τ] ...) ...)])) + (begin-for-syntax + ;; arg-variance-vars : (List Variance-Var ...) + (define arg-variance-vars + (list (variance-var (syntax-e (generate-temporary 'X))) ...))) + (define-type-constructor Name + #:arity = #,(stx-length #'(X ...)) + #:arg-variances (make-arg-variances-proc arg-variance-vars + (list #'X ...) + (list #'τ ... ...)) + #:extra-info 'NameExtraInfo + #:no-provide) + (struct- StructName (fld ...) #:reflection-name 'Cons #:transparent) ... + (define-syntax (exposed-acc stx) ; accessor for records + (syntax-parse stx + [_:id (⊢ acc (?∀ (X ...) (ext-stlc:→ (Name X ...) τ)))] + [(o . rst) ; handle if used in fn position + #:with app (datum->syntax #'o '#%app) + #`(app + #,(assign-type #'acc #'(?∀ (X ...) (ext-stlc:→ (Name X ...) τ))) + . rst)])) ... ... + (define-syntax (exposed-Cons? stx) ; predicates for each variant + (syntax-parse stx + [_:id (⊢ Cons? (?∀ (X ...) (ext-stlc:→ (Name X ...) Bool)))] + [(o . rst) ; handle if used in fn position + #:with app (datum->syntax #'o '#%app) + #`(app + #,(assign-type #'Cons? #'(?∀ (X ...) (ext-stlc:→ (Name X ...) Bool))) + . rst)])) ... + (define-syntax (Cons stx) + (syntax-parse stx + ; no args and not polymorphic + [C:id #:when (and (stx-null? #'(X ...)) (stx-null? #'(τ ...))) #'(C)] + ; no args but polymorphic, check inferred type + [C:id + #:when (stx-null? #'(τ ...)) + #:with τ-expected (syntax-property #'C 'expected-type) + #:fail-unless (syntax-e #'τ-expected) + (raise + (exn:fail:type:infer + (string-append + (format "TYPE-ERROR: ~a (~a:~a): " + (syntax-source stx) (syntax-line stx) (syntax-column stx)) + (format "cannot infer type of ~a; add annotations" + (syntax->datum #'C))) + (current-continuation-marks))) + #:with (NameExpander τ-expected-arg (... ...)) ((current-type-eval) #'τ-expected) + #'(C {τ-expected-arg (... ...)})] + [_:id (⊢ StructName (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))] ; HO fn + [(C τs e_arg ...) + #:when (brace? #'τs) ; commit to this clause + #:with {~! τ_X:type (... ...)} #'τs + #:with (τ_in:type (... ...)) ; instantiated types + (stx-map + (λ (t) (substs #'(τ_X.norm (... ...)) #'(X ...) t)) + #'(τ ...)) + #:with ([e_arg- τ_arg] ...) + (stx-map + (λ (e τ_e) + (infer+erase (set-stx-prop/preserved e 'expected-type τ_e))) + #'(e_arg ...) #'(τ_in.norm (... ...))) + #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in.norm (... ...))) + (mk-app-err-msg (syntax/loc stx (#%app C e_arg ...)) + #:expected #'(τ_in.norm (... ...)) #:given #'(τ_arg ...) + #:name (format "constructor ~a" 'Cons)) + (⊢ (StructName e_arg- ...) : (Name τ_X (... ...)))] + [(C . args) ; no type annotations, must infer instantiation + #:with StructName/ty + (set-stx-prop/preserved + (⊢ StructName : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...)))) + 'orig + (list #'C)) + ; stx/loc transfers expected-type + (syntax/loc stx (mlish:#%app StructName/ty . args))])) + ...)])) + +;; match -------------------------------------------------- +(begin-for-syntax + (define (get-ctx pat ty) + (unify-pat+ty (list pat ty))) + (define (unify-pat+ty pat+ty) + (syntax-parse pat+ty + [(pat ty) #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) + (syntax-parse #'pat + [{(~datum _)} #'()] + [{(~literal stlc+cons:nil)} #'()] + [{A:id} ; disambiguate 0-arity constructors (that don't need parens) + #:when (get-extra-info #'ty) + #'()] + ;; comma tup syntax always has parens + [{(~and ps (p1 (unq p) ...))} + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + (unify-pat+ty #'(ps ty))] + [{p ...} + (unify-pat+ty #'((p ...) ty))])] ; pair + [((~datum _) ty) #'()] + [((~or (~literal stlc+cons:nil)) ty) #'()] + [(A:id ty) ; disambiguate 0-arity constructors (that don't need parens) + #:with (_ (_ (_ C) . _) ...) (get-extra-info #'ty) + #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) + #'()] + [(x:id ty) #'((x ty))] + [((p1 (unq p) ...) ty) ; comma tup stx + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + #:with (~× t ...) #'ty + #:with (pp ...) #'(p1 p ...) + (unifys #'([pp t] ...))] + [(((~literal stlc+tup:tup) p ...) ty) ; tup + #:with (~× t ...) #'ty + (unifys #'([p t] ...))] + [(((~literal stlc+cons:list) p ...) ty) ; known length list + #:with (~List t) #'ty + (unifys #'([p t] ...))] + [(((~seq p (~datum ::)) ... rst) ty) ; nicer cons stx + #:with (~List t) #'ty + (unifys #'([p t] ... [rst ty]))] + [(((~literal stlc+cons:cons) p ps) ty) ; arb length list + #:with (~List t) #'ty + (unifys #'([p t] [ps ty]))] + [((Name p ...) ty) + #:with (_ (_ Cons) _ _ [_ _ τ] ...) + (stx-findf + (syntax-parser + [(_ 'C . rst) + (equal? (syntax->datum #'Name) (syntax->datum #'C))]) + (stx-cdr (get-extra-info #'ty))) + (unifys #'([p τ] ...))] + [p+t #:fail-when #t (format "could not unify ~a" (syntax->datum #'p+t)) + #'()])) + (define (unifys p+tys) (stx-appendmap unify-pat+ty p+tys)) + + (define (compile-pat p ty) + (syntax-parse p + [pat #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) + (syntax-parse #'pat + [{(~datum _)} #'_] + [{(~literal stlc+cons:nil)} (syntax/loc p (list))] + [{A:id} ; disambiguate 0-arity constructors (that don't need parens) + #:when (get-extra-info ty) + (compile-pat #'(A) ty)] + ;; comma tup stx always has parens + [{(~and ps (p1 (unq p) ...))} + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + (compile-pat #'ps ty)] + [{pat ...} (compile-pat (syntax/loc p (pat ...)) ty)])] + [(~datum _) #'_] + [(~literal stlc+cons:nil) ; nil + #'(list)] + [A:id ; disambiguate 0-arity constructors (that don't need parens) + #:with (_ (_ (_ C) . _) ...) (get-extra-info ty) + #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) + (compile-pat #'(A) ty)] + [x:id p] + [(p1 (unq p) ...) ; comma tup stx + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + #:with (~× t ...) ty + #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'(p1 p ...) #'(t ...)) + #'(list p- ...)] + [((~literal stlc+tup:tup) . pats) + #:with (~× . tys) ty + #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'pats #'tys) + (syntax/loc p (list p- ...))] + [((~literal stlc+cons:list) . ps) + #:with (~List t) ty + #:with (p- ...) (stx-map (lambda (p) (compile-pat p #'t)) #'ps) + (syntax/loc p (list p- ...))] + [((~seq pat (~datum ::)) ... last) ; nicer cons stx + #:with (~List t) ty + #:with (p- ...) (stx-map (lambda (pp) (compile-pat pp #'t)) #'(pat ...)) + #:with last- (compile-pat #'last ty) + (syntax/loc p (list-rest p- ... last-))] + [((~literal stlc+cons:cons) p ps) + #:with (~List t) ty + #:with p- (compile-pat #'p #'t) + #:with ps- (compile-pat #'ps ty) + #'(cons p- ps-)] + [(Name . pats) + #:with (_ (_ Cons) (_ StructName) _ [_ _ τ] ...) + (stx-findf + (syntax-parser + [(_ 'C . rst) + (equal? (syntax->datum #'Name) (syntax->datum #'C))]) + (stx-cdr (get-extra-info ty))) + #:with (p- ...) (stx-map compile-pat #'pats #'(τ ...)) + (syntax/loc p (StructName p- ...))])) + + ;; pats = compiled pats = racket pats + (define (check-exhaust pats ty) + (define (else-pat? p) + (syntax-parse p [(~literal _) #t] [_ #f])) + (define (nil-pat? p) + (syntax-parse p + [((~literal list)) #t] + [_ #f])) + (define (non-nil-pat? p) + (syntax-parse p + [((~literal list-rest) . rst) #t] + [((~literal cons) . rst) #t] + [_ #f])) + (define (tup-pat? p) + (syntax-parse p + [((~literal list) . _) #t] [_ #f])) + (cond + [(or (stx-ormap else-pat? pats) (stx-ormap identifier? pats)) #t] + [(List? ty) ; lists + (unless (stx-ormap nil-pat? pats) + (error 'match2 (let ([last (car (stx-rev pats))]) + (format "(~a:~a) missing nil clause for list expression" + (syntax-line last) (syntax-column last))))) + (unless (stx-ormap non-nil-pat? pats) + (error 'match2 (let ([last (car (stx-rev pats))]) + (format "(~a:~a) missing clause for non-empty, arbitrary length list" + (syntax-line last) (syntax-column last))))) + #t] + [(×? ty) ; tuples + (unless (stx-ormap tup-pat? pats) + (error 'match2 (let ([last (car (stx-rev pats))]) + (format "(~a:~a) missing pattern for tuple expression" + (syntax-line last) (syntax-column last))))) + (syntax-parse pats + [((_ p ...) ...) + (syntax-parse ty + [(~× t ...) + (apply stx-andmap + (lambda (t . ps) (check-exhaust ps t)) + #'(t ...) + (syntax->list #'((p ...) ...)))])])] + [else ; algebraic datatypes + (syntax-parse (get-extra-info ty) + [(_ (_ (_ C) (_ Cstruct) . rst) ...) + (syntax-parse pats + [((Cpat _ ...) ...) + (define Cs (syntax->datum #'(C ...))) + (define Cstructs (syntax->datum #'(Cstruct ...))) + (define Cpats (syntax->datum #'(Cpat ...))) + (unless (set=? Cstructs Cpats) + (error 'match2 + (let ([last (car (stx-rev pats))]) + (format "(~a:~a) clauses not exhaustive; missing: ~a" + (syntax-line last) (syntax-column last) + (string-join + (for/list ([C Cs][Cstr Cstructs] #:unless (member Cstr Cpats)) + (symbol->string C)) + ", "))))) + #t])] + [_ #t])])) + + ;; TODO: do get-ctx and compile-pat in one pass + (define (compile-pats pats ty) + (stx-map (lambda (p) (list (get-ctx p ty) (compile-pat p ty))) pats)) + ) + +(define-syntax (match2 stx) + (syntax-parse stx #:datum-literals (with) + [(match2 e with . clauses) + #:fail-when (null? (syntax->list #'clauses)) "no clauses" + #:with [e- τ_e] (infer+erase #'e) + (syntax-parse #'clauses #:datum-literals (->) + [([(~seq p ...) -> e_body] ...) + #:with (pat ...) (stx-map ; use brace to indicate root pattern + (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc stx {pp ...})])) + #'((p ...) ...)) + #:with ([(~and ctx ([x ty] ...)) pat-] ...) (compile-pats #'(pat ...) #'τ_e) + #:with ty-expected (get-expected-type stx) + #:with ([(x- ...) e_body- ty_body] ...) + (stx-map + infer/ctx+erase + #'(ctx ...) #'((add-expected e_body ty-expected) ...)) + #:when (check-exhaust #'(pat- ...) #'τ_e) + #:with τ_out (stx-foldr (current-join) (stx-car #'(ty_body ...)) (stx-cdr #'(ty_body ...))) + (⊢ (match- e- [pat- (let- ([x- x] ...) e_body-)] ...) : τ_out) + ])])) + +(define-typed-syntax match #:datum-literals (with) + [(match e with . clauses) + #:fail-when (null? (syntax->list #'clauses)) "no clauses" + #:with [e- τ_e] (infer+erase #'e) + #:with t_expect (syntax-property stx 'expected-type) ; propagate inferred type + (cond + [(×? #'τ_e) ;; e is tuple + (syntax-parse #'clauses #:datum-literals (->) + [([x ... -> e_body]) + #:with (~× ty ...) #'τ_e + #:fail-unless (stx-length=? #'(ty ...) #'(x ...)) + "match clause pattern not compatible with given tuple" + #:with [(x- ...) e_body- ty_body] (infer/ctx+erase #'([x ty] ...) + #'(add-expected e_body t_expect)) + #:with (acc ...) (for/list ([(a i) (in-indexed (syntax->list #'(x ...)))]) + #`(lambda- (s) (list-ref- s #,(datum->syntax #'here i)))) + #:with z (generate-temporary) + (⊢ (let- ([z e-]) + (let- ([x- (acc z)] ...) e_body-)) + : ty_body)])] + [(List? #'τ_e) ;; e is List + (syntax-parse #'clauses #:datum-literals (-> ::) + [([(~or (~and (~and xs [x ...]) (~parse rst (generate-temporary))) + (~and (~seq (~seq x ::) ... rst:id) (~parse xs #'()))) + -> e_body] ...+) + #:fail-unless (stx-ormap + (lambda (xx) (and (brack? xx) (zero? (stx-length xx)))) + #'(xs ...)) + "match: missing empty list case" + #:fail-when (and (stx-andmap brack? #'(xs ...)) + (= 1 (stx-length #'(xs ...)))) + "match: missing non-empty list case" + #:with (~List ty) #'τ_e + #:with ([(x- ... rst-) e_body- ty_body] ...) + (stx-map (lambda (ctx e) (infer/ctx+erase ctx e)) + #'(([x ty] ... [rst (List ty)]) ...) #'((add-expected e_body t_expect) ...)) + #:with τ_out (stx-foldr (current-join) (stx-car #'(ty_body ...)) (stx-cdr #'(ty_body ...))) + #:with (len ...) (stx-map (lambda (p) #`#,(stx-length p)) #'((x ...) ...)) + #:with (lenop ...) (stx-map (lambda (p) (if (brack? p) #'=- #'>=-)) #'(xs ...)) + #:with (pred? ...) (stx-map + (lambda (l lo) #`(λ- (lst) (#,lo (length- lst) #,l))) + #'(len ...) #'(lenop ...)) + #:with ((acc1 ...) ...) (stx-map + (lambda (xs) + (for/list ([(x i) (in-indexed (syntax->list xs))]) + #`(lambda- (lst) (list-ref- lst #,(datum->syntax #'here i))))) + #'((x ...) ...)) + #:with (acc2 ...) (stx-map (lambda (l) #`(lambda- (lst) (list-tail- lst #,l))) #'(len ...)) + (⊢ (let- ([z e-]) + (cond- + [(pred? z) + (let- ([x- (acc1 z)] ... [rst- (acc2 z)]) e_body-)] ...)) + : τ_out)])] + [else ;; e is variant + (syntax-parse #'clauses #:datum-literals (->) + [([Clause:id x:id ... + (~optional (~seq #:when e_guard) #:defaults ([e_guard #'(ext-stlc:#%datum . #t)])) + -> e_c_un] ...+) ; un = unannotated with expected ty + ;; length #'clauses may be > length #'info, due to guards + #:with info-body (get-extra-info #'τ_e) + #:with (_ (_ (_ ConsAll) . _) ...) #'info-body + #:fail-unless (set=? (syntax->datum #'(Clause ...)) + (syntax->datum #'(ConsAll ...))) + (type-error #:src stx + #:msg (string-append + "match: clauses not exhaustive; missing: " + (string-join + (map symbol->string + (set-subtract + (syntax->datum #'(ConsAll ...)) + (syntax->datum #'(Clause ...)))) + ", "))) + #:with ((_ _ _ Cons? [_ acc τ] ...) ...) + (map ; ok to compare symbols since clause names can't be rebound + (lambda (Cl) + (stx-findf + (syntax-parser + [(_ 'C . rst) (equal? Cl (syntax->datum #'C))]) + (stx-cdr #'info-body))) ; drop leading #%app + (syntax->datum #'(Clause ...))) + ;; this commented block experiments with expanding to unsafe ops + ;; #:with ((acc ...) ...) (stx-map + ;; (lambda (accs) + ;; (for/list ([(a i) (in-indexed (syntax->list accs))]) + ;; #`(lambda (s) (unsafe-struct*-ref s #,(datum->syntax #'here i))))) + ;; #'((acc-fn ...) ...)) + #:with (e_c ...+) (stx-map (lambda (ec) (add-expected-ty ec #'t_expect)) #'(e_c_un ...)) + #:with (((x- ...) (e_guard- e_c-) (τ_guard τ_ec)) ...) + (stx-map + (λ (bs eg+ec) (infers/ctx+erase bs eg+ec)) + #'(([x : τ] ...) ...) #'((e_guard e_c) ...)) + #:fail-unless (and (same-types? #'(τ_guard ...)) + (Bool? (stx-car #'(τ_guard ...)))) + "guard expression(s) must have type bool" + #:with τ_out (stx-foldr (current-join) (stx-car #'(τ_ec ...)) (stx-cdr #'(τ_ec ...))) + #:with z (generate-temporary) ; dont duplicate eval of test expr + (⊢ (let- ([z e-]) + (cond- + [(and- (Cons? z) + (let- ([x- (acc z)] ...) e_guard-)) + (let- ([x- (acc z)] ...) e_c-)] ...)) + : τ_out)])])]) + +; special arrow that computes free vars; for use with tests +; (because we can't write explicit forall +(define-syntax →/test + (syntax-parser + [(→/test (~and Xs (X:id ...)) . rst) + #:when (brace? #'Xs) + #'(?∀ (X ...) (ext-stlc:→ . rst))] + [(→/test . rst) + #:with Xs (compute-tyvars #'rst) + #'(?∀ Xs (ext-stlc:→ . rst))])) + +; redefine these to use lifted → +(define-primop + : (→ Int Int Int)) +(define-primop - : (→ Int Int Int)) +(define-primop * : (→ Int Int Int)) +(define-primop max : (→ Int Int Int)) +(define-primop min : (→ Int Int Int)) +(define-primop void : (→ Unit)) +(define-primop = : (→ Int Int Bool)) +(define-primop <= : (→ Int Int Bool)) +(define-primop < : (→ Int Int Bool)) +(define-primop > : (→ Int Int Bool)) +(define-primop modulo : (→ Int Int Int)) +(define-primop zero? : (→ Int Bool)) +(define-primop sub1 : (→ Int Int)) +(define-primop add1 : (→ Int Int)) +(define-primop not : (→ Bool Bool)) +(define-primop abs : (→ Int Int)) +(define-primop even? : (→ Int Bool)) +(define-primop odd? : (→ Int Bool)) + +; all λs have type (?∀ (X ...) (→ τ_in ... τ_out)) +(define-typed-syntax λ + [(λ (x:id ...+) body) + #:with (~?∀ Xs expected) (get-expected-type stx) + #:do [(unless (→? #'expected) + (type-error #:src stx #:msg "λ parameters must have type annotations"))] + #:with (~ext-stlc:→ arg-ty ... body-ty) #'expected + #:do [(unless (stx-length=? #'[x ...] #'[arg-ty ...]) + (type-error #:src stx #:msg + (format "expected a function of ~a arguments, got one with ~a arguments" + (stx-length #'[arg-ty ...] #'[x ...]))))] + #`(?Λ Xs (ext-stlc:λ ([x : arg-ty] ...) #,(add-expected-ty #'body #'body-ty)))] + [(λ args body) + #:with (~?∀ () (~ext-stlc:→ arg-ty ... body-ty)) (get-expected-type stx) + #`(?Λ () (ext-stlc:λ args #,(add-expected-ty #'body #'body-ty)))] + [(λ (~and x+tys ([_ (~datum :) ty] ...)) . body) + #:with Xs (compute-tyvars #'(ty ...)) + ;; TODO is there a way to have λs that refer to ids defined after them? + #'(?Λ Xs (ext-stlc:λ x+tys . body))]) + + +;; #%app -------------------------------------------------- +(define-typed-syntax mlish:#%app #:export-as #%app + [(_ e_fn . e_args) + ;; ) compute fn type (ie ∀ and →) + #:with [e_fn- (~?∀ Xs (~ext-stlc:→ . tyX_args))] (infer+erase #'e_fn) + (cond + [(stx-null? #'Xs) + (syntax-parse #'(e_args tyX_args) + [((e_arg ...) (τ_inX ... _)) + #:fail-unless (stx-length=? #'(e_arg ...) #'(τ_inX ...)) + (mk-app-err-msg stx #:expected #'(τ_inX ...) + #:note "Wrong number of arguments.") + #:with e_fn/ty (⊢ e_fn- : (ext-stlc:→ . tyX_args)) + #'(ext-stlc:#%app e_fn/ty (add-expected e_arg τ_inX) ...)])] + [else + ;; ) solve for type variables Xs + (define/with-syntax ((e_arg- ...) Xs* cs) (solve #'Xs #'tyX_args stx)) + ;; ) instantiate polymorphic function type + (syntax-parse (inst-types/cs #'Xs* #'cs #'tyX_args) + [(τ_in ... τ_out) ; concrete types + #:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out) + ;; ) arity check + #:fail-unless (stx-length=? #'(τ_in ...) #'e_args) + (mk-app-err-msg stx #:expected #'(τ_in ...) + #:note "Wrong number of arguments.") + ;; ) compute argument types + #:with (τ_arg ...) (stx-map typeof #'(e_arg- ...)) + ;; ) typecheck args + #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) + (mk-app-err-msg stx + #:given #'(τ_arg ...) + #:expected + (stx-map + (lambda (tyin) + (define old-orig (get-orig tyin)) + (define new-orig + (and old-orig + (substs + (stx-map get-orig (lookup-Xs/keep-unsolved #'Xs* #'cs)) + #'Xs* + old-orig + (lambda (x y) + (equal? (syntax->datum x) (syntax->datum y)))))) + (set-stx-prop/preserved tyin 'orig (list new-orig))) + #'(τ_in ...))) + #:with τ_out* (if (stx-null? #'(unsolved-X ...)) + #'τ_out + (syntax-parse #'τ_out + [(~?∀ (Y ...) τ_out) + (unless (→? #'τ_out) + (raise-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn)) + (for ([X (in-list (syntax->list #'(unsolved-X ...)))]) + (unless (covariant-X? X #'τ_out) + (raise-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn))) + #'(∀ (unsolved-X ... Y ...) τ_out)])) + (⊢ (#%app- e_fn- e_arg- ...) : τ_out*)])])] + [(_ e_fn . e_args) ; err case; e_fn is not a function + #:with [e_fn- τ_fn] (infer+erase #'e_fn) + (type-error #:src stx + #:msg (format "Expected expression ~a to have → type, got: ~a" + (syntax->datum #'e_fn) (type->str #'τ_fn)))]) + + +;; cond and other conditionals +(define-typed-syntax cond + [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t))) + test) + b ... body] ...+) + #:with (test- ...) (⇑s (test ...) as Bool) + #:with ty-expected (get-expected-type stx) + #:with ([body- ty_body] ...) (infers+erase #'((add-expected body ty-expected) ...)) + #:with (([b- ty_b] ...) ...) (stx-map infers+erase #'((b ...) ...)) + #:with τ_out (stx-foldr (current-join) (stx-car #'(ty_body ...)) (stx-cdr #'(ty_body ...))) + (⊢ (cond- [test- b- ... body-] ...) : τ_out)]) +(define-typed-syntax when + [(when test body ...) +; #:with test- (⇑ test as Bool) + #:with [test- _] (infer+erase #'test) + #:with [(body- _) ...] (infers+erase #'(body ...)) + (⊢ (when- test- body- ...) : Unit)]) +(define-typed-syntax unless + [(unless test body ...) +; #:with test- (⇑ test as Bool) + #:with [test- _] (infer+erase #'test) + #:with [(body- _) ...] (infers+erase #'(body ...)) + (⊢ (unless- test- body- ...) : Unit)]) + +;; sync channels and threads +(define-type-constructor Channel) + +(define-typed-syntax make-channel + [(make-channel (~and tys {ty})) + #:when (brace? #'tys) + (⊢ (make-channel-) : (Channel ty))]) +(define-typed-syntax channel-get + [(channel-get c) + #:with (c- (ty)) (⇑ c as Channel) + (⊢ (channel-get- c-) : ty)]) +(define-typed-syntax channel-put + [(channel-put c v) + #:with (c- (ty)) (⇑ c as Channel) + #:with [v- ty_v] (infer+erase #'v) + #:fail-unless (typechecks? #'ty_v #'ty) + (format "Cannot send ~a value on ~a channel." + (type->str #'ty_v) (type->str #'ty)) + (⊢ (channel-put- c- v-) : Unit)]) + +(define-base-type Thread) + +;; threads +(define-typed-syntax thread + [(thread th) + #:with (th- (~?∀ () (~ext-stlc:→ τ_out))) (infer+erase #'th) + (⊢ (thread- th-) : Thread)]) + +(define-primop random : (→ Int Int)) +(define-primop integer->char : (→ Int Char)) +(define-primop string->list : (→ String (List Char))) +(define-primop string->number : (→ String Int)) +;(define-primop number->string : (→ Int String)) +(define-typed-syntax number->string + [f:id (assign-type #'number->string- #'(→ Int String))] + [(number->string n) + #'(number->string n (ext-stlc:#%datum . 10))] + [(number->string n rad) + #:with args- (⇑s (n rad) as Int) + (⊢ (number->string- . args-) : String)]) +(define-primop string : (→ Char String)) +(define-primop sleep : (→ Int Unit)) +(define-primop string=? : (→ String String Bool)) +(define-primop string<=? : (→ String String Bool)) + +(define-typed-syntax string-append + [(string-append . strs) + #:with strs- (⇑s strs as String) + (⊢ (string-append- . strs-) : String)]) + +;; vectors +(define-type-constructor Vector) + +(define-typed-syntax vector + [(vector (~and tys {ty})) + #:when (brace? #'tys) + (⊢ (vector-) : (Vector ty))] + [(vector v ...) + #:with ([v- ty] ...) (infers+erase #'(v ...)) + #:when (same-types? #'(ty ...)) + #:with one-ty (stx-car #'(ty ...)) + (⊢ (vector- v- ...) : (Vector one-ty))]) +(define-typed-syntax make-vector + [(make-vector n) #'(make-vector n (ext-stlc:#%datum . 0))] + [(make-vector n e) + #:with n- (⇑ n as Int) + #:with [e- ty] (infer+erase #'e) + (⊢ (make-vector- n- e-) : (Vector ty))]) +(define-typed-syntax vector-length + [(vector-length e) + #:with [e- _] (⇑ e as Vector) + (⊢ (vector-length- e-) : Int)]) +(define-typed-syntax vector-ref + [(vector-ref e n) + #:with n- (⇑ n as Int) + #:with [e- (ty)] (⇑ e as Vector) + (⊢ (vector-ref- e- n-) : ty)]) +(define-typed-syntax vector-set! + [(vector-set! e n v) + #:with n- (⇑ n as Int) + #:with [e- (ty)] (⇑ e as Vector) + #:with [v- ty_v] (infer+erase #'v) + #:when (typecheck? #'ty_v #'ty) + (⊢ (vector-set!- e- n- v-) : Unit)]) +(define-typed-syntax vector-copy! + [(vector-copy! dest start src) + #:with start- (⇑ start as Int) + #:with [dest- (ty_dest)] (⇑ dest as Vector) + #:with [src- (ty_src)] (⇑ src as Vector) + #:when (typecheck? #'ty_dest #'ty_src) + (⊢ (vector-copy!- dest- start- src-) : Unit)]) + + +;; sequences and for loops + +(define-type-constructor Sequence) + +(define-typed-syntax in-range + [(in-range end) + #'(in-range (ext-stlc:#%datum . 0) end (ext-stlc:#%datum . 1))] + [(in-range start end) + #'(in-range start end (ext-stlc:#%datum . 1))] + [(in-range start end step) + #:with (e- ...) (⇑s (start end step) as Int) + (⊢ (in-range- e- ...) : (Sequence Int))]) + +(define-typed-syntax in-naturals + [(in-naturals) #'(in-naturals (ext-stlc:#%datum . 0))] + [(in-naturals start) + #:with start- (⇑ start as Int) + (⊢ (in-naturals- start-) : (Sequence Int))]) + + +(define-typed-syntax in-vector + [(in-vector e) + #:with [e- (ty)] (⇑ e as Vector) + (⊢ (in-vector- e-) : (Sequence ty))]) + +(define-typed-syntax in-list + [(in-list e) + #:with [e- (ty)] (⇑ e as List) + (⊢ (in-list- e-) : (Sequence ty))]) + +(define-typed-syntax in-lines + [(in-lines e) + #:with e- (⇑ e as String) + (⊢ (in-lines- (open-input-string e-)) : (Sequence String))]) + +(define-typed-syntax for + [(for ([x:id e]...) b ... body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) (b- ... body-) (ty_b ... ty_body)] + (infers/ctx+erase #'([x : ty] ...) #'(b ... body)) + (⊢ (for- ([x- e-] ...) b- ... body-) : Unit)]) +(define-typed-syntax for* + [(for* ([x:id e]...) body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) + (⊢ (for*- ([x- e-] ...) body-) : Unit)]) + +(define-typed-syntax for/list + [(for/list ([x:id e]...) body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) + (⊢ (for/list- ([x- e-] ...) body-) : (List ty_body))]) +(define-typed-syntax for/vector + [(for/vector ([x:id e]...) body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) + (⊢ (for/vector- ([x- e-] ...) body-) : (Vector ty_body))]) +(define-typed-syntax for*/vector + [(for*/vector ([x:id e]...) body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) + (⊢ (for*/vector- ([x- e-] ...) body-) : (Vector ty_body))]) +(define-typed-syntax for*/list + [(for*/list ([x:id e]...) body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) + (⊢ (for*/list- ([x- e-] ...) body-) : (List ty_body))]) +(define-typed-syntax for/fold + [(for/fold ([acc init]) ([x:id e] ...) body) + #:with [init- ty_init] (infer+erase #`(pass-expected init #,stx)) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(acc- x- ...) body- ty_body] + (infer/ctx+erase #'([acc : ty_init][x : ty] ...) #'body) + #:fail-unless (typecheck? #'ty_body #'ty_init) + (type-error #:src stx + #:msg + "for/fold: Type of body and initial accumulator must be the same, given ~a and ~a" + #'ty_init #'ty_body) + (⊢ (for/fold- ([acc- init-]) ([x- e-] ...) body-) : ty_body)]) + +(define-typed-syntax for/hash + [(for/hash ([x:id e]...) body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) body- (~× ty_k ty_v)] + (infer/ctx+erase #'([x : ty] ...) #'body) + (⊢ (for/hash- ([x- e-] ...) + (let- ([t body-]) + (values- (car- t) (cadr- t)))) + : (Hash ty_k ty_v))]) + +(define-typed-syntax for/sum + [(for/sum ([x:id e]... + (~optional (~seq #:when guard) #:defaults ([guard #'#t]))) + body) + #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) + #:with [(x- ...) (guard- body-) (_ ty_body)] + (infers/ctx+erase #'([x : ty] ...) #'(guard body)) + #:when (Int? #'ty_body) + (⊢ (for/sum- ([x- e-] ... #:when guard-) body-) : Int)]) + +; printing and displaying +(define-typed-syntax printf + [(printf str e ...) + #:with s- (⇑ str as String) + #:with ([e- ty] ...) (infers+erase #'(e ...)) + (⊢ (printf- s- e- ...) : Unit)]) +(define-typed-syntax format + [(format str e ...) + #:with s- (⇑ str as String) + #:with ([e- ty] ...) (infers+erase #'(e ...)) + (⊢ (format- s- e- ...) : String)]) +(define-typed-syntax display + [(display e) + #:with [e- _] (infer+erase #'e) + (⊢ (display- e-) : Unit)]) +(define-typed-syntax displayln + [(displayln e) + #:with [e- _] (infer+erase #'e) + (⊢ (displayln- e-) : Unit)]) +(define-primop newline : (→ Unit)) + +(define-typed-syntax list->vector + [(list->vector e) + #:with [e- (ty)] (⇑ e as List) + (⊢ (list->vector- e-) : (Vector ty))]) + +(define-typed-syntax let + [(let name:id (~datum :) ty:type ~! ([x:id e] ...) b ... body) + #:with ([e- ty_e] ...) (infers+erase #'(e ...)) + #:with [(name- . xs-) (body- ...) (_ ... ty_body)] + (infers/ctx+erase #'([name : (→ ty_e ... ty.norm)][x : ty_e] ...) + #'(b ... body)) + #:fail-unless (typecheck? #'ty_body #'ty.norm) + (format "type of let body ~a does not match expected typed ~a" + (type->str #'ty_body) (type->str #'ty)) + (⊢ (letrec- ([name- (λ- xs- body- ...)]) + (name- e- ...)) + : ty_body)] + [(let ([x:id e] ...) body ...) + #'(ext-stlc:let ([x e] ...) (begin body ...))]) +(define-typed-syntax let* + [(let* ([x:id e] ...) body ...) + #'(ext-stlc:let* ([x e] ...) (begin body ...))]) + +(define-typed-syntax begin + [(begin body ... b) + #:with expected (get-expected-type stx) + #:with b_ann #'(add-expected b expected) + #'(ext-stlc:begin body ... b_ann)]) + +;; hash +(define-type-constructor Hash #:arity = 2) + +(define-typed-syntax in-hash + [(in-hash e) + #:with [e- (ty_k ty_v)] (⇑ e as Hash) + (⊢ (hash-map- e- list-) + : (Sequence (stlc+rec-iso:× ty_k ty_v)))]) + +; mutable hashes +(define-typed-syntax hash + [(hash (~and tys {ty_key ty_val})) + #:when (brace? #'tys) + (⊢ (make-hash-) : (Hash ty_key ty_val))] + [(hash (~seq k v) ...) + #:with ([k- ty_k] ...) (infers+erase #'(k ...)) + #:with ([v- ty_v] ...) (infers+erase #'(v ...)) + #:when (same-types? #'(ty_k ...)) + #:when (same-types? #'(ty_v ...)) + #:with ty_key (stx-car #'(ty_k ...)) + #:with ty_val (stx-car #'(ty_v ...)) + (⊢ (make-hash- (list- (cons- k- v-) ...)) : (Hash ty_key ty_val))]) +(define-typed-syntax hash-set! + [(hash-set! h k v) + #:with [h- (ty_key ty_val)] (⇑ h as Hash) + #:with [k- ty_k] (infer+erase #'k) + #:with [v- ty_v] (infer+erase #'v) + #:when (typecheck? #'ty_k #'ty_key) + #:when (typecheck? #'ty_v #'ty_val) + (⊢ (hash-set!- h- k- v-) : Unit)]) +(define-typed-syntax hash-ref + [(hash-ref h k) + #:with [h- (ty_key ty_val)] (⇑ h as Hash) + #:with [k- ty_k] (infer+erase #'k) + #:when (typecheck? #'ty_k #'ty_key) + (⊢ (hash-ref- h- k-) : ty_val)] + [(hash-ref h k fail) + #:with [h- (ty_key ty_val)] (⇑ h as Hash) + #:with [k- ty_k] (infer+erase #'k) + #:when (typecheck? #'ty_k #'ty_key) + #:with [fail- (~?∀ () (~ext-stlc:→ ty_fail))] (infer+erase #'fail) + #:when (typecheck? #'ty_fail #'ty_val) + (⊢ (hash-ref- h- k- fail-) : ty_val)]) +(define-typed-syntax hash-has-key? + [(hash-has-key? h k) + #:with [h- (ty_key _)] (⇑ h as Hash) + #:with [k- ty_k] (infer+erase #'k) + #:when (typecheck? #'ty_k #'ty_key) + (⊢ (hash-has-key?- h- k-) : Bool)]) + +(define-typed-syntax hash-count + [(hash-count h) + #:with [h- _] (⇑ h as Hash) + (⊢ (hash-count- h-) : Int)]) + +(define-base-type String-Port) +(define-base-type Input-Port) +(define-primop open-output-string : (→ String-Port)) +(define-primop get-output-string : (→ String-Port String)) +(define-primop string-upcase : (→ String String)) + +(define-typed-syntax write-string + [(write-string str out) + #'(write-string str out (ext-stlc:#%datum . 0) (string-length str))] + [(write-string str out start end) + #:with str- (⇑ str as String) + #:with out- (⇑ out as String-Port) + #:with start- (⇑ start as Int) + #:with end- (⇑ end as Int) + (⊢ (write-string- str- out- start- end-) : Unit)]) + +(define-typed-syntax string-length + [(string-length str) + #:with str- (⇑ str as String) + (⊢ (string-length- str-) : Int)]) +(define-primop make-string : (→ Int String)) +(define-primop string-set! : (→ String Int Char Unit)) +(define-primop string-ref : (→ String Int Char)) +(define-typed-syntax string-copy! + [(string-copy! dest dest-start src) + #'(string-copy! + dest dest-start src (ext-stlc:#%datum . 0) (string-length src))] + [(string-copy! dest dest-start src src-start src-end) + #:with dest- (⇑ dest as String) + #:with src- (⇑ src as String) + #:with dest-start- (⇑ dest-start as Int) + #:with src-start- (⇑ src-start as Int) + #:with src-end- (⇑ src-end as Int) + (⊢ (string-copy!- dest- dest-start- src- src-start- src-end-) : Unit)]) + +(define-primop fl+ : (→ Float Float Float)) +(define-primop fl- : (→ Float Float Float)) +(define-primop fl* : (→ Float Float Float)) +(define-primop fl/ : (→ Float Float Float)) +(define-primop flsqrt : (→ Float Float)) +(define-primop flceiling : (→ Float Float)) +(define-primop inexact->exact : (→ Float Int)) +(define-primop exact->inexact : (→ Int Float)) +(define-primop char->integer : (→ Char Int)) +(define-primop real->decimal-string : (→ Float Int String)) +(define-primop fx->fl : (→ Int Float)) +(define-typed-syntax quotient+remainder + [(quotient+remainder x y) + #:with x- (⇑ x as Int) + #:with y- (⇑ y as Int) + (⊢ (let-values- ([[a b] (quotient/remainder- x- y-)]) + (list- a b)) + : (stlc+rec-iso:× Int Int))]) +(define-primop quotient : (→ Int Int Int)) + +(define-typed-syntax set! + [(set! x:id e) + #:with [x- ty_x] (infer+erase #'x) + #:with [e- ty_e] (infer+erase #'e) + #:when (typecheck? #'ty_e #'ty_x) + (⊢ (set!- x e-) : Unit)]) + +(define-typed-syntax provide-type [(provide-type ty ...) #'(provide- ty ...)]) + +(define-typed-syntax provide + [(provide x:id ...) + #:with ([x- ty_x] ...) (infers+erase #'(x ...)) + ; TODO: use hash-code to generate this tmp + #:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...)) + #'(begin- + (provide- x ...) + (stlc+rec-iso:define-type-alias x-ty ty_x) ... + (provide- x-ty ...))]) +(define-typed-syntax require-typed + [(require-typed x:id ... #:from mod) + #:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...)) + #:with (y ...) (generate-temporaries #'(x ...)) + #'(begin- + (require- (rename-in- (only-in- mod x ... x-ty ...) [x y] ...)) + (define-syntax x (make-rename-transformer (assign-type #'y #'x-ty))) ...)]) + +(define-base-type Regexp) +(define-primop regexp-match : (→ Regexp String (List String))) +(define-primop regexp : (→ String Regexp)) + +(define-typed-syntax equal? + [(equal? e1 e2) + #:with [e1- ty1] (infer+erase #'e1) + #:with [e2- ty2] (infer+erase #'(add-expected e2 ty1)) + #:fail-unless (typecheck? #'ty1 #'ty2) "arguments to equal? have different types" + (⊢ (equal?- e1- e2-) : Bool)]) + +(define-typed-syntax read + [(read) + (⊢ (let- ([x (read-)]) + (cond- [(eof-object?- x) ""] + [(number?- x) (number->string- x)] + [(symbol?- x) (symbol->string- x)])) : String)]) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module+ test + (begin-for-syntax + (check-true (covariant-Xs? #'Int)) + (check-true (covariant-Xs? #'(stlc+box:Ref Int))) + (check-true (covariant-Xs? #'(→ Int Int))) + (check-true (covariant-Xs? #'(∀ (X) X))) + (check-false (covariant-Xs? #'(∀ (X) (stlc+box:Ref X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ X X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ X Int)))) + (check-true (covariant-Xs? #'(∀ (X) (→ Int X)))) + (check-true (covariant-Xs? #'(∀ (X) (→ (→ X Int) X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ (→ (→ X Int) Int) X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ (stlc+box:Ref X) Int)))) + (check-false (covariant-Xs? #'(∀ (X Y) (→ X Y)))) + (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) Y)))) + (check-false (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Y Int))))) + (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Int Y))))) + (check-false (covariant-Xs? #'(∀ (A B) (→ (→ Int (stlc+rec-iso:× A B)) + (→ String (stlc+rec-iso:× A B)) + (stlc+rec-iso:× A B))))) + (check-true (covariant-Xs? #'(∀ (A B) (→ (→ (stlc+rec-iso:× A B) Int) + (→ (stlc+rec-iso:× A B) String) + (stlc+rec-iso:× A B))))) + )) diff --git a/tapl/notes.txt b/macrotypes/examples/notes.txt diff --git a/macrotypes/examples/stlc+box.rkt b/macrotypes/examples/stlc+box.rkt @@ -0,0 +1,27 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+cons.rkt") + +;; Simply-Typed Lambda Calculus, plus mutable references +;; Types: +;; - types from stlc+cons.rkt +;; - Ref constructor +;; Terms: +;; - terms from stlc+cons.rkt +;; - ref deref := + +(define-type-constructor Ref) + +(define-typed-syntax ref + [(ref e) + #:with (e- τ) (infer+erase #'e) + (⊢ (box- e-) : (Ref τ))]) +(define-typed-syntax deref + [(deref e) + #:with (e- (τ)) (⇑ e as Ref) + (⊢ (unbox- e-) : τ)]) +(define-typed-syntax := #:literals (:=) + [(:= e_ref e) + #:with (e_ref- (τ1)) (⇑ e_ref as Ref) + #:with (e- τ2) (infer+erase #'e) + #:when (typecheck? #'τ1 #'τ2) + (⊢ (set-box!- e_ref- e-) : Unit)]) diff --git a/macrotypes/examples/stlc+cons.rkt b/macrotypes/examples/stlc+cons.rkt @@ -0,0 +1,91 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+reco+var.rkt") + +;; Simply-Typed Lambda Calculus, plus cons +;; Types: +;; - types from stlc+reco+var.rkt +;; - List constructor +;; Terms: +;; - terms from stlc+reco+var.rkt + +;; TODO: enable HO use of list primitives + +(define-type-constructor List) + +(define-typed-syntax nil + [(nil ~! τi:type-ann) + (⊢ null- : (List τi.norm))] + ; minimal type inference + [nil:id #:with expected-τ (get-expected-type #'nil) + #:when (syntax-e #'expected-τ) ; 'expected-type property exists (ie, not false) + #:with ty_lst (local-expand #'expected-τ 'expression null) ; canonicalize + #:fail-unless (List? #'ty_lst) + (raise (exn:fail:type:infer + (format "~a (~a:~a): Inferred ~a type for nil, which is not a List." + (syntax-source stx) (syntax-line stx) (syntax-column stx) + (type->str #'ty_lst)) + (current-continuation-marks))) + #:with (~List τ) #'ty_lst + (⊢ null- : (List τ))] + [_:id #:fail-when #t + (raise (exn:fail:type:infer + (format "~a (~a:~a): nil requires type annotation" + (syntax-source stx) (syntax-line stx) (syntax-column stx)) + (current-continuation-marks))) + #'(void-)]) +(define-typed-syntax cons + [(cons e1 e2) + #:with [e1- τ1] (infer+erase #'e1) +; #:with e2ann (add-expected-type #'e2 #'(List τ1)) + #:with (e2- (τ2)) (⇑ (add-expected e2 (List τ1)) as List) + #:fail-unless (typecheck? #'τ1 #'τ2) + (format "trying to cons expression ~a with type ~a to list ~a with type ~a\n" + (syntax->datum #'e1) (type->str #'τ1) + (syntax->datum #'e2) (type->str #'(List τ2))) + ;; propagate up inferred types of variables + #:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e1- e2-)))) + #:with result-cons (add-env #'(cons- e1- e2-) #'env) + (⊢ result-cons : (List τ1))]) +(define-typed-syntax isnil + [(isnil e) + #:with (e- _) (⇑ e as List) + (⊢ (null?- e-) : Bool)]) +(define-typed-syntax head + [(head e) + #:with (e- (τ)) (⇑ e as List) + (⊢ (car- e-) : τ)]) +(define-typed-syntax tail + [(tail e) + #:with (e- τ-lst) (infer+erase #'e) + #:when (List? #'τ-lst) + (⊢ (cdr- e-) : τ-lst)]) +(define-typed-syntax list + [(list) #'nil] + [(_ x . rst) ; has expected type + #:with expected-τ (get-expected-type stx) + #:when (syntax-e #'expected-τ) + #:with (~List τ) (local-expand #'expected-τ 'expression null) + #'(cons (add-expected x τ) (list . rst))] + [(_ x . rst) ; no expected type + #'(cons x (list . rst))]) +(define-typed-syntax reverse + [(reverse e) + #:with (e- τ-lst) (infer+erase #'e) + #:when (List? #'τ-lst) + (⊢ (reverse- e-) : τ-lst)]) +(define-typed-syntax length + [(length e) + #:with (e- τ-lst) (infer+erase #'e) + #:when (List? #'τ-lst) + (⊢ (length- e-) : Int)]) +(define-typed-syntax list-ref + [(list-ref e n) + #:with (e- (ty)) (⇑ e as List) + #:with n- (⇑ n as Int) + (⊢ (list-ref- e- n-) : ty)]) +(define-typed-syntax member + [(member v e) + #:with (e- (ty)) (⇑ e as List) + #:with [v- ty_v] (infer+erase #'(add-expected v ty)) + #:when (typecheck? #'ty_v #'ty) + (⊢ (member- v- e-) : Bool)]) diff --git a/macrotypes/examples/stlc+effect.rkt b/macrotypes/examples/stlc+effect.rkt @@ -0,0 +1,138 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+box.rkt" #:except ref deref := #%app λ) + +(provide (for-syntax get-new-effects)) + +;; Simply-Typed Lambda Calculus, plus mutable references +;; Types: +;; - types from stlc+cons.rkt +;; - Ref constructor +;; Terms: +;; - terms from stlc+cons.rkt +;; - ref deref := + +(begin-for-syntax + (define (add-news e locs) (syntax-property e 'ν locs)) + (define (add-assigns e locs) (syntax-property e ':= locs)) + (define (add-derefs e locs) (syntax-property e '! locs)) + (define (add-effects e new-locs assign-locs deref-locs) + (add-derefs + (add-assigns + (add-news e new-locs) + assign-locs) + deref-locs)) + + (define (get-effects e tag [vs '()]) + (or (syntax-property + (local-expand (if (null? vs) e #`(stlc+box:λ #,vs #,e)) 'expression null) + tag) + null)) + (define (get-new-effects e [vs '()]) (get-effects e 'ν vs)) + (define (get-assign-effects e [vs '()]) (get-effects e ':= vs)) + (define (get-deref-effects e [vs '()]) (get-effects e '! vs)) + + (define (print-effects e) + (printf "expr ~a\n" (syntax->datum e)) + (define e+ (local-expand e 'expression null)) + (printf "new locs: ~a\n" (syntax-property e+ 'ν)) + (printf "deref locs: ~a\n" (syntax-property e+ '!)) + (printf "assign locs: ~a\n" (syntax-property e+ ':=))) + + (define (loc-union locs1 locs2) + (cond + [(not locs1) locs2] + [(not locs2) locs1] + [else (set-union locs1 locs2)]))) + + +(define-typed-syntax effect:#%app #:export-as #%app + [(_ efn e ...) + #:with [e_fn- ty_fn fns fas fds] (infer+erase/eff #'efn) + #:with tyns (get-new-effects #'ty_fn) + #:with tyas (get-assign-effects #'ty_fn) + #:with tyds (get-deref-effects #'ty_fn) + #:with (~→ τ_in ... τ_out) #'ty_fn + #:with ([e_arg- τ_arg ns as ds] ...) (infers+erase/eff #'(e ...)) +; #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn as →) + #:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...)) + (mk-app-err-msg stx #:expected #'(τ_in ...) + #:given #'(τ_arg ...) + #:note "Wrong number of arguments.") + #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) + (mk-app-err-msg stx #:expected #'(τ_in ...) + #:given #'(τ_arg ...)) + (assign-type/eff #'(#%app- e_fn- e_arg- ...) #'τ_out + (stx-flatten #'(fns tyns . (ns ...))) + (stx-flatten #'(fas tyas . (as ...))) + (stx-flatten #'(fds tyds . (ds ...)))) + #;(let ([φ-news (stx-map get-new-effects #'(τfn efn e ...))] + [φ-assigns (stx-map get-assign-effects #'(τfn efn e ...))] + [φ-derefs (stx-map get-deref-effects #'(τfn efn e ...))]) + (add-effects #'(stlc+box:#%app efn e ...) + (foldl loc-union (set) φ-news) + (foldl loc-union (set) φ-assigns) + (foldl loc-union (set) φ-derefs)))]) + +(define-typed-syntax λ + [(λ bvs:type-ctx e) + #:with [xs- e- τ_res ns as ds] (infer/ctx+erase/eff #'bvs #'e) + (assign-type #'(λ- xs- e-) + (add-effects #'(→ bvs.type ... τ_res) #'ns #'as #'ds))]) + +#;(define-typed-syntax λ + [(λ bvs:type-ctx e) + #:with (xs- e- τ_res) (infer/ctx+erase #'bvs #'e) + (let ([φ-news (get-new-effects #'e-)] + [φ-assigns (get-assign-effects #'e-)] + [φ-derefs (get-deref-effects #'e-)]) + (assign-type + #'(λ- xs- e-) + (add-effects #'(→ bvs.type ... τ_res) φ-news φ-assigns φ-derefs)))]) + +(define-type-constructor Ref) + +(begin-for-syntax + (define (infer+erase/eff e) + (define/with-syntax [e- ty] (infer+erase e)) + (list + #'e- #'ty + (get-new-effects #'e-) (get-assign-effects #'e-) (get-deref-effects #'e-))) + (define (infers+erase/eff es) + (stx-map infer+erase/eff es)) + (define (infer/ctx+erase/eff bvs e) + (define/with-syntax [xs- e- ty] (infer/ctx+erase bvs e)) + (list #'xs- #'e- #'ty + (get-new-effects #'e-) (get-assign-effects #'e-) (get-deref-effects #'e-))) + (define (assign-type/eff e ty news assigns derefs) + (assign-type (add-effects e news assigns derefs) ty))) + +(define-typed-syntax ref + [(ref e) + #:with (e- τ ns as ds) (infer+erase/eff #'e) + (assign-type/eff #'(box- e-) #'(Ref τ) + (cons (syntax-position stx) #'ns) #'as #'ds)]) +(define-typed-syntax deref + [(deref e) + #:with (e- (~Ref ty) ns as ds) (infer+erase/eff #'e) + (assign-type/eff #'(unbox- e-) #'ty + #'ns #'as (cons (syntax-position stx) #'ds))]) +(define-typed-syntax := #:literals (:=) + [(:= e_ref e) + ;#:with (e_ref- (τ1)) (⇑ e_ref as Ref) + #:with [e_ref- (~Ref ty1) ns1 as1 ds1] (infer+erase/eff #'e_ref) + #:with [e- ty2 ns2 as2 ds2] (infer+erase/eff #'e) + #:when (typecheck? #'ty1 #'ty2) + (assign-type/eff #'(set-box!- e_ref- e-) #'Unit + (stx-append #'ns1 #'ns2) + (cons (syntax-position stx) (stx-append #'as1 #'as2)) + (stx-append #'ds1 #'ds2))]) +;(define-typed-syntax ref +; [(_ e) +; (syntax-property #'(stlc+box:ref e) 'ν (set (syntax-position stx)))]) +;(define-typed-syntax deref +; [(_ e) +; (syntax-property #'(stlc+box:deref e) '! (set (syntax-position stx)))]) +;(define-typed-syntax := +; [(_ e_ref e) +; (syntax-property #'(stlc+box::= e_ref e) ':= (set (syntax-position stx)))]) + diff --git a/macrotypes/examples/stlc+lit.rkt b/macrotypes/examples/stlc+lit.rkt @@ -0,0 +1,39 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc.rkt") +(provide define-primop) + +;; Simply-Typed Lambda Calculus, plus numeric literals and primitives +;; Types: +;; - types from stlc.rkt +;; - Int +;; Terms: +;; - terms from stlc.rkt +;; - numeric literals +;; - prim + +;; Typechecking forms: +;; - define-primop + +(define-base-type Int) + +(define-syntax define-primop + (syntax-parser #:datum-literals (:) + [(_ op:id : τ:type) + #:with op/tc (generate-temporary #'op) + #'(begin + (provide (rename-out [op/tc op])) + (define-primop op/tc op : τ))] + [(_ op/tc op : τ) + #'(begin + #;(define-syntax op/tc (make-rename-transformer (assign-type #'op #'τ))) + ; rename transformer doesnt seem to expand at the right time + ; - op still has no type in #%app + (define-syntax op/tc + (make-variable-like-transformer (assign-type #'op #'τ))))])) + +(define-primop + : (→ Int Int Int)) + +(define-typed-syntax #%datum #:literals (#%datum) + [(#%datum . n:integer) (⊢ #,(syntax/loc stx (#%datum- . n)) : Int)] + [(#%datum . x) + #:when (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x) + #'(#%datum- . x)]) diff --git a/macrotypes/examples/stlc+occurrence.rkt b/macrotypes/examples/stlc+occurrence.rkt @@ -0,0 +1,355 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+sub.rkt" #:except #%datum) +(extends "stlc+cons.rkt" #:except + #%datum and tup × proj ~× list) +(reuse tup × proj #:from "stlc+tup.rkt") +(require (only-in "stlc+tup.rkt" ~×)) + +;; Calculus for occurrence typing. +;; - Types can be simple, or sets of simple types +;; (aka "ambiguous types"; +;; the run-time value will have one of a few ambiguous possible types.) +;; - The ∪ constructor makes ambiguous types +;; - `(test [τ ? x] e1 e2)` form will insert a run-time check to discriminate ∪ +;; -- If the value at identifier x has type τ, then we continue to e1 with [x : τ] +;; -- Otherwise, we move to e2 with [x : (- (typeof x) τ)]. +;; i.e., [x : τ] is not possible +;; - Subtyping rules: +;; -- ALL : t ... <: t' => (U t ...) <: t' +;; -- AMB : t <: (U ... t ...) +;; -- EXT : (U t' ...) <: (U t t' ...) +;; -- ONE : a<:b => (U a t' ...) <: (U b t' ...) + +;; ============================================================================= + +(define-base-type Bot) ;; For empty unions +(define-base-type Boolean) +(define-base-type Str) + +(define-typed-syntax #%datum + [(#%datum . n:boolean) (⊢ (#%datum- . n) : Boolean)] + [(#%datum . n:str) (⊢ (#%datum- . n) : Str)] + [(#%datum . x) #'(stlc+sub:#%datum . x)]) + +(define-type-constructor ∪ #:arity >= 1) + +;; ----------------------------------------------------------------------------- +;; --- Union operations + +;; Occurrence type operations +;; These assume that τ is a type in 'normal form' +(begin-for-syntax + (define (∪->list τ) + ;; Ignore type constructor & the kind + ;; (because there are no bound identifiers) + (syntax-parse τ + [(~∪ τ* ...) + (syntax->list #'(τ* ...))] + [_ + (error '∪->list (format "Given non-ambiguous type '~a'" τ))])) + + (define (list->∪ τ*) + (if (null? τ*) + #'Bot + (τ-eval #`(∪ #,@τ*)))) + + (define (∖ τ1 τ2) + (cond + [(∪? τ1) + (define (not-τ2? τ) + (not (typecheck? τ τ2))) + (list->∪ (filter not-τ2? (∪->list τ1)))] + [else ; do nothing not non-union types + τ1])) +) + +;; ----------------------------------------------------------------------------- +;; --- Normal Form +;; Evaluate each type in the union, +;; remove duplicates +;; determinize the ordering of members +;; flatten nested unions + +(begin-for-syntax + + (define τ-eval (current-type-eval)) + + (define (τ->symbol τ) + (syntax-parse τ + [(_ κ) + (syntax->datum #'κ)] + [(_ κ (_ () _ τ* ...)) + (define κ-str (symbol->string (syntax->datum #'κ))) + (define τ-str* + (map (compose1 symbol->string τ->symbol) (syntax->list #'(τ* ...)))) + (string->symbol + (string-append + (apply string-append "(" κ-str τ-str*) + ")"))] + [_ + (error 'τ->symbol (~a (syntax->datum τ)))])) + + (define ∪-eval + ;; Private helper: check that all functions have unique arities + ;; It's private because it assumes all τ* have been evaluated + (let ([assert-unique-arity-arrows + (lambda (τ*) + (for/fold ([seen '()]) + ([τ (in-list τ*)]) + (syntax-parse τ + [(~→ τ-dom* ... τ-cod) + (define arity (stx-length #'(τ-dom* ...))) + (when (memv arity seen) + (error '∪ (format "Cannot discriminate types in the union ~a. Multiple functions have arity ~a." (cons '∪ (map syntax->datum τ*)) arity))) + (cons arity seen)] + [_ seen])))]) + (lambda (τ-stx) + (syntax-parse (τ-eval τ-stx) + [(~∪ τ-stx* ...) + ;; Recursively evaluate members + (define τ** + (for/list ([τ (in-list (syntax->list #'(τ-stx* ...)))]) + (let ([τ+ (∪-eval τ)]) + (if (∪? τ+) + (∪->list τ+) + (list τ+))))) + ;; Remove duplicates from the union, sort members + (define τ* + (sort + (remove-duplicates (apply append τ**) (current-type=?)) + symbol<? + #:key τ->symbol)) + ;; Check for empty & singleton lists + (define τ + (cond + [(null? τ*) + (raise-user-error 'τ-eval "~a (~a:~a) empty union type ~a\n" + (syntax-source τ-stx) (syntax-line τ-stx) (syntax-column τ-stx) + (syntax->datum τ-stx))] + [(null? (cdr τ*)) + #`#,(car τ*)] + [else + (assert-unique-arity-arrows τ*) + #`#,(cons #'∪ τ*)])) + (τ-eval τ)] + [_ + (τ-eval τ-stx)])))) + (current-type-eval ∪-eval)) + +;; ----------------------------------------------------------------------------- +;; --- Subtyping + +(begin-for-syntax + ;; True if one ordered list (of types) is a subset of another + (define (subset? x* y* #:leq [cmp (current-typecheck-relation)]) + (let loop ([x* x*] [y* y*]) + (cond + [(null? x*) #t] + [(null? y*) #f] + [(cmp (car x*) (car y*)) + (loop (cdr x*) (cdr y*))] + [else + (loop x* (cdr y*))]))) + + (define ∪-sub? + (let ([sub? (current-sub?)]) + (lambda (τ1-stx τ2-stx) + (define τ1 ((current-type-eval) τ1-stx)) + (define τ2 ((current-type-eval) τ2-stx)) + (or (Bot? τ1) (Top? τ2) + (match `(,(∪? τ1) ,(∪? τ2)) + ['(#f #t) + ;; AMB : a<:b => a <: (U ... b ...) + (for/or ([τ (in-list (∪->list τ2))]) + ((current-sub?) τ1 τ))] + ['(#t #t) + (define τ1* (∪->list τ1)) + (define τ2* (∪->list τ2)) + (match `(,(length τ1*) ,(length τ2*)) + [`(,L1 ,L2) #:when (< L1 L2) + ;; - EXT : (U t' ...) <: (U t t' ...) + (subset? τ1* τ2* #:leq (current-sub?))] + [`(,L1 ,L2) #:when (= L1 L2) + ;; - SUB : a<:b => (U a t' ...) <: (U b t' ...) + ;; `∪->list` guarantees same order on type members + ;; `sub?` is reflexive + (andmap (current-sub?) τ1* τ2*)] + [_ #f])] + ['(#t #f) + ;; - ALL : t... <: t' => (U t ...) <: t' + (andmap (lambda (τ) ((current-sub?) τ τ2)) (∪->list τ1))] + ['(#f #f) + ;; Fall back to OLD sub + (sub? τ1 τ2)]))))) + + (current-sub? ∪-sub?) + (current-typecheck-relation (current-sub?)) +) + +;; ----------------------------------------------------------------------------- +;; --- Filters +;; These are stored imperatively, in a function. +;; Makes it easy to add a new filter & avoids duplicating this map + +(begin-for-syntax + (define current-Π (make-parameter (lambda (x) (error 'Π)))) + + (define (type->filter τ) + (define f ((current-Π) τ)) + (unless f + (error 'τ->filter (format "Could not express type '~a' as a filter." (syntax->datum τ)))) + f) + + (define (type*->filter* τ*) + (map (current-Π) τ*)) + + (define (simple-Π τ) + (syntax-parse (τ-eval τ) + [~Boolean + #'boolean?-] + [~Int + #'integer?-] + [~Str + #'string?-] + [~Num + #'number?-] + [~Nat + #'(lambda- (n) (and- (integer?- n) (not- (negative?- n))))] + [(~→ τ* ... τ) + (define k (stx-length #'(τ* ...))) + #`(lambda- (f) (and- (procedure?- f) (procedure-arity-includes?- f #,k #f)))] + [(~∪ τ* ...) + (define filter* (type*->filter* (syntax->list #'(τ* ...)))) + #`(lambda- (v) (for/or- ([f (in-list- (list- #,@filter*))]) (f v)))] + [_ + (error 'Π "Cannot make filter for type ~a\n" (syntax->datum τ))])) + (current-Π simple-Π) + +) + +;; (test (τ ? x) e1 e2) +;; - drop absurd branches? +;; - allow x not identifier (1. does nothing 2. latent filters) +(define-typed-syntax test #:datum-literals (?) + ;; -- THIS CASE BELONGS IN A NEW FILE + [(test [τ0+:type ? (unop x-stx:id n-stx:nat)] e1 e2) + ;; 1. Check that we're using a known eliminator + #:when (free-identifier=? #'stlc+tup:proj #'unop) + ;; 2. Make sure we're filtering with a valid type + #:with f (type->filter #'τ0+) + ;; 3. Typecheck the eliminator call. Remember the type & apply the filter. + ;; (This type is PROBABLY a union -- else why bother testing!) + #:with (e0+ τ0) (infer+erase #'(unop x-stx n-stx)) + #:with τ0- (∖ #'τ0 #'τ0+) + ;; 4. Build the +/- types for our identifier; the thing we apply the elim. + test to + ;; We know that x has a pair type because (proj x n) typechecked + #:with (x (~× τi* ...)) (infer+erase #'x-stx) + #:with τ+ #`(stlc+tup:× #,@(replace-at (syntax->list #'(τi* ...)) (syntax-e #'n-stx) #'τ0+)) + #:with τ- #`(stlc+tup:× #,@(replace-at (syntax->list #'(τi* ...)) (syntax-e #'n-stx) #'τ0-)) + ;; 5. Check the branches with the refined types + #:with [x1 e1+ τ1] (infer/ctx+erase #'([x-stx : τ+]) #'e1) + #:with [x2 e2+ τ2] (infer/ctx+erase #'([x-stx : τ-]) #'e2) + ;; 6. Desugar, replacing the filtered identifier + (⊢ (if- (f e0+) + ((lambda- x1 e1+) x-stx) + ((lambda- x2 e2+) x-stx)) + : (∪ τ1 τ2))] + ;; TODO lists + ;; For now, we can't express the type (List* A (U A B)), so our filters are too strong + ;; -- THE ORIGINAL + [(test [τ0+:type ? x-stx:id] e1 e2) + #:with f (type->filter #'τ0+) + #:with (x τ0) (infer+erase #'x-stx) + #:with τ0- (∖ #'τ0 #'τ0+) + #:with [x1 e1+ τ1] (infer/ctx+erase #'([x-stx : τ0+]) #'e1) + #:with [x2 e2+ τ2] (infer/ctx+erase #'([x-stx : τ0-]) #'e2) + ;; Expand to a conditional, using the runtime predicate + (⊢ (if- (f x-stx) + ((lambda- x1 e1+) x-stx) + ((lambda- x2 e2+) x-stx)) + : (∪ τ1 τ2))]) + +;; ============================================================================= +;; === BELONGS IN A NEW FILE + +;; (extends "stlc+occurrence.rkt"); #:rename [test ot:test]) +;; (extends "stlc+tup.rkt" #:except + #%datum) + +(define-for-syntax (replace-at τ* n τ-new) + (for/list ([τ-old (in-list τ*)] + [i (in-naturals)]) + (if (= i n) + τ-new + τ-old))) + +;; Add subtyping for tuples +(begin-for-syntax + (define ×-sub? + (let ([sub? (current-sub?)]) + (lambda (τ1-stx τ2-stx) + (define τ1 ((current-type-eval) τ1-stx)) + (define τ2 ((current-type-eval) τ2-stx)) + (or (Bot? τ1) (Top? τ2) + (syntax-parse `(,τ1 ,τ2) + [((~× τi1* ...) + (~× τi2* ...)) + (and (stx-length=? #'(τi1* ...) + #'(τi2* ...)) + ;; Gotta use (current-sub?), because products may be recursive + (stx-andmap (current-sub?) #'(τi1* ...) #'(τi2* ...)))] + [_ + (sub? τ1 τ2)]))))) + (current-sub? ×-sub?) + (current-typecheck-relation (current-sub?))) + +;; --- Update Π for products +(begin-for-syntax + (define π-Π + (let ([Π (current-Π)]) + (lambda (τ) + (syntax-parse (τ-eval τ) + [(~× τ* ...) + (define filter* (type*->filter* (syntax->list #'(τ* ...)))) + #`(lambda- (v*) + (and- (list?- v*) + (for/and- ([v (in-list- v*)] + [f (in-list- (list- #,@filter*))]) + (f v))))] + [_ ;; Fall back + (Π τ)])))) + (current-Π π-Π)) + +;; ============================================================================= +;; === Lists + +;; Subtyping for lists +(begin-for-syntax + (define list-sub? + (let ([sub? (current-sub?)]) + (lambda (τ1-stx τ2-stx) + (define τ1 ((current-type-eval) τ1-stx)) + (define τ2 ((current-type-eval) τ2-stx)) + (or (Bot? τ1) (Top? τ2) + (syntax-parse `(,τ1 ,τ2) + [((~List τi1) + (~List τi2)) + ((current-sub?) #'τi1 #'τi2)] + [_ + (sub? τ1 τ2)]))))) + (current-sub? list-sub?) + (current-typecheck-relation (current-sub?))) + +;; --- Update Π for lists +(begin-for-syntax + (define list-Π + (let ([Π (current-Π)]) + (lambda (τ) + (syntax-parse (τ-eval τ) + [(~List τi) + (define f ((current-Π) #'τi)) + #`(lambda- (v*) + (and- (list?- v*) + (for/and- ([v (in-list- v*)]) + (#,f v))))] + [_ ;; Fall back + (Π τ)])))) + (current-Π list-Π)) diff --git a/macrotypes/examples/stlc+overloading.rkt b/macrotypes/examples/stlc+overloading.rkt @@ -0,0 +1,164 @@ +#lang s-exp macrotypes/typecheck +(reuse List cons nil #:from "stlc+cons.rkt") +(reuse #:from "stlc+rec-iso.rkt") ; to load current-type=? +(extends "stlc+sub.rkt" #:except #%datum) + +;; Revision of overloading, using identifier macros instead of overriding #%app + +;; ============================================================================= + +(define-base-type Bot) +(define-base-type Str) + +(define-typed-syntax #%datum + [(#%datum . n:str) (⊢ (#%datum- . n) : Str)] + [(#%datum . x) #'(stlc+sub:#%datum . x)]) + +(define-for-syntax xerox syntax->datum) + +;; ============================================================================= +;; === Resolvers + +(begin-for-syntax + (struct ℜ ( + name ;; Symbol + dom* ;; (Box (Listof (Pairof Type Expr))) + cod ;; Type + ) #:constructor-name make-ℜ + #:transparent + #:property prop:procedure + (lambda (self τ-or-e #:exact? [exact? #f]) + (define r + (if (syntax? τ-or-e) ;; Can I ask "type?" + (ℜ-resolve-syntax self τ-or-e #:exact? exact?) + (ℜ-resolve-value self τ-or-e #:exact? exact?))) + (or r + (error 'ℜ (format "Resolution for '~a' failed at type ~a" + (syntax->datum (ℜ-name self)) + τ-or-e)))) + ) + + ;; Rad! + (define (ℜ-add! ℜ τ e) + (define dom* (ℜ-dom* ℜ)) + (set-box! dom* (cons (cons τ e) (unbox dom*)))) + + (define (ℜ-init name τ-cod) + (make-ℜ name (box '()) τ-cod)) + + (define (ℜ->type ℜ #:subst [τ-dom (assign-type #''α #'#%type)]) + ((current-type-eval) #`(→ #,τ-dom #,(ℜ-cod ℜ)))) + + (define (ℜ-find ℜ τ #:=? =?) + (define (τ=? τ2) + (=? τ τ2)) + (assf τ=? (unbox (ℜ-dom* ℜ)))) + + (define (ℜ-resolve-syntax ℜ τ #:exact? [exact? #f]) + ;; First try exact matches, then fall back to subtyping (unless 'exact?' is set). + ;; When subtyping, the __order instances were declared__ resolves ties. + (define result + (or (ℜ-find ℜ τ #:=? (current-type=?)) + (and (not exact?) + (ℜ-find ℜ τ #:=? (current-typecheck-relation))))) + (and (pair? result) + (cdr result))) + + (define (ℜ-resolve-value ℜ e #:exact? [exact? #f]) + (error 'ℜ (format "Runtime resolution not implemented. Anyway your value was ~a" e))) + + (define (ℜ-unbound? ℜ τ) + (not (ℜ-resolve-syntax ℜ τ #:exact? #t))) + + (define (syntax->ℜ id) + ;; Don't care about the type + (define stx+τ (infer+erase id)) + ;; Boy, I wish I had a monad + (define (fail) + (error 'resolve (format "Identifier '~a' is not overloaded" (syntax->datum id)))) + (unless (pair? stx+τ) (fail)) + (define stx (car stx+τ)) + (unless (syntax? stx) (fail)) + (define ℜ-stx (syntax->datum (car stx+τ))) + (unless (and (list? ℜ-stx) + (not (null? ℜ-stx)) + (not (null? (cdr ℜ-stx)))) + (fail)) + (define ℜ (cadr ℜ-stx)) + (unless (ℜ? ℜ) (fail)) + ℜ) + + (define-syntax-rule (error-template sym id τ reason) + (error sym (format "Failure for '~a' at type '~a'. ~a" + (syntax->datum id) + (syntax->datum τ) + reason))) + + (define-syntax-rule (instance-error id τ reason) + (error-template 'instance id τ reason)) + + (define-syntax-rule (resolve-error id τ reason) + (error-template 'resolve id τ reason)) +) + +;; ============================================================================= +;; === Overloaded signature environment + +(define-typed-syntax signature + [(signature (name:id α:id) τ) + #:with ((α+) (~→ τ_α:id τ-cod) _) (infer/tyctx+erase #'([α : #%type]) #'τ) + (define ℜ (ℜ-init #'name #'τ-cod)) + (⊢ (define-syntax name + (syntax-parser + [_:id + #'(quote- #,ℜ)] ;; Is there a way to transmit ℜ directly? + [(n e) + #:with [e+ τ+] (infer+erase #'e) + #:with n+ (#,ℜ #'τ+) + (⊢ (#%app- n+ e+) + : τ-cod)] + [(_ e* (... ...)) + #'(raise-arity-error- (syntax->datum- name) 1 e* (... ...))])) + : Bot)] + [(signature e* ...) + (error 'signature (format "Expected (signature (NAME VAR) (→ VAR τ)), got ~a" (xerox #'(e* ...))))]) + +(define-typed-syntax resolve + [(resolve name:id τ) + #:with τ+ ((current-type-eval) #'τ) + ;; Extract a resolver from the syntax object + (define ℜ (syntax->ℜ #'name)) + ;; Apply the resolver to the argument type. woo-wee! + (⊢ #,(ℜ #'τ+ #:exact? #t) : #,(ℜ->type ℜ #:subst #'τ+))]) + +(define-typed-syntax instance + [(instance (name:id τ-stx) e) + #:with τ ((current-type-eval) #'τ-stx) + #:with [e+ τ+] (infer+erase #'e) + (define ℜ (syntax->ℜ #'name)) + (unless (ℜ-unbound? ℜ #'τ) (instance-error #'name #'τ "Overlaps with existing instance.")) + (define _unify ;; Should be a helper function + (syntax-parse #`(τ+ #,(ℜ->type ℜ)) + [((~→ τ_dom1 τ_cod1) + (~→ _ τ_cod2)) + ;; Really, need to unify this type with the template + ;; (unless ((current-type=?) τ_dom1 τ_dom2) + ;; (instance-error #'name #'τ (format "Domain '~a' must unify with template domain '~a'." + ;; (syntax->datum #'τ_dom1) (syntax->datum #'τ_dom2)))) + (unless ((current-type=?) ((current-type-eval) #'τ) #'τ_dom1) + (instance-error #'name #'τ (format "Domain '~a' must be the instance type, for now (2015-10-20)." (syntax->datum #'τ_dom1)))) + (unless ((current-type=?) #'τ_cod1 #'τ_cod2) + (instance-error #'name #'τ (format "Codomain '~a' must match template codomain '~a'" + (syntax->datum #'τ_cod1) (syntax->datum #'τ_cod2)))) + (void)] + [(a b) + (instance-error #'name #'τ (format "May only overload single-argument functions. (Got ~a and ~a)" + (syntax->datum #'a) (syntax->datum #'b)) + )])) + ;; Should we use syntax instead of e+ ? + (ℜ-add! ℜ #'τ #'e+) + (⊢ (void-) : Bot)] + [_ + (error 'instance "Expected (instance (id τ) e).")]) + + diff --git a/macrotypes/examples/stlc+rec-iso.rkt b/macrotypes/examples/stlc+rec-iso.rkt @@ -0,0 +1,70 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+tup.rkt") +(reuse ∨ var case define-type-alias define #:from "stlc+reco+var.rkt") + +;; stlc + (iso) recursive types +;; Types: +;; - types from stlc+tup.rkt +;; - also ∨ from stlc+reco+var +;; - μ +;; Terms: +;; - terms from stlc+tup.rkt +;; - also var and case from stlc+reco+var +;; - fld, unfld +;; Other: +;; - extend type=? to handle lambdas + +(define-type-constructor μ #:bvs = 1) + +(begin-for-syntax + (define stlc:type=? (current-type=?)) + ;; extend to handle μ, ie lambdas + (define (type=? τ1 τ2) +; (printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum τ1)) +; (printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum τ2)) + (syntax-parse (list τ1 τ2) + ;; alternative #4: use old type=? for everything except lambda + [(((~literal #%plain-lambda) (x:id ...) t1 ...) + ((~literal #%plain-lambda) (y:id ...) t2 ...)) + (and (stx-length=? #'(x ...) #'(y ...)) + (stx-length=? #'(t1 ...) #'(t2 ...)) + (stx-andmap + (λ (t1 t2) + ((current-type=?) (substs #'(y ...) #'(x ...) t1) t2)) + #'(t1 ...) #'(t2 ...)))] + #;[(((~literal #%plain-app) tycon1 ((~literal #%plain-lambda) (x:id ...) k1 ... t1)) + ((~literal #%plain-app) tycon2 ((~literal #%plain-lambda) (y:id ...) k2 ... t2))) + #:when ((current-type=?) #'tycon1 #'tycon2) + #:when (types=? #'(k1 ...) #'(k2 ...)) + #:when (stx-length=? #'(x ...) #'(y ...)) + #:with (z ...) (generate-temporaries #'(x ...)) + ;; alternative #1: install wrappers that checks for x and y and return true + #;(define old-type=? (current-type=?)) + #;(define (new-type=? ty1 ty2) + (or (and (identifier? ty1) (identifier? ty2) + (stx-ormap (λ (x y) + (and (bound-identifier=? ty1 x) (bound-identifier=? ty2 y))) + #'(x ...) #'(y ...))) + (old-type=? ty1 ty2))) + #;(parameterize ([current-type=? new-type=?]) ((current-type=?) #'t1 #'t2)) + ;; alternative #2: subst fresh identifier for both x and y + #;((current-type=?) (substs #'(z ...) #'(x ...) #'t1) + (substs #'(z ...) #'(y ...) #'t2)) + ;; alternative #3: subst y for x in t1 + ((current-type=?) (substs #'(y ...) #'(x ...) #'t1) #'t2)] + [_ (stlc:type=? τ1 τ2)])) + (current-type=? type=?) + (current-typecheck-relation type=?)) + +(define-typed-syntax unfld + [(unfld τ:type-ann e) + #:with (~μ* (tv) τ_body) #'τ.norm + #:with [e- τ_e] (infer+erase #'e) + #:when (typecheck? #'τ_e #'τ.norm) + (⊢ e- : #,(subst #'τ.norm #'tv #'τ_body))]) +(define-typed-syntax fld + [(fld τ:type-ann e) + #:with (~μ* (tv) τ_body) #'τ.norm + #:with [e- τ_e] (infer+erase #'e) + #:when (typecheck? #'τ_e (subst #'τ.norm #'tv #'τ_body)) + (⊢ e- : τ.norm)]) diff --git a/macrotypes/examples/stlc+reco+sub.rkt b/macrotypes/examples/stlc+reco+sub.rkt @@ -0,0 +1,48 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+sub.rkt" #:except #%app #%datum) +(extends "stlc+reco+var.rkt" #:except #%datum +) +;;use type=? and eval-type from stlc+reco+var.rkt, not stlc+sub.rkt +;; but extend sub? from stlc+sub.rkt + +;; Simply-Typed Lambda Calculus, plus subtyping, plus records +;; Types: +;; - types from stlc+sub.rkt +;; Type relations: +;; - sub? extended to records +;; Terms: +;; - terms from stlc+sub.rkt +;; - records and variants from stlc+reco+var + +(define-typed-syntax #%datum + [(#%datum . n:number) #'(stlc+sub:#%datum . n)] + [(#%datum . x) #'(stlc+reco+var:#%datum . x)]) + +(begin-for-syntax + (define old-sub? (current-sub?)) + (define (sub? τ1 τ2) +; (printf "t1 = ~a\n" (syntax->datum τ1)) +; (printf "t2 = ~a\n" (syntax->datum τ2)) + (or + (old-sub? τ1 τ2) + (syntax-parse (list τ1 τ2) + [((~× [k : τk] ...) (~× [l : τl] ...)) + #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) + (stx-map syntax-e (syntax->list #'(k ...)))) + (stx-andmap + (syntax-parser + [(label τlabel) + #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) + ((current-sub?) #'τk_match #'τlabel)]) + #'([l τl] ...))] + [((~∨ [k : τk] ...) (~∨ [l : τl] ...)) + #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) + (stx-map syntax-e (syntax->list #'(k ...)))) + (stx-andmap + (syntax-parser + [(label τlabel) + #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) + ((current-sub?) #'τk_match #'τlabel)]) + #'([l τl] ...))] + [_ #f]))) + (current-sub? sub?) + (current-typecheck-relation (current-sub?))) diff --git a/macrotypes/examples/stlc+reco+var.rkt b/macrotypes/examples/stlc+reco+var.rkt @@ -0,0 +1,132 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+tup.rkt" #:except × ×? tup proj + #:rename [~× ~stlc:×]) +(provide × ∨ (for-syntax ~× ~×* ~∨ ~∨*)) + + +;; Simply-Typed Lambda Calculus, plus records and variants +;; Types: +;; - types from stlc+tup.rkt +;; - redefine tuple type × to records +;; - sum type constructor ∨ +;; Terms: +;; - terms from stlc+tup.rkt +;; - redefine tup to records +;; - sums (var) +;; TopLevel: +;; - define (values only) +;; - define-type-alias + +(provide define-type-alias) +(define-syntax define-type-alias + (syntax-parser + [(_ alias:id τ:type) + #'(define-syntax alias (make-variable-like-transformer #'τ.norm) #;(syntax-parser [x:id #'τ.norm]))] + [(_ (f:id x:id ...) ty) + #'(define-syntax (f stx) + (syntax-parse stx + [(_ x ...) #'ty]))])) + +(define-typed-syntax define + [(define x:id e) + #:with (e- τ) (infer+erase #'e) + #:with y (generate-temporary) + #'(begin- + (define-syntax x (make-rename-transformer (⊢ y : τ))) + (define- y e-))]) + +; re-define tuples as records +; dont use define-type-constructor because I want the : literal syntax +(define-syntax × + (syntax-parser #:datum-literals (:) + [(_ [label:id : τ:type] ...) + #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) + #`(stlc+tup:× valid-τ ...)])) +(begin-for-syntax + (define-syntax ~× + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~stlc:× ((~literal #%plain-app) (quote l) τ_l) ddd)] + [(_ . args) + #'(~and (~stlc:× ((~literal #%plain-app) (quote l) τ_l) (... ...)) + (~parse args #'((l τ_l) (... ...))))]))) + (define ×? stlc+tup:×?) + (define-syntax ~×* + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~or (~× [l : τ_l] ddd) + (~and any (~do (type-error + #:src #'any + #:msg "Expected × type, got: ~a" #'any))))])))) + +;; records +(define-typed-syntax tup #:datum-literals (=) + [(tup [l:id = e] ...) + #:with ([e- τ] ...) (infers+erase #'(e ...)) + (⊢ (list- (list- 'l e-) ...) : (× [l : τ] ...))]) +(define-typed-syntax proj #:literals (quote) + [(proj e_rec l:id) + #:with (e_rec- ([l_τ τ] ...)) (⇑ e_rec as ×) + #:with (_ τ_match) (stx-assoc #'l #'([l_τ τ] ...)) + (⊢ (cadr- (assoc- 'l e_rec-)) : τ_match)]) + +(define-type-constructor ∨/internal #:arity >= 0) + +;; variants +(define-syntax ∨ + (syntax-parser #:datum-literals (:) + [(_ (~and [label:id : τ:type] x) ...) + #:when (> (stx-length #'(x ...)) 0) + #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) + #'(∨/internal valid-τ ...)] + [any + (type-error #:src #'any + #:msg (string-append + "Improper usage of type constructor ∨: ~a, " + "expected (∨ [label:id : τ:type] ...+)") + #'any)])) +(begin-for-syntax + (define ∨? ∨/internal?) + (define-syntax ~∨ + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~∨/internal ((~literal #%plain-app) (quote l) τ_l) ddd)] + [(_ . args) + #'(~and (~∨/internal ((~literal #%plain-app) (quote l) τ_l) (... ...)) + (~parse args #'((l τ_l) (... ...))))]))) + (define-syntax ~∨* + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~and (~or (~∨ [l : τ_l] ddd) + (~and any (~do (type-error + #:src #'any + #:msg "Expected ∨ type, got: ~a" #'any)))) + ~!)])))) ; dont backtrack here + +(define-typed-syntax var #:datum-literals (as =) + [(var l:id = e as τ:type) + #:with (~∨* [l_τ : τ_l] ...) #'τ.norm + #:with match_res (stx-assoc #'l #'((l_τ τ_l) ...)) + #:fail-unless (syntax-e #'match_res) + (format "~a field does not exist" (syntax->datum #'l)) + #:with (_ τ_match) #'match_res + #:with (e- τ_e) (infer+erase #'e) + #:when (typecheck? #'τ_e #'τ_match) + (⊢ (list- 'l e) : τ)]) +(define-typed-syntax case + #:datum-literals (of =>) + [(case e [l:id x:id => e_l] ...) + #:fail-when (null? (syntax->list #'(l ...))) "no clauses" + #:with (e- ([l_x τ_x] ...)) (⇑ e as ∨) + #:fail-unless (= (stx-length #'(l ...)) (stx-length #'(l_x ...))) "wrong number of case clauses" + #:fail-unless (typechecks? #'(l ...) #'(l_x ...)) "case clauses not exhaustive" + #:with (((x-) e_l- τ_el) ...) + (stx-map (λ (bs e) (infer/ctx+erase bs e)) #'(([x : τ_x]) ...) #'(e_l ...)) + #:fail-unless (same-types? #'(τ_el ...)) "branches have different types" + (⊢ (let- ([l_e (car- e-)]) + (cond- [(symbol=?- l_e 'l) (let- ([x- (cadr- e-)]) e_l-)] ...)) + : #,(stx-car #'(τ_el ...)))]) diff --git a/macrotypes/examples/stlc+sub.rkt b/macrotypes/examples/stlc+sub.rkt @@ -0,0 +1,97 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+lit.rkt" #:except #%datum +) +(reuse Bool String add1 #:from "ext-stlc.rkt") +(require (prefix-in ext: (only-in "ext-stlc.rkt" #%datum)) + (only-in "ext-stlc.rkt" current-join)) +(provide (for-syntax subs? current-sub?)) + +;; Simply-Typed Lambda Calculus, plus subtyping +;; Types: +;; - types from and stlc+lit.rkt +;; - Top, Num, Nat +;; Type relations: +;; - sub? +;; - Any <: Top +;; - Nat <: Int +;; - Int <: Num +;; - → +;; Terms: +;; - terms from stlc+lit.rkt, except redefined: datum and + +;; - also * +;; Other: sub? current-sub? + +(define-base-types Top Num Nat) + +(define-primop + : (→ Num Num Num)) +(define-primop * : (→ Num Num Num)) + +(define-typed-syntax #%datum + [(#%datum . n:nat) (⊢ (#%datum- . n) : Nat)] + [(#%datum . n:integer) (⊢ (#%datum- . n) : Int)] + [(#%datum . n:number) (⊢ (#%datum- . n) : Num)] + [(#%datum . x) #'(ext:#%datum . x)]) + +(begin-for-syntax + (define (sub? t1 t2) + ; need this because recursive calls made with unexpanded types + (define τ1 ((current-type-eval) t1)) + (define τ2 ((current-type-eval) t2)) +; (printf "t1 = ~a\n" (syntax->datum τ1)) +; (printf "t2 = ~a\n" (syntax->datum τ2)) + (or ((current-type=?) τ1 τ2) + (Top? τ2))) + (define current-sub? (make-parameter sub?)) + (current-typecheck-relation sub?) + (define (subs? τs1 τs2) + (and (stx-length=? τs1 τs2) + (stx-andmap (current-sub?) τs1 τs2))) + + (define-syntax (define-sub-relation stx) + (syntax-parse stx #:datum-literals (<: =>) + [(_ τ1:id <: τ2:id) + #:with τ1-expander (format-id #'τ1 "~~~a" #'τ1) + #:with τ2-expander (format-id #'τ2 "~~~a" #'τ2) + #:with fn (generate-temporary) + #:with old-sub? (generate-temporary) + #'(begin + (define old-sub? (current-sub?)) + (define (fn t1 t2) + (define τ1 ((current-type-eval) t1)) + (define τ2 ((current-type-eval) t2)) + (syntax-parse (list τ1 τ2) + [(τ1-expander τ) ((current-sub?) #'τ2 #'τ)] + [(τ τ2-expander) ((current-sub?) #'τ #'τ1)] + [_ #f])) + (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) + (current-typecheck-relation (current-sub?)))] + [(_ (~seq τ1:id <: τ2:id (~and (~literal ...) ddd)) + (~seq τ3:id <: τ4:id) + => + (tycon1 . rst1) <: (tycon2 . rst2)) + #:with tycon1-expander (format-id #'tycon1 "~~~a" #'tycon1) + #:with tycon2-expander (format-id #'tycon2 "~~~a" #'tycon2) + #:with fn (generate-temporary) + #:with old-sub? (generate-temporary) + #'(begin + (define old-sub? (current-sub?)) + (define (fn t1 t2) + (define τ1 ((current-type-eval) t1)) + (define τ2 ((current-type-eval) t2)) + (syntax-parse (list τ1 τ2) + [((tycon1-expander . rst1) (tycon2-expander . rst2)) + (and (subs? #'(τ1 ddd) #'(τ2 ddd)) + ((current-sub?) #'τ3 #'τ4))] + [_ #f])) + (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) + (current-typecheck-relation (current-sub?)))])) + + (define-sub-relation Nat <: Int) + (define-sub-relation Int <: Num) + (define-sub-relation t1 <: s1 ... s2 <: t2 => (→ s1 ... s2) <: (→ t1 ... t2)) + + (define (join t1 t2) + (cond + [((current-sub?) t1 t2) t2] + [((current-sub?) t2 t1) t1] + [else #'Top])) + (current-join join)) diff --git a/macrotypes/examples/stlc+tup.rkt b/macrotypes/examples/stlc+tup.rkt @@ -0,0 +1,33 @@ +#lang s-exp macrotypes/typecheck +(extends "ext-stlc.rkt") + +(require (for-syntax racket/list)) + +;; Simply-Typed Lambda Calculus, plus tuples +;; Types: +;; - types from ext-stlc.rkt +;; - × +;; Terms: +;; - terms from ext-stlc.rkt +;; - tup and proj + +(define-type-constructor × #:arity >= 0 + #:arg-variances (λ (stx) + (make-list (stx-length (stx-cdr stx)) covariant))) + +(define-typed-syntax tup + [(tup e ...) + #:with ty-expected (get-expected-type stx) + #:with (e_ann ...) (if (syntax-e #'ty-expected) + (syntax-parse (local-expand #'ty-expected 'expression null) + [(~× ty_exp ...) #'((add-expected e ty_exp) ...)] + [_ #'(e ...)]) + #'(e ...)) + #:with ([e- τ] ...) (infers+erase #'(e_ann ...)) + (⊢ (list- e- ...) : (× τ ...))]) +(define-typed-syntax proj + [(proj e_tup n:nat) + #:with [e_tup- τs_tup] (⇑ e_tup as ×) + #:fail-unless (< (syntax-e #'n) (stx-length #'τs_tup)) "index too large" + (⊢ (list-ref- e_tup- n) : #,(stx-list-ref #'τs_tup (syntax-e #'n)))]) + diff --git a/macrotypes/examples/stlc.rkt b/macrotypes/examples/stlc.rkt @@ -0,0 +1,130 @@ +#lang s-exp macrotypes/typecheck +(provide (for-syntax current-type=? types=?)) +(provide (for-syntax mk-app-err-msg)) + +(require (for-syntax racket/list)) + +;; Simply-Typed Lambda Calculus +;; - no base types; can't write any terms +;; Types: multi-arg → (1+) +;; Terms: +;; - var +;; - multi-arg λ (0+) +;; - multi-arg #%app (0+) +;; Other: +;; - "type" syntax category; defines: +;; - define-base-type +;; - define-type-constructor +;; Typechecking forms: +;; - current-type-eval +;; - current-type=? + +(begin-for-syntax + ;; type eval + ;; - type-eval == full expansion == canonical type representation + ;; - must expand because: + ;; - checks for unbound identifiers (ie, undefined types) + ;; - checks for valid types, ow can't distinguish types and terms + ;; - could parse types but separate parser leads to duplicate code + ;; - later, expanding enables reuse of same mechanisms for kind checking + ;; and type application + (define (type-eval τ) + ; TODO: optimization: don't expand if expanded + ; currently, this causes problems when + ; combining unexpanded and expanded types to create new types + (add-orig (expand/df τ) τ)) + + (current-type-eval type-eval) + + ;; type=? : Type Type -> Boolean + ;; Two types are equivalent when structurally free-identifier=? + ;; - assumes canonical (ie expanded) representation + ;; (new: without syntax-parse) + ;; 2015-10-04: moved to define-syntax-category + #;(define (type=? t1 t2) + ;(printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum t1)) + ;(printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum t2)) + (or (and (identifier? t1) (identifier? t2) (free-identifier=? t1 t2)) + (and (stx-null? t1) (stx-null? t2)) + (and (stx-pair? t1) (stx-pair? t2) + (with-syntax ([(ta ...) t1][(tb ...) t2]) + #;(types=? #'(ta ...) #'(tb ...)) (types=? t1 t2))))) + ;; (old: uses syntax-parse) + #;(define (type=? τ1 τ2) +; (printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum τ1)) +; (printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum τ2)) + (syntax-parse (list τ1 τ2) + [(x:id y:id) (free-identifier=? τ1 τ2)] + [((τa ...) (τb ...)) (types=? #'(τa ...) #'(τb ...))] + [_ #f])) + + #;(define current-type=? (make-parameter type=?)) + #;(current-typecheck-relation type=?) + + ;; convenience fns for current-type=? + #;(define (types=? τs1 τs2) + (and (stx-length=? τs1 τs2) + (stx-andmap (current-type=?) τs1 τs2)))) + +(define-syntax-category type) + +(define-type-constructor → #:arity >= 1 + #:arg-variances (λ (stx) + (syntax-parse stx + [(_ τ_in ... τ_out) + (append + (make-list (stx-length #'[τ_in ...]) contravariant) + (list covariant))]))) + +(define-typed-syntax λ + [(λ bvs:type-ctx e) + #:with (xs- e- τ_res) (infer/ctx+erase #'bvs #'e) + (⊢ (λ- xs- e-) : (→ bvs.type ... τ_res))]) + +(define-for-syntax (mk-app-err-msg stx #:expected [expected-τs #'()] + #:given [given-τs #'()] + #:note [note ""] + #:name [name #f]) + (syntax-parse stx + #;[(app . rst) + #:when (not (equal? '#%app (syntax->datum #'app))) + (mk-app-err-msg (syntax/loc stx (#%app app . rst)) + #:expected expected-τs + #:given given-τs + #:note note + #:name name)] + [(app e_fn e_arg ...) + (define fn-name + (if name name + (format "function ~a" + (syntax->datum (or (get-orig #'e_fn) #'e_fn))))) + (string-append + (format "~a (~a:~a):\nType error applying " + (syntax-source stx) (syntax-line stx) (syntax-column stx)) + fn-name ". " note "\n" + (format " Expected: ~a argument(s) with type(s): " (stx-length expected-τs)) + (string-join (stx-map type->str expected-τs) ", " #:after-last "\n") + " Given:\n" + (string-join + (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line + (syntax->datum #'(e_arg ...)) + (if (stx-length=? #'(e_arg ...) given-τs) + (stx-map type->str given-τs) + (stx-map (lambda (e) "?") #'(e_arg ...)))) + "\n") + "\n")])) + +(define-typed-syntax #%app #:literals (#%app) + [(#%app e_fn e_arg ...) + #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn as →) + #:with ([e_arg- τ_arg] ...) (infers+erase #'(e_arg ...)) + #:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...)) + (type-error #:src stx + #:msg (mk-app-err-msg stx #:expected #'(τ_in ...) + #:given #'(τ_arg ...) + #:note "Wrong number of arguments.")) + #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) + (type-error #:src stx + #:msg (mk-app-err-msg stx #:expected #'(τ_in ...) + #:given #'(τ_arg ...))) + (⊢ (#%app- e_fn- e_arg- ...) : τ_out)]) diff --git a/macrotypes/examples/sysf.rkt b/macrotypes/examples/sysf.rkt @@ -0,0 +1,29 @@ +#lang s-exp macrotypes/typecheck +(extends "stlc+lit.rkt") +(reuse #:from "stlc+rec-iso.rkt") ; want this type=? + +;; System F +;; Type relation: +;; - extend type=? with ∀ +;; Types: +;; - types from stlc+lit.rkt +;; - ∀ +;; Terms: +;; - terms from stlc+lit.rkt +;; - Λ and inst + +(define-type-constructor ∀ #:bvs >= 0) + +(define-typed-syntax Λ + [(Λ (tv:id ...) e) + #:with ((tv- ...) e- τ) (infer/tyctx+erase #'([tv : #%type] ...) #'e) + (⊢ e- : (∀ (tv- ...) τ))]) +(define-typed-syntax inst + [(inst e τ:type ...) + #:with (e- (tvs (τ_body))) (⇑ e as ∀) + ;#:with [e- (~and t (~∀ tvs τ_body))] (infer+erase #'e) + ;#:with (_ Xs τ_orig) (get-orig #'t) ; doesnt work with implicit lifted→ + ;#:with new-orig (substs #'(τ ...) #'Xs #'τ_orig) + ;(⊢ e- : #,(add-orig (substs #'(τ.norm ...) #'tvs #'τ_body) #'new-orig))] + (⊢ e- : #,(substs #'(τ.norm ...) #'tvs #'τ_body))] + [(_ e) #'e]) diff --git a/macrotypes/examples/tests/infer-tests.rkt b/macrotypes/examples/tests/infer-tests.rkt @@ -0,0 +1,364 @@ +#lang s-exp "../infer.rkt" +(require typed-lang-builder/examples/tests/rackunit-typechecking) + +(typecheck-fail (λ (x) x) #:with-msg "could not infer type of x; add annotation\\(s\\)") + +; should bidirectional checking work for this case? +; I think no, since TR doesnt handle it either +;(typecheck-fail (λ (x) (+ x 1)) #:with-msg "add annotations") +; 2015-12-18: can infer this type now +(check-type (λ (x) (+ x 1)) : (→ Int Int)) +; can't check this case either +(typecheck-fail ((λ (f) (f 10)) (λ (x) x)) #:with-msg "add annotation\\(s\\)") + +; stlc+lit tests with app, but infer types (no annotations) +(check-type ((λ (x) x) 1) : Int ⇒ 1) +(check-type ((λ (f x y) (f x y)) + 1 2) : Int ⇒ 3) +(check-type ((λ (x) (+ x x)) 10) : Int ⇒ 20) + +(check-type ((λ (x) ((λ (y) y) x)) 10) : Int ⇒ 10) + +; top level functions +(define (f [x : Int] → Int) x) +(check-type f : (→ Int Int)) +(check-type (f 1) : Int ⇒ 1) +(typecheck-fail (f (λ ([x : Int]) x))) + +(define {X} (g [x : X] → X) x) +(check-type g : (→ {X} X X)) + +; (inferred) polymorpic instantiation +(check-type (g 1) : Int ⇒ 1) +(check-type (g #f) : Bool ⇒ #f) ; different instantiation +(check-type (g add1) : (→ Int Int)) +(check-type (g +) : (→ Int Int Int)) + +; function polymorphic in list element +(define {X} (g2 [lst : (List X)] → (List X)) lst) +(check-type g2 : (→ {X} (List X) (List X))) +(typecheck-fail (g2 1) #:with-msg "expected: \\(List X\\)\n *given: Int") ; TODO: more precise err msg +(check-type (g2 (nil {Int})) : (List Int) ⇒ (nil {Int})) +(check-type (g2 (nil {Bool})) : (List Bool) ⇒ (nil {Bool})) +(check-type (g2 (nil {(List Int)})) : (List (List Int)) ⇒ (nil {(List Int)})) +(check-type (g2 (nil {(→ Int Int)})) : (List (→ Int Int)) ⇒ (nil {(List (→ Int Int))})) +(check-type (g2 (cons 1 nil)) : (List Int) ⇒ (cons 1 nil)) +(check-type (g2 (cons "1" nil)) : (List String) ⇒ (cons "1" nil)) + +(define {X} (g3 [lst : (List X)] → X) (hd lst)) +(check-type g3 : (→ {X} (List X) X)) +(check-type g3 : (→ {A} (List A) A)) +(check-not-type g3 : (→ {A B} (List A) B)) +(typecheck-fail (g3) #:with-msg "Expected.+arguments with type.+List") ; TODO: more precise err msg +(check-type (g3 (nil {Int})) : Int) ; runtime fail +(check-type (g3 (nil {Bool})) : Bool) ; runtime fail +(check-type (g3 (cons 1 nil)) : Int ⇒ 1) +(check-type (g3 (cons "1" nil)) : String ⇒ "1") + +; recursive fn +(define (recf [x : Int] → Int) (recf x)) +(check-type recf : (→ Int Int)) + +(define (countdown [x : Int] → Int) + (if (zero? x) + 0 + (countdown (sub1 x)))) +(check-type (countdown 0) : Int ⇒ 0) +(check-type (countdown 10) : Int ⇒ 0) +(typecheck-fail (countdown "10") #:with-msg "expected: Int\n *given: String") + +; list abbrv +(check-type (list 1 2 3) : (List Int)) +(typecheck-fail (list 1 "3") + #:with-msg "cons expression.+with type Int to list.+with type \\(List String\\)") + + +(define {X Y} (map [f : (→ X Y)] [lst : (List X)] → (List Y)) + (if (nil? lst) + nil ; test expected-type propagation of if and define + ; recursive call should instantiate to "concrete" X and Y types + (cons (f (hd lst)) (map f (tl lst))))) + +(check-type map : (→ {X Y} (→ X Y) (List X) (List Y))) +(check-type map : (→ {Y X} (→ Y X) (List Y) (List X))) +(check-type map : (→ {A B} (→ A B) (List A) (List B))) +(check-not-type map : (→ {X Y} (→ X X) (List X) (List X))) +(check-not-type map : (→ {X} (→ X X) (List X) (List X))) + +; nil without annotation tests fn-first, left-to-right arg inference (2nd #%app case) +(check-type (map add1 nil) : (List Int) ⇒ (nil {Int})) +(check-type (map add1 (list)) : (List Int) ⇒ (nil {Int})) +(check-type (map add1 (list 1 2 3)) : (List Int) ⇒ (list 2 3 4)) +(typecheck-fail (map add1 (list "1")) #:with-msg + (string-append + "couldn't unify Int and String\n" + " *expected: \\(→ X Y\\), \\(List X\\)\n" + " *given: \\(→ Int Int\\), \\(List String\\)")) +(check-type (map (λ ([x : Int]) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) +; doesnt work yet +;; 2015-12-18: dont need annotations on lambdas with concrete type +(check-type (map (λ (x) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) + +(define {X} (filter [p? : (→ X Bool)] [lst : (List X)] → (List X)) + (if (nil? lst) + nil + (if (p? (hd lst)) + (cons (hd lst) (filter p? (tl lst))) + (filter p? (tl lst))))) +(define {X} (filter/let [p? : (→ X Bool)] [lst : (List X)] → (List X)) + (if (nil? lst) + nil + (let ([x (hd lst)] [filtered-rst (filter p? (tl lst))]) + (if (p? x) (cons x filtered-rst) filtered-rst)))) + +(check-type (filter zero? nil) : (List Int) ⇒ (nil {Int})) +(check-type (filter zero? (list 1 2 3)) : (List Int) ⇒ (nil {Int})) +(check-type (filter zero? (list 0 1 2)) : (List Int) ⇒ (list 0)) +(check-type (filter (λ ([x : Int]) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) +;; 2015-12-18: dont need annotations on lambdas with concrete type +(check-type (filter (λ (x) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) + +(define {X Y} (foldr [f : (→ X Y Y)] [base : Y] [lst : (List X)] → Y) + (if (nil? lst) + base + (f (hd lst) (foldr f base (tl lst))))) +(define {X Y} (foldl [f : (→ X Y Y)] [acc : Y] [lst : (List X)] → Y) + (if (nil? lst) + acc + (foldr f (f (hd lst) acc) (tl lst)))) + +(define {X} (all? [p? : (→ X Bool)] [lst : (List X)] → Bool) + (if (nil? lst) + #t + (and (p? (hd lst)) (all? p? (tl lst))))) + +(define {X} (tails [lst : (List X)] → (List (List X))) + (if (nil? lst) + (list nil) + (cons lst (tails (tl lst))))) + +; creates backwards list +(define {X} (build-list [n : Int] [f : (→ Int X)] → (List X)) + (if (zero? (sub1 n)) + (list (f 0)) + (cons (f (sub1 n)) (build-list (sub1 n) f)))) +(check-type (build-list 1 add1) : (List Int) ⇒ (list 1)) +(check-type (build-list 3 add1) : (List Int) ⇒ (list 3 2 1)) +(check-type (build-list 5 sub1) : (List Int) ⇒ (list 3 2 1 0 -1)) + +(define {X} (append [lst1 : (List X)] [lst2 : (List X)] → (List X)) + (if (nil? lst1) + lst2 + (cons (hd lst1) (append (tl lst1) lst2)))) + +; nqueens +(define-type-alias Queen (× Int Int)) +(define (q-x [q : Queen] → Int) (proj q 0)) +(define (q-y [q : Queen] → Int) (proj q 1)) +(define (Q [x : Int] [y : Int] → Queen) (tup x y)) + +(define (safe? [q1 : Queen] [q2 : Queen] → Bool) + (let ([x1 (q-x q1)][y1 (q-y q1)] + [x2 (q-x q2)][y2 (q-y q2)]) + (not (or (= x1 x2) (= y1 y2) (= (abs (- x1 x2)) (abs (- y1 y2))))))) +(define (safe/list? [qs : (List Queen)] → Bool) + (if (nil? qs) + #t + (let ([q1 (hd qs)]) + (all? (λ ([q2 : Queen]) (safe? q1 q2)) (tl qs))))) +(define (valid? [lst : (List Queen)] → Bool) + (all? safe/list? (tails lst))) + +(define (nqueens [n : Int] → (List Queen)) + (let* ([process-row + (λ ;([r : Int] [all-possible-so-far : (List (List Queen))]) + (r all-possible-so-far) + (foldr + ;; 2015-12-18: dont need annotations on lambdas with concrete type + (λ ;([qs : (List Queen)] [new-qss : (List (List Queen))]) + (qs new-qss) + (append + (map + ;; 2015-12-18: dont need annotations on lambdas with concrete type + (λ (c) (cons (Q r c) qs)) + (build-list n add1)) + new-qss)) + nil + all-possible-so-far))] + [all-possible (foldl process-row (list nil) (build-list n add1))]) + (let ([solns (filter valid? all-possible)]) + (if (nil? solns) + nil + (hd solns))))) + +(check-type nqueens : (→ Int (List Queen))) +(check-type (nqueens 1) : (List Queen) ⇒ (list (list 1 1))) +(check-type (nqueens 2) : (List Queen) ⇒ (nil {Queen})) +(check-type (nqueens 3) : (List Queen) ⇒ (nil {Queen})) +(check-type (nqueens 4) : (List Queen) ⇒ (list (Q 3 1) (Q 2 4) (Q 1 2) (Q 4 3))) +(check-type (nqueens 5) : (List Queen) ⇒ (list (Q 4 2) (Q 3 4) (Q 2 1) (Q 1 3) (Q 5 5))) + +; -------------------------------------------------- +; all ext-stlc tests should still pass (copied below): +;; tests for stlc extensions +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) + +(typecheck-fail + ((λ ([x : Unit]) x) 2) + #:with-msg + "expected: Unit\n *given: Int") +(typecheck-fail + ((λ ([x : Unit]) x) void) + #:with-msg + "expected: Unit\n *given: \\(→ Unit\\)") + +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(check-type (begin 1) : Int) + +(typecheck-fail (begin) #:with-msg "expected more terms") +;; 2016-03-06: begin terms dont need to be Unit +(check-type (begin 1 2 3) : Int) +#;(typecheck-fail + (begin 1 2 3) + #:with-msg "Expected expression 1 to have Unit type, got: Int") + +(check-type (begin (void) 1) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (begin (void) x)) 1) : Int) +(check-type ((λ ([x : Int]) (begin x)) 1) : Int) +(check-type ((λ ([x : Int]) (begin (begin x))) 1) : Int) +(check-type ((λ ([x : Int]) (begin (void) (begin (void) x))) 1) : Int) +(check-type ((λ ([x : Int]) (begin (begin (void) x))) 1) : Int) + +;;ascription +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) +(typecheck-fail (ann 1 : Bool) #:with-msg "ann: 1 does not have type Bool") +;ann errs +(typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier") +(typecheck-fail (ann 1 : 1) #:with-msg "not a valid type") +(typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a valid type") +(typecheck-fail (ann Int : Int) #:with-msg "does not have type Int") + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail + (let ([x #f]) (+ x 1)) + #:with-msg + "expected: Int, Int\n *given: Bool, Int") +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y)) + #:with-msg "x: unbound identifier") + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail + (let* ([x #t] [y (+ x 1)]) 1) + #:with-msg + "expected: Int, Int\n *given: Bool, Int") + +; letrec +(typecheck-fail + (letrec ([(x : Int) #f] [(y : Int) 1]) y) + #:with-msg + "letrec: type check fail, args have wrong type:\n#f has type Bool, expected Int") +(typecheck-fail + (letrec ([(y : Int) 1] [(x : Int) #f]) x) + #:with-msg + "letrec: type check fail, args have wrong type:.+#f has type Bool, expected Int") + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; check some more err msgs +(typecheck-fail + (and "1" #f) + #:with-msg "Expected expression \"1\" to have Bool type, got: String") +(typecheck-fail + (and #t "2") + #:with-msg + "Expected expression \"2\" to have Bool type, got: String") +(typecheck-fail + (or "1" #f) + #:with-msg + "Expected expression \"1\" to have Bool type, got: String") +(typecheck-fail + (or #t "2") + #:with-msg + "Expected expression \"2\" to have Bool type, got: String") +;; 2016-03-10: change if to work with non-false vals +(check-type (if "true" 1 2) : Int -> 1) +(typecheck-fail + (if #t 1 "2") + #:with-msg + "branches have incompatible types: Int and String") + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) + +(typecheck-fail + ((λ ([x : Bool]) x) 1) + #:with-msg + "expected: Bool\n *given: Int") +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail + (λ ([f : Int]) (f 1 2)) + #:with-msg + "Expected expression f to have ∀ type, got: Int") + +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) + : Int ⇒ 3) + +(typecheck-fail + (+ 1 (λ ([x : Int]) x)) + #:with-msg + "expected: Int, Int\n *given: Int, \\(→ Int Int\\)") +(typecheck-fail + (λ ([x : (→ Int Int)]) (+ x x)) + #:with-msg + "expected: Int, Int\n *given: \\(→ Int Int\\), \\(→ Int Int\\)") +(typecheck-fail + ((λ ([x : Int] [y : Int]) y) 1) + #:with-msg "Wrong number of arguments") + +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/tapl/tests/lam-testing-tests.rkt b/macrotypes/examples/tests/lam-testing-tests.rkt diff --git a/macrotypes/examples/tests/stlc+occurrence-tests.rkt b/macrotypes/examples/tests/stlc+occurrence-tests.rkt @@ -0,0 +1,618 @@ +#lang s-exp "../stlc+occurrence.rkt" +(require typed-lang-builder/examples/tests/rackunit-typechecking) + +;; ----------------------------------------------------------------------------- +;; basic types & syntax + +(check-type 1 : Int) +(check-type #f : Boolean) +(check-type "hello" : Str) +(check-type 1 : Top) +(check-type (λ ([x : (∪ Boolean Int)]) x) + : (→ (∪ Boolean Int) (∪ Boolean Int))) + +(typecheck-fail + (λ ([x : ∪]) x) + #:with-msg "Improper usage of type constructor ∪: ∪, expected >= 1 arguments") +(typecheck-fail + (λ ([x : (∪)]) x) + #:with-msg "Improper usage of type constructor ∪") +(typecheck-fail + (λ ([x : (∪ ∪)]) x) + #:with-msg "Improper usage of type constructor ∪") +(typecheck-fail + (λ ([x : (1 ∪)]) x) + #:with-msg "") +(typecheck-fail + (λ ([x : (Int ∪)]) x) + #:with-msg "expected identifier") +(typecheck-fail + (λ ([x : (→ ∪ ∪)]) x) + #:with-msg "Improper usage of type constructor ∪") +(typecheck-fail + (λ ([x : (→ Int ∪)]) x) + #:with-msg "Improper usage of type constructor ∪: ∪, expected >= 1 arguments") +(typecheck-fail + (λ ([x : (∪ Int →)]) x) + #:with-msg "Improper usage of type constructor →: →, expected >= 1 arguments") + +;; ----------------------------------------------------------------------------- +;; --- type evaluation + +(check-type (λ ([x : (∪ Int Int Int Int)]) x) + : (→ Int Int)) +(check-type (λ ([x : (∪ Int Boolean)]) 42) + : (→ (∪ Boolean Int) Int)) +(check-type (λ ([x : (∪ Int Boolean Boolean Int)]) x) + : (→ (∪ Boolean Int) (∪ Boolean Int))) +(check-type (λ ([x : (∪ (∪ Int Boolean))]) 42) + : (→ (∪ Int Boolean) Int)) +(check-type (λ ([x : (∪ Int Boolean)]) 42) + : (→ (∪ (∪ Int Boolean)) Int)) +(check-type (λ ([x : (∪ Int Boolean)]) 42) + : (→ (∪ (∪ Int Boolean) (∪ Int Boolean)) Int)) + + +;; ----------------------------------------------------------------------------- +;; --- subtyping + +;; ---- basics +(check-type 1 : (∪ Int)) +(check-type 1 : (∪ (∪ Int))) +(check-type (λ ([x : Int]) x) + : (→ Bot Top)) + +(check-not-type 1 : (∪ Boolean)) + +;; - AMB : t <: t' => t <: (U ... t' ...) +(check-type 1 : (∪ Boolean Int)) +(check-type -1 : (∪ Int Boolean)) +(check-type 1 : (∪ Boolean Int (→ Boolean Boolean))) +(check-type 1 : (∪ (∪ Int Boolean) (∪ Int Boolean))) + +(check-not-type 1 : (∪ Boolean (→ Int Int))) + +;; --- EXT : (U t' ...) <: (U t t' ...) +(check-type (λ ([x : (∪ Int Boolean)]) x) + : (→ (∪ Int Boolean) (∪ Int Boolean Str))) +(check-type (λ ([x : (∪ Int Boolean)]) x) + : (→ (∪ Boolean) (∪ Int Boolean Str))) + +(check-not-type (λ ([x : (∪ Int Boolean)]) x) + : (→ (∪ Int Boolean) (∪ Int))) +(check-not-type (λ ([x : (∪ Int Boolean)]) x) + : (→ (∪ Boolean Int Str) (∪ Int Boolean))) + +;; --- SUB : a<:b => (U a t' ...) <: (U b t' ...) +(check-type (λ ([x : (∪ Int Str)]) x) + : (→ (∪ Int Str) (∪ Num Str))) +(check-type (λ ([x : (∪ Int Str)]) x) + : (→ (∪ Nat Str) (∪ Num Str))) + +(check-type (λ ([x : (∪ Int Str)]) x) + : (→ (∪ Int Str) Top)) + +(check-not-type (λ ([x : (∪ Int Str)]) x) + : (→ Top (∪ Num Str))) + +;; --- ALL +(check-type (λ ([x : (∪ Boolean Int Str)]) x) + : (→ (∪ Boolean Int Str) Top)) +(check-type (λ ([x : (∪ Nat Int Num)]) x) + : (→ (∪ Nat Int Num) Num)) +(check-type (λ ([x : (∪ Nat Int Num)]) x) + : (→ Nat Num)) + +;; --- misc +;; Because Int<:(U Int ...) +(check-type (λ ([x : (∪ Int Nat)]) #t) + : (→ Int Boolean)) + +;; ----------------------------------------------------------------------------- +;; --- Basic Filters (applying functions) + +;; --- is-boolean? +(check-type + (λ ([x : (∪ Boolean Int)]) + (test [Boolean ? x] + #t + #f)) + : (→ (∪ Boolean Int) Boolean)) +(check-type + ((λ ([x : (∪ Boolean Int)]) + (test (Boolean ? x) + #t + #f)) #t) + : Boolean ⇒ #t) +(check-type + ((λ ([x : (∪ Boolean Int)]) + (test (Boolean ? x) + #t + #f)) 902) + : Boolean ⇒ #f) + +;; --- successor +(check-type + (λ ([x : (∪ Int Boolean)]) + (test (Int ? x) + (+ 1 x) + 0)) + : (→ (∪ Int Boolean) (∪ Num Nat))) +(check-type + ((λ ([x : (∪ Int Boolean)]) + (test (Int ? x) + (+ 1 x) + 0)) #f) + : Num ⇒ 0) +(check-type + ((λ ([x : (∪ Int Boolean)]) + (test (Int ? x) + (+ 1 x) + 1)) #t) + : Num ⇒ 1) +(check-type + ((λ ([x : (∪ Int Boolean)]) + (test (Int ? x) + (+ 1 x) + 0)) 9000) + : Num ⇒ 9001) + +;; ;; --- Do-nothing filter +(check-type + (λ ([x : Int]) + (test (Int ? x) #t #f)) + : (→ Int Boolean)) +(check-type + (λ ([x : Int]) + (test (Boolean ? x) 0 x)) + : (→ Int (∪ Nat Int))) + +;; --- Filter a subtype +(check-type + (λ ([x : (∪ Nat Boolean)]) + (test (Int ? x) + x + x)) + : (→ (∪ Nat Boolean) (∪ Int (∪ Nat Boolean)))) + +(check-type + (λ ([x : (∪ Int Boolean)]) + (test (Nat ? x) + x + x)) + : (→ (∪ Boolean Int) (∪ Int Nat Boolean))) + +;; --- Filter a supertype +(check-type + (λ ([x : (∪ Int Boolean)]) + (test (Num ? x) + 1 + x)) + : (→ (∪ Boolean Int) (∪ Nat Boolean))) + +(check-type + ((λ ([x : (∪ Int Boolean)]) + (test (Num ? x) + #f + x)) #t) + : Boolean + ⇒ #t) + +;; Should filter all the impossible types +(check-type + ((λ ([x : (∪ Nat Int Num Boolean)]) + (test (Num ? x) + #f + x)) #t) + : Boolean + ⇒ #t) + +;; Can refine non-union types +(check-type + ((λ ([x : Top]) + (test (Str ? x) + x + "nope")) + "yes") + : Str ⇒ "yes") + +;; ----------------------------------------------------------------------------- +;; --- misc subtyping + filters (regression tests) +(check-type + (λ ([x : (∪ Int Boolean)]) + (test (Int ? x) + 0 + 1)) + : (→ (∪ Int Boolean) Nat)) +(check-type + (λ ([x : (∪ Int Boolean)]) + (test (Int ? x) + 0 + 1)) + : (→ (∪ Int Boolean) Int)) + +;; ----------------------------------------------------------------------------- +;; --- Invalid filters + +(typecheck-fail + (λ ([x : (∪ Int Boolean)]) + (test (1 ? x) #t #f)) + #:with-msg "not a valid type") +(typecheck-fail + (test (1 ? 1) #t #f) + #:with-msg "not a valid type") +(typecheck-fail + (test (1 ? 1) #t #f) + #:with-msg "not a valid type") +(typecheck-fail + (test (#f ? #t) #t #f) + #:with-msg "not a valid type") + +;; ----------------------------------------------------------------------------- +;; --- Subtypes should not be collapsed + +(check-not-type (λ ([x : (∪ Int Nat)]) #t) + : (→ Num Boolean)) +(check-type ((λ ([x : (∪ Int Nat Boolean)]) + (test (Int ? x) + 2 + (test (Nat ? x) + 1 + 0))) + #t) + : Nat ⇒ 0) +(check-type ((λ ([x : (∪ Int Nat)]) + (test (Nat ? x) + 1 + (test (Int ? x) + 2 + 0))) + 1) + : Nat ⇒ 1) +(check-type ((λ ([x : (∪ Int Nat)]) + (test (Int ? x) + 2 + (test (Nat ? x) + 1 + 0))) + -10) + : Nat ⇒ 2) + +;; ----------------------------------------------------------------------------- +;; --- Functions in union + +(check-type (λ ([x : (∪ Int (∪ Nat) (∪ (→ Int Str Int)) (→ (→ (→ Int Int)) Int))]) #t) + : (→ (∪ Int Nat (→ Int Str Int) (→ (→ (→ Int Int)) Int)) Boolean)) + +(check-type (λ ([x : (∪ Int (→ Int Int))]) #t) + : (→ Int Boolean)) + +;; --- filter functions +(check-type + (λ ([x : (∪ Int (→ Int Int))]) + (test ((→ Int Int) ? x) + (x 0) + x)) + : (→ (∪ Int (→ Int Int)) Int)) + +(check-type + (λ ([x : (∪ (→ Int Int Int) (→ Int Int))]) + (test ((→ Int Int) ? x) + (x 0) + (test (Int ? x) + x + (x 1 0)))) + : (→ (∪ (→ Int Int Int) (→ Int Int)) Int)) + +(check-type + ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)]) + (test ((→ Int Int) ? x) + (x 0) + (test (Int ? x) + x + (x 1 0)))) 1) + : Int ⇒ 1) + +(check-type + ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)]) + (test ((→ Int Int) ? x) + (x 0) + (test (Int ? x) + x + (x 1 0)))) (λ ([y : Int]) 5)) + : Int ⇒ 5) + +(check-type + ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)]) + (test ((→ Int Int) ? x) + (x 0) + (test (Int ? x) + x + (x 1 0)))) (λ ([y : Int] [z : Int]) z)) + : Int ⇒ 0) + +;; --- disallow same-arity functions +(typecheck-fail + (λ ([x : (∪ (→ Int Int) (→ Str Str))]) 1) + #:with-msg "Cannot discriminate") + +;; ----------------------------------------------------------------------------- +;; --- Filter with unions + +(check-type + (λ ([x : (∪ Int Str)]) + (test ((∪ Int Str) ? x) + x + "nope")) + : (→ (∪ Int Str) (∪ Int Str))) + +(check-type + (λ ([x : (∪ Int Str Boolean)]) + (test ((∪ Int Str) ? x) + x + "Nope")) + : (→ (∪ Int Str Boolean) (∪ Int Str))) + +(check-type + (λ ([x : (∪ Int Str Boolean)]) + (test ((∪ Int Str) ? x) + (test (Str ? x) + "yes" + "int") + "bool")) + : (→ (∪ Int Str Boolean) Str)) + +(check-type + ((λ ([x : (∪ Str Boolean)]) + (test ((∪ Int Nat Num) ? x) + x + (+ 1 2))) "hi") + : Num ⇒ 3) + +(check-type + ((λ ([x : (∪ Str Int Boolean)]) + (test ((∪ Int Str) ? x) + x + "error")) 1) + : (∪ Str Int) ⇒ 1) + +(check-type + ((λ ([x : (∪ Str Int Boolean)]) + (test ((∪ Int Str) ? x) + x + "error")) "hi") + : (∪ Int Str) ⇒ "hi") + +;; ----------------------------------------------------------------------------- +;; --- Subtyping products + +(check-type (tup 1) : (× Nat)) +(check-type (tup 1) : (× Int)) +(check-type (tup 1) : (× Num)) +(check-type (tup 1) : (× Top)) +(check-type (tup 1) : Top) + +(check-not-type (tup 1) : Boolean) +(check-not-type (tup 1) : Str) +(check-not-type (tup 1) : (× Str)) +(check-not-type (tup 1) : (× Int Str)) +(check-not-type (tup 1) : Bot) + +(check-type (tup 1 2 3) : (× Int Nat Num)) +(check-type (tup 1 2 3) : (× Num Nat Num)) +(check-type (tup 1 2 3) : (× Top Top Num)) +(check-type (tup 1 "2" 3) : (× Int Top Int)) + +(check-not-type (tup 1 2 3) : (× Nat Nat Str)) + +;; ----------------------------------------------------------------------------- +;; --- Latent filters (on products) + +(check-type + (λ ([v : (× (∪ Int Str) Int)]) + (test (Int ? (proj v 0)) + (+ (proj v 0) (proj v 1)) + 0)) + : (→ (× (∪ Int Str) Int) Num)) + +(check-type + ((λ ([v : (× (∪ Int Str) Int)]) + (test (Int ? (proj v 0)) + (+ (proj v 0) (proj v 1)) + 0)) + (tup ((λ ([x : (∪ Int Str)]) x) -2) -3)) + : Num ⇒ -5) + +(check-type + ((λ ([v : (× (∪ Int Str) Int)]) + (test (Int ? (proj v 0)) + (+ (proj v 0) (proj v 1)) + 0)) + (tup "hi" -3)) + : Num ⇒ 0) + +;; --- Use a product as filter + +(check-type + (λ ([x : (∪ Int (× Int Int Int))]) + (test (Int ? x) + (+ 1 x) + (+ (proj x 0) (+ (proj x 1) (proj x 2))))) + : (→ (∪ (× Int Int Int) Int) Num)) + +(check-type + ((λ ([x : (∪ Int (× Int Int Int))]) + (test (Int ? x) + (+ 1 x) + (+ (proj x 0) (+ (proj x 1) (proj x 2))))) + 0) + : Num ⇒ 1) + +(check-type + ((λ ([x : (∪ Int (× Int Int Int))]) + (test (Int ? x) + (+ 1 x) + (+ (proj x 0) (+ (proj x 1) (proj x 2))))) + (tup 2 2 2)) + : Num ⇒ 6) + +(check-type + ((λ ([x : (∪ Int (× Str Nat) (× Int Int Int))]) + (test (Int ? x) + (+ 1 x) + (test ((× Int Int Int) ? x) + (+ (proj x 0) (+ (proj x 1) (proj x 2))) + (proj x 1)))) + (tup 2 2 2)) + : Num ⇒ 6) + +(check-type + ((λ ([x : (∪ Int (× Str Nat) (× Int Int Int))]) + (test (Int ? x) + (+ 1 x) + (test ((× Int Int Int) ? x) + (+ (proj x 0) (+ (proj x 1) (proj x 2))) + (proj x 1)))) + (tup "yolo" 33)) + : Num ⇒ 33) + +;; -- All together now + +(check-type + ((λ ([x : (∪ Int (× Boolean Boolean) (× Int (∪ Str Int)))]) + (test (Int ? x) + "just an int" + (test ((× Boolean Boolean) ? x) + "pair of bools" + (test (Str ? (proj x 1)) + (proj x 1) + "pair of ints")))) + (tup 33 "success")) + : Str ⇒ "success") + +(check-type + ((λ ([x : (∪ Int (× Int Int) (× Int (∪ Str Int)))]) + (test (Int ? x) + "just an int" + (test ((× Int Int) ? x) + "pair of ints" + (test (Str ? (proj x 1)) + (proj x 1) + "another pair of ints")))) + (tup 33 "success")) + : Str ⇒ "success") + +;; ----------------------------------------------------------------------------- +;; --- Filter lists + +(check-type + (λ ([x : (List (∪ Int Str))]) + (test ((List Str) ? x) + x + #f)) + : (→ (List (∪ Int Str)) (∪ Boolean (List Str)))) + +;; -- -subtyping lists +(check-type + (cons 1 (nil {Nat})) + : (List Int)) + +(check-type + ((λ ([filter/3 : (→ (List (∪ Int Str)) (List Int))] + [add*/3 : (→ Num (List Num) (List Num))] + [xs : (× (∪ Int Str) (∪ Int Str) (∪ Int Str))]) + (add*/3 5 (filter/3 (cons (proj xs 0) + (cons (proj xs 1) + (cons (proj xs 2) + (nil {(∪ Str Int)}))))))) + ;; filter (okay this is a little tricky for recursion) + (λ ([xs : (List (∪ Int Str))]) + ((λ ([v1 : (∪ Int Str)] + [v2 : (∪ Int Str)] + [v3 : (∪ Int Str)]) + (test (Int ? v1) + (cons v1 (test (Int ? v2) + (cons v2 (test (Int ? v3) + (cons v3 (nil {Int})) + (nil {Int}))) + (test (Int ? v3) + (cons v3 (nil {Int})) + (nil {Int})))) + (test (Int ? v2) + (cons v2 (test (Int ? v3) + (cons v3 (nil {Int})) + (nil {Int}))) + (test (Int ? v3) + (cons v3 (nil {Int})) + (nil {Int}))))) + (head xs) (head (tail xs)) (head (tail (tail xs))))) + ;; add3 + (λ ([n : Num] [xs : (List Num)]) + (cons (+ n (head xs)) + (cons (+ n (head (tail xs))) + (cons (+ n (head (tail (tail xs)))) + (nil {Num}))))) + ;; xs (3-tuple) + (tup 1 "foo" 3)) + : (List Num)) + +;; ----------------------------------------------------------------------------- +;; --- ICFP'10 examples + +;; -- Exaple 1 (x can have any type) +(check-type + (λ ([x : Top]) + (test (Num ? x) + (+ 1 x) + 0)) + : (→ Top Num)) + +;; -- Example 2 +(check-type + (λ ([x : (∪ Str Num)] + [str-length : (→ Str Num)]) + (test (Num ? x) + (+ 1 x) + (str-length x))) + : (→ (∪ Str Num) (→ Str Num) Num)) + +;; -- TODO Example 3 (requires IF) +;; (check-type +;; (λ ([member : (→ Num (List Num) Boolean)]) +;; (λ ([x : Num] [l : (List Num)]) +;; (if (member x l) +;; <compute with x> +;; <fail>))) +;; : <compute-result> + +;; -- Example 4 +(check-type + (λ ([x : (∪ Num Str Top)] [f : (→ (∪ Num Str) Num)]) + (test ((∪ Num Str) ? x) + (f x) + 0)) + : (→ (∪ Num Str Top) (→ (∪ Num Str) Num) Num)) + +;; Exmample 10 (we don't allow non-homogenous lists, so need to select head before filtering) +(check-type + (λ ([p : (List (∪ Nat Str))]) + ((λ ([x : (∪ Nat Str)]) + (test (Num ? x) + (+ 1 x) + 7)) + (head p))) + : (→ (List (∪ Nat Str)) Num)) + +;; ----------------------------------------------------------------------------- +;; --- TODO CPS filters + +;; ----------------------------------------------------------------------------- +;; --- TODO Filter on values (should do nothing) + +;; (check-type +;; (test (Int ? 1) #t #f) +;; : Boolean) + +;; ----------------------------------------------------------------------------- +;; --- TODO Values as filters (check equality) + diff --git a/macrotypes/examples/tests/stlc+overloading-tests.rkt b/macrotypes/examples/tests/stlc+overloading-tests.rkt @@ -0,0 +1,120 @@ +#lang s-exp "../stlc+overloading.rkt" +(require typed-lang-builder/examples/tests/rackunit-typechecking) + +;; ----------------------------------------------------------------------------- +;; --- syntax for ψ types + +(typecheck-fail + (signature (to-string0 α) (→ α Str Str)) + #:with-msg "Expected") + +(typecheck-fail + (signature (to-string0 α) (→ Str Str)) + #:with-msg "Expected") + +(typecheck-fail + (signature (to-string0 α) (→ α Str)) + #:with-msg "not allowed in an expression context") + +;; ----------------------------------------------------------------------------- +;; --- basic overloading + +(signature (to-string α) (→ α Str)) + +(typecheck-fail + (to-string 1) + #:with-msg "Resolution for 'to-string' failed") + +(typecheck-fail + (to-string "yolo") + #:with-msg "Resolution for 'to-string' failed") + +;; -- can later add cases to an overloaded name +(instance (to-string Nat) + (λ ([x : Nat]) "nat")) + +(instance (to-string Str) + (λ ([x : Str]) "string")) + +(check-type + (to-string 3) + : Str ⇒ "nat") + +(typecheck-fail + (to-string (+ 0 0)) + #:with-msg "Resolution for 'to-string' failed") + +(instance (to-string Num) + (λ ([x : Num]) "num")) + +(check-type + (to-string (+ 2 2)) + : Str ⇒ "num") + +(check-type + (to-string -1) + : Str ⇒ "num") + +(check-type + (to-string "hi") + : Str ⇒ "string") + +;; -- use 'resolve' to get exact matches + +(check-type + ((resolve to-string Nat) 1) + : Str ⇒ "nat") + +(check-type + ((resolve to-string Num) 1) + : Str ⇒ "num") + +(typecheck-fail + (resolve to-string Int) + #:with-msg "Resolution for 'to-string' failed") + +(typecheck-fail + ((resolve to-string Num) "hello") + #:with-msg (expected "Num" #:given "Str")) + +;; -- instances are type-checked. They must match +(typecheck-fail + (instance (to-string Int) + (λ ([x : Num]) "num")) + #:with-msg "must be the instance type") + +(typecheck-fail + (instance (to-string Int) + (λ ([x : Int]) 0)) + #:with-msg "must match template codomain") + +(typecheck-fail + (instance (to-string Int) + 42) + #:with-msg "May only overload single-argument functions") + +;; -- no overlapping instances +(typecheck-fail + (instance (to-string Nat) + (λ ([x : Nat]) "wrong")) + #:with-msg "Overlaps with existing instance") + +;; -- can't instantiate non-overloadeds +(typecheck-fail + (λ ([x : (→ Int Int)]) + (instance (x Int) + 0)) + #:with-msg "Identifier 'x' is not overloaded") + +;; -- explicit resolve + +;; -- recursive instances are fine [TODO really want (List α)] +(instance (to-string (List Nat)) + (λ ([x : (List Nat)]) "listnat")) + +(check-type + (to-string (cons 1 (cons 2 (nil {Nat})))) + : Str ⇒ "listnat") + +;; -- higher-order use + diff --git a/tapl/postfix-in.rkt b/macrotypes/postfix-in.rkt diff --git a/tapl/stx-utils.rkt b/macrotypes/stx-utils.rkt diff --git a/tapl/type-constraints.rkt b/macrotypes/type-constraints.rkt diff --git a/tapl/typecheck.rkt b/macrotypes/typecheck.rkt diff --git a/tapl/variance-constraints.rkt b/macrotypes/variance-constraints.rkt diff --git a/tapl/exist.rkt b/tapl/exist.rkt @@ -1,74 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+reco+var.rkt") -(reuse #:from "stlc+rec-iso.rkt") ; want type=?, but only need to load current-type=? - -;; existential types -;; Types: -;; - types from stlc+reco+var.rkt -;; - ∃ -;; Terms: -;; - terms from stlc+reco+var.rkt -;; - pack and open -;; Other: type=? from stlc+rec-iso.rkt - - -(define-type-constructor ∃ #:bvs = 1) - -(define-typed-syntax pack - [(pack (τ:type e) as ∃τ:type) - #:with (~∃* (τ_abstract) τ_body) #'∃τ.norm - #:with [e- τ_e] (infer+erase #'e) - #:when (typecheck? #'τ_e (subst #'τ.norm #'τ_abstract #'τ_body)) - (⊢ e- : ∃τ.norm)]) - -(define-typed-syntax open #:datum-literals (<=) - [(open ([(tv:id x:id) <= e_packed]) e) - #:with [e_packed- ((τ_abstract) (τ_body))] (⇑ e_packed as ∃) - ;; The subst below appears to be a hack, but it's not really. - ;; It's the (TaPL) type rule itself that is fast and loose. - ;; Leveraging the macro system's management of binding reveals this. - ;; - ;; Specifically, here is the TaPL Unpack type rule, fig24-1, p366: - ;; Γ ⊢ t_1 : {∃X,T_12} - ;; Γ,X,x:T_12 ⊢ t_2 : T_2 - ;; ------------------------------ - ;; Γ ⊢ let {X,x}=t_1 in t_2 : T_2 - ;; - ;; There's *two* separate binders, the ∃ and the let, - ;; which the rule conflates. - ;; - ;; Here's the rule rewritten to distinguish the two binding positions: - ;; Γ ⊢ t_1 : {∃X_1,T_12} - ;; Γ,X_???,x:T_12 ⊢ t_2 : T_2 - ;; ------------------------------ - ;; Γ ⊢ let {X_2,x}=t_1 in t_2 : T_2 - ;; - ;; The X_1 binds references to X in T_12. - ;; The X_2 binds references to X in t_2. - ;; What should the X_??? be? - ;; - ;; A first guess might be to replace X_??? with both X_1 and X_2, - ;; so all the potentially referenced type vars are bound. - ;; Γ ⊢ t_1 : {∃X_1,T_12} - ;; Γ,X_1,X_2,x:T_12 ⊢ t_2 : T_2 - ;; ------------------------------ - ;; Γ ⊢ let {X_2,x}=t_1 in t_2 : T_2 - ;; - ;; But this example demonstrates that the rule above doesnt work: - ;; (open ([x : X_2 (pack (Int 0) as (∃ (X_1) X_1))]) - ;; ((λ ([y : X_2]) y) x) - ;; Here, x has type X_1, y has type X_2, but they should be the same thing, - ;; so we need to replace all X_1's with X_2 - ;; - ;; Here's the fixed rule, which is implemented here - ;; - ;; Γ ⊢ t_1 : {∃X_1,T_12} - ;; Γ,X_2,x:[X_2/X_1]T_12 ⊢ t_2 : T_2 - ;; ------------------------------ - ;; Γ ⊢ let {X_2,x}=t_1 in t_2 : T_2 - ;; - #:with [_ (x-) (e-) (τ_e)] - (infer #'(e) - #:tvctx #'([tv : #%type]) - #:ctx #`([x : #,(subst #'tv #'τ_abstract #'τ_body)])) - (⊢ (let- ([x- e_packed-]) e-) : τ_e)]) diff --git a/tapl/ext-stlc.rkt b/tapl/ext-stlc.rkt @@ -1,134 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+lit.rkt" #:except #%datum) -(provide (for-syntax current-join)) - -;; Simply-Typed Lambda Calculus, plus extensions (TAPL ch11) -;; Types: -;; - types from stlc+lit.rkt -;; - Bool, String -;; - Unit -;; Terms: -;; - terms from stlc+lit.rkt -;; - literals: bool, string -;; - boolean prims, numeric prims -;; - if -;; - prim void : (→ Unit) -;; - begin -;; - ascription (ann) -;; - let, let*, letrec - -(define-base-type Bool) -(define-base-type String) -(define-base-type Float) -(define-base-type Char) - -(define-typed-syntax #%datum - [(#%datum . b:boolean) (⊢ #,(syntax/loc stx (#%datum- . b)) : Bool)] - [(#%datum . s:str) (⊢ #,(syntax/loc stx (#%datum- . s)) : String)] - [(#%datum . f) #:when (flonum? (syntax-e #'f)) (⊢ #,(syntax/loc stx (#%datum- . f)) : Float)] - [(#%datum . c:char) (⊢ #,(syntax/loc stx (#%datum- . c)) : Char)] - [(#%datum . x) (syntax/loc stx (stlc+lit:#%datum . x))]) - -(define-primop zero? : (→ Int Bool)) -(define-primop = : (→ Int Int Bool)) -(define-primop - : (→ Int Int Int)) -(define-primop add1 : (→ Int Int)) -(define-primop sub1 : (→ Int Int)) -(define-primop not : (→ Bool Bool)) - -(define-typed-syntax and - [(and e1 e2) - #:with e1- (⇑ e1 as Bool) - #:with e2- (⇑ e2 as Bool) - (⊢ (and- e1- e2-) : Bool)]) - -(define-typed-syntax or - [(or e ...) - #:with (e- ...) (⇑s (e ...) as Bool) -; #:with e1- (⇑ e1 as Bool) -; #:with e2- (⇑ e2 as Bool) -; (⊢ (or- e1- e2-) : Bool)]) - (⊢ (or- e- ...) : Bool)]) - -(begin-for-syntax - (define current-join - (make-parameter - (λ (x y) - (unless (typecheck? x y) - (type-error - #:src x - #:msg "branches have incompatible types: ~a and ~a" x y)) - x)))) - -(define-typed-syntax if - [(if e_tst e1 e2) - #:with τ-expected (get-expected-type stx) -; #:with e_tst- (⇑ e_tst as Bool) - #:with [e_tst- _] (infer+erase #'e_tst) - #:with e1_ann #'(add-expected e1 τ-expected) - #:with e2_ann #'(add-expected e2 τ-expected) - #:with (e1- τ1) (infer+erase #'e1_ann) - #:with (e2- τ2) (infer+erase #'e2_ann) - #:with τ-out ((current-join) #'τ1 #'τ2) - (⊢ (if- e_tst- e1- e2-) : τ-out)]) - -(define-base-type Unit) -(define-primop void : (→ Unit)) - -(define-typed-syntax begin - [(begin e_unit ... e) - #:with ([e_unit- _] ...) (infers+erase #'(e_unit ...)) ;(⇑s (e_unit ...) as Unit) - #:with (e- τ) (infer+erase #'e) - (⊢ (begin- e_unit- ... e-) : τ)]) - -(define-typed-syntax ann - #:datum-literals (:) - [(ann e : ascribed-τ:type) - #:with (e- τ) (infer+erase #'(add-expected e ascribed-τ.norm)) - #:fail-unless (typecheck? #'τ #'ascribed-τ.norm) - (format "~a does not have type ~a\n" - (syntax->datum #'e) (syntax->datum #'ascribed-τ)) - (⊢ e- : ascribed-τ)]) - -(define-typed-syntax let - [(let ([x e] ...) e_body) - #:with τ-expected (get-expected-type stx) - #:with ((e- τ) ...) (infers+erase #'(e ...)) - #:with ((x- ...) e_body- τ_body) (infer/ctx+erase #'([x τ] ...) #'(add-expected e_body τ-expected)) - #:fail-unless (or (not (syntax-e #'τ-expected)) ; no expected type - (typecheck? #'τ_body ((current-type-eval) #'τ-expected))) - (format "let body has type ~a, which does not match expected type ~a" - (type->str #'τ_body) (type->str #'τ-expected)) - (⊢ (let- ([x- e-] ...) e_body-) : τ_body)]) - -; dont need to manually transfer expected type -; result template automatically propagates properties -; - only need to transfer expected type when local expanding an expression -; - see let/tc -(define-typed-syntax let* - [(let* () e_body) - #:with τ-expected (get-expected-type stx) - #'e_body] - [(let* ([x e] [x_rst e_rst] ...) e_body) - #:with τ-expected (get-expected-type stx) - #'(let ([x e]) (let* ([x_rst e_rst] ...) e_body))]) - -(define-typed-syntax letrec - [(letrec ([b:type-bind e] ...) e_body) - #:with ((x- ...) (e- ... e_body-) (τ ... τ_body)) - (infers/ctx+erase #'(b ...) #'((add-expected e b.type) ... e_body)) - #:fail-unless (typechecks? #'(b.type ...) #'(τ ...)) - (type-error #:src stx - #:msg (string-append - "letrec: type check fail, args have wrong type:\n" - (string-join - (stx-map - (λ (e τ τ-expect) - (format - "~a has type ~a, expected ~a" - (syntax->datum e) (type->str τ) (type->str τ-expect))) - #'(e ...) #'(τ ...) #'(b.type ...)) - "\n"))) - (⊢ (letrec- ([x- e-] ...) e_body-) : τ_body)]) - - diff --git a/tapl/fomega.rkt b/tapl/fomega.rkt @@ -1,128 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "sysf.rkt" #:except #%datum ∀ Λ inst) -(reuse String #%datum #:from "stlc+reco+var.rkt") - -;; System F_omega -;; Type relation: -;; Types: -;; - types from sysf.rkt -;; - String from stlc+reco+var -;; Terms: -;; - extend ∀ Λ inst from sysf -;; - add tyλ and tyapp -;; - #%datum from stlc+reco+var - -(define-syntax-category kind) - -; want #%type to be equiv to★ -; => edit current-kind? so existing #%type annotations (with no #%kind tag) -; are treated as kinds -; <= define ★ as rename-transformer expanding to #%type -(begin-for-syntax - (current-kind? (λ (k) (or (#%type? k) (kind? k)))) - ;; Try to keep "type?" backward compatible with its uses so far, - ;; eg in the definition of λ or previous type constuctors. - ;; (However, this is not completely possible, eg define-type-alias) - ;; So now "type?" no longer validates types, rather it's a subset. - ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) - (current-type? (λ (t) - (define k (typeof t)) - #;(or (type? t) (★? (typeof t)) (∀★? (typeof t))) - (and ((current-kind?) k) (not (⇒? k)))))) - -; must override, to handle kinds -(provide define-type-alias) -(define-syntax define-type-alias - (syntax-parser - [(_ alias:id τ) - #:with (τ- k_τ) (infer+erase #'τ) - #:fail-unless ((current-kind?) #'k_τ) (format "not a valid type: ~a\n" (type->str #'τ)) - #'(define-syntax alias (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))])) - -(provide ★ (for-syntax ★?)) -(define-for-syntax ★? #%type?) -(define-syntax ★ (make-rename-transformer #'#%type)) -(define-kind-constructor ⇒ #:arity >= 1) -(define-kind-constructor ∀★ #:arity >= 0) - -(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) - -;; alternative: normalize before type=? -; but then also need to normalize in current-promote -(begin-for-syntax - (define (normalize τ) - (syntax-parse τ #:literals (#%plain-app #%plain-lambda) - [x:id #'x] - [(#%plain-app - (#%plain-lambda (tv ...) τ_body) τ_arg ...) - (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] - [(#%plain-lambda (x ...) . bodys) - #:with bodys_norm (stx-map normalize #'bodys) - (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] - [(#%plain-app x:id . args) - #:with args_norm (stx-map normalize #'args) - (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] - [(#%plain-app . args) - #:with args_norm (stx-map normalize #'args) - #:with res (normalize #'(#%plain-app . args_norm)) - (transfer-stx-props #'res τ #:ctx τ)] - [_ τ])) - - (define old-eval (current-type-eval)) - (define (type-eval τ) (normalize (old-eval τ))) - (current-type-eval type-eval) - - (define old-type=? (current-type=?)) - ; ty=? == syntax eq and syntax prop eq - (define (type=? t1 t2) - (let ([k1 (typeof t1)][k2 (typeof t2)]) - (and (or (and (not k1) (not k2)) - (and k1 k2 ((current-type=?) k1 k2))) - (old-type=? t1 t2)))) - (current-type=? type=?) - (current-typecheck-relation (current-type=?))) - -(define-typed-syntax Λ - [(Λ bvs:kind-ctx e) - #:with ((tv- ...) e- τ_e) (infer/ctx+erase #'bvs #'e) - (⊢ e- : (∀ ([tv- : bvs.kind] ...) τ_e))]) - -(define-typed-syntax inst - [(inst e τ ...) - #:with (e- (([tv k] ...) (τ_body))) (⇑ e as ∀) - #:with ([τ- k_τ] ...) (infers+erase #'(τ ...)) - #:when (stx-andmap - (λ (t k) (or ((current-kind?) k) - (type-error #:src t #:msg "not a valid type: ~a" t))) - #'(τ ...) #'(k_τ ...)) - #:when (typechecks? #'(k_τ ...) #'(k ...)) - (⊢ e- : #,(substs #'(τ- ...) #'(tv ...) #'τ_body))]) - -;; TODO: merge with regular λ and app? -;; - see fomega2.rkt -(define-typed-syntax tyλ - [(tyλ bvs:kind-ctx τ_body) - #:with (tvs- τ_body- k_body) (infer/ctx+erase #'bvs #'τ_body) - #:fail-unless ((current-kind?) #'k_body) - (format "not a valid type: ~a\n" (type->str #'τ_body)) - (⊢ (λ- tvs- τ_body-) : (⇒ bvs.kind ... k_body))]) - -(define-typed-syntax tyapp - [(tyapp τ_fn τ_arg ...) - #:with [τ_fn- (k_in ... k_out)] (⇑ τ_fn as ⇒) - #:with ([τ_arg- k_arg] ...) (infers+erase #'(τ_arg ...)) - #:fail-unless (typechecks? #'(k_arg ...) #'(k_in ...)) - (string-append - (format "~a (~a:~a) Arguments to function ~a have wrong kinds(s), " - (syntax-source stx) (syntax-line stx) (syntax-column stx) - (syntax->datum #'τ_fn)) - "or wrong number of arguments:\nGiven:\n" - (string-join - (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line - (syntax->datum #'(τ_arg ...)) - (stx-map type->str #'(k_arg ...))) - "\n" #:after-last "\n") - (format "Expected: ~a arguments with type(s): " - (stx-length #'(k_in ...))) - (string-join (stx-map type->str #'(k_in ...)) ", ")) - (⊢ (#%app- τ_fn- τ_arg- ...) : k_out)]) diff --git a/tapl/fomega2.rkt b/tapl/fomega2.rkt @@ -1,95 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "sysf.rkt" #:except #%datum ∀ Λ inst);#:rename [~∀ ~sysf:∀]) -(reuse String #%datum #:from "stlc+reco+var.rkt") - -; same as fomega.rkt except here λ and #%app works as both type and terms -; - uses definition from stlc, but tweaks type? and kind? predicates -;; → is also both type and kind - -;; System F_omega -;; Type relation: -;; Types: -;; - types from sysf.rkt -;; - String from stlc+reco+var -;; Terms: -;; - extend ∀ Λ inst from sysf -;; - #%datum from stlc+reco+var - -(define-syntax-category kind) - -(begin-for-syntax - (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) - ;; Try to keep "type?" backward compatible with its uses so far, - ;; eg in the definition of λ or previous type constuctors. - ;; (However, this is not completely possible, eg define-type-alias) - ;; So now "type?" no longer validates types, rather it's a subset. - ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) - (current-type? (λ (t) (or (type? t) - (let ([k (typeof t)]) - (or (★? k) (∀★? k))) - ((current-kind?) t))))) - -; must override -(provide define-type-alias) -(define-syntax define-type-alias - (syntax-parser - [(_ alias:id τ) - #:with (τ- k_τ) (infer+erase #'τ) - #'(define-syntax alias (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))])) - -(define-base-kind ★) -(define-kind-constructor ∀★ #:arity >= 0) -(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) - -;; alternative: normalize before type=? -; but then also need to normalize in current-promote -(begin-for-syntax - (define (normalize τ) - (syntax-parse τ #:literals (#%plain-app #%plain-lambda) - [x:id #'x] - [(#%plain-app - (#%plain-lambda (tv ...) τ_body) τ_arg ...) - (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] - [(#%plain-lambda (x ...) . bodys) - #:with bodys_norm (stx-map normalize #'bodys) - (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] - [(#%plain-app x:id . args) - #:with args_norm (stx-map normalize #'args) - (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] - [(#%plain-app . args) - #:with args_norm (stx-map normalize #'args) - (transfer-stx-props (normalize #'(#%plain-app . args_norm)) τ #:ctx τ)] - [_ τ])) - - (define old-eval (current-type-eval)) - (define (type-eval τ) (normalize (old-eval τ))) - (current-type-eval type-eval) - - (define old-type=? (current-type=?)) - (define (type=? t1 t2) - (or (and (★? t1) (#%type? t2)) - (and (#%type? t1) (★? t2)) - (and (syntax-parse (list t1 t2) #:datum-literals (:) - [((~∀ ([tv1 : k1]) tbody1) - (~∀ ([tv2 : k2]) tbody2)) - ((current-type=?) #'k1 #'k2)] - [_ #t]) - (old-type=? t1 t2)))) - (current-type=? type=?) - (current-typecheck-relation (current-type=?))) - -(define-typed-syntax Λ - [(Λ bvs:kind-ctx e) - #:with ((tv- ...) e- τ_e) - (infer/ctx+erase #'bvs #'e) - (⊢ e- : (∀ ([tv- : bvs.kind] ...) τ_e))]) - -(define-typed-syntax inst - [(inst e τ ...) - #:with (e- (([tv k] ...) (τ_body))) (⇑ e as ∀) - #:with ([τ- k_τ] ...) (infers+erase #'(τ ...)) - #:when (stx-andmap (λ (t k) (or ((current-kind?) k) - (type-error #:src t #:msg "not a valid type: ~a" t))) - #'(τ ...) #'(k_τ ...)) - #:when (typechecks? #'(k_τ ...) #'(k ...)) - (⊢ e- : #,(substs #'(τ- ...) #'(tv ...) #'τ_body))]) diff --git a/tapl/fomega3.rkt b/tapl/fomega3.rkt @@ -1,33 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "sysf.rkt" #:except #%datum ∀ Λ inst) -(reuse String #%datum #:from "stlc+reco+var.rkt") -(require (only-in "fomega.rkt" current-kind? ∀★? ★? kind?)) -(reuse ★ ∀ Λ inst define-type-alias ∀★ #:from "fomega.rkt") - -; same as fomega2.rkt --- λ and #%app works as both regular and type versions, -; → is both type and kind --- but reuses parts of fomega.rkt, -; ie removes the duplication in fomega2.rkt - -;; System F_omega -;; Type relation: -;; - redefine current-kind? and current-type so #%app and λ -;; work for both terms and types -;; Types: -;; - types from fomega.rkt -;; - String from stlc+reco+var -;; Terms: -;; - extend ∀ Λ inst from fomega.rkt -;; - #%datum from stlc+reco+var - -;; types and kinds are now mixed, due to #%app and λ -(begin-for-syntax - (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) - ;; Try to keep "type?" backward compatible with its uses so far, - ;; eg in the definition of λ or previous type constuctors. - ;; (However, this is not completely possible, eg define-type-alias) - ;; So now "type?" no longer validates types, rather it's a subset. - ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) - (current-type? (λ (t) (or (type? t) - (let ([k (typeof t)]) - (or (★? k) (∀★? k))) - ((current-kind?) t))))) diff --git a/tapl/fsub.rkt b/tapl/fsub.rkt @@ -1,88 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+reco+sub.rkt" #:except +) -(require (rename-in (only-in "sysf.rkt" ∀? ∀ ~∀) [~∀ ~sysf:∀] [∀ sysf:∀])) - -;; System F<: -;; Types: -;; - types from sysf.rkt and stlc+reco+sub -;; - extend ∀ with bounds -;; Terms: -;; - terms from sysf.rkt and stlc+reco+sub -;; - extend Λ and inst -;; - redefine + with Nat -;; Other -;; - current-promote, expose -;; - extend current-sub? to call current-promote - -(define-primop + : (→ Nat Nat Nat)) - -; can't just call expose in type-eval, -; otherwise typevars will have bound as type, rather than instantiated type -; only need expose during -; 1) subtype checking -; 2) pattern matching -- including base types -(begin-for-syntax - (define (expose t) - (cond [(identifier? t) - (define sub (typeof t #:tag '<:)) - (if sub (expose sub) t)] - [else t])) - (current-promote expose) - (define stlc:sub? (current-sub?)) - (define (sub? t1 t2) - (stlc:sub? ((current-promote) t1) t2)) - (current-sub? sub?) - (current-typecheck-relation (current-sub?))) - -; quasi-kind, but must be type constructor because its arguments are types -(define-type-constructor <: #:arity >= 0) -(begin-for-syntax - (current-type? (λ (t) (or (type? t) (<:? (typeof t)))))) - -;; Type annotations used in two places: -;; 1) typechecking the body of -;; 2) instantiation of ∀ -;; Problem: need type annotations, even in expanded form -;; Solution: store type annotations in a (quasi) kind <: -(define-typed-syntax ∀ #:datum-literals (<:) - [(_ ([tv:id <: τ:type] ...) τ_body) - ; eval first to overwrite the old #%type - (⊢ #,((current-type-eval) #'(sysf:∀ (tv ...) τ_body)) : (<: τ.norm ...))]) -(begin-for-syntax - (define-syntax ~∀ - (pattern-expander - (syntax-parser #:datum-literals (<:) - [(_ ([tv:id <: τ_sub] ...) τ) - #'(~and ∀τ - (~parse (~sysf:∀ (tv ...) τ) #'∀τ) - (~parse (~<: τ_sub ...) (typeof #'∀τ)))] - [(_ . args) - #'(~and ∀τ - (~parse (~sysf:∀ (tv (... ...)) τ) #'∀τ) - (~parse (~<: τ_sub (... ...)) (typeof #'∀τ)) - (~parse args #'(([tv τ_sub] (... ...)) τ)))]))) - (define-syntax ~∀* - (pattern-expander - (syntax-parser #:datum-literals (<:) - [(_ . args) - #'(~or - (~∀ . args) - (~and any (~do - (type-error - #:src #'any - #:msg "Expected ∀ type, got: ~a" #'any))))])))) - -(define-typed-syntax Λ #:datum-literals (<:) - [(Λ ([tv:id <: τsub:type] ...) e) - ;; NOTE: store the subtyping relation of tv and τsub in another - ;; "environment", ie, a syntax property with another tag: '<: - ;; The "expose" function looks for this tag to enforce the bound, - ;; as in TaPL (fig 28-1) - #:with ((tv- ...) _ (e-) (τ_e)) (infer #'(e) #:tvctx #'([tv : #%type <: τsub] ...)) - (⊢ e- : (∀ ([tv- <: τsub] ...) τ_e))]) -(define-typed-syntax inst - [(inst e τ:type ...) - #:with (e- (([tv τ_sub] ...) τ_body)) (⇑ e as ∀) - #:when (typechecks? #'(τ.norm ...) #'(τ_sub ...)) - (⊢ e- : #,(substs #'(τ.norm ...) #'(tv ...) #'τ_body))]) - diff --git a/tapl/infer.rkt b/tapl/infer.rkt @@ -1,200 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "ext-stlc.rkt" #:except #%app λ → + - void = zero? sub1 add1 not - #:rename [~→ ~ext-stlc:→]) -(require (only-in "sysf.rkt" ∀ ~∀ ∀? Λ)) -(reuse cons [head hd] [tail tl] nil [isnil nil?] List list #:from "stlc+cons.rkt") -(require (only-in "stlc+cons.rkt" ~List)) -(reuse tup × proj #:from "stlc+tup.rkt") -(reuse define-type-alias #:from "stlc+reco+var.rkt") -(require (for-syntax "type-constraints.rkt")) -(provide hd tl nil?) -(provide →) - -;; a language with partial (local) type inference using bidirectional type checking - -(define-syntax → ; wrapping → - (syntax-parser - [(→ (~and Xs {X:id ...}) . rst) - #:when (brace? #'Xs) - (add-orig #'(∀ (X ...) (ext-stlc:→ . rst)) (get-orig this-syntax))] - [(→ . rst) (add-orig #'(∀ () (ext-stlc:→ . rst)) (get-orig this-syntax))])) - -(define-primop + : (→ Int Int Int)) -(define-primop - : (→ Int Int Int)) -(define-primop void : (→ Unit)) -(define-primop = : (→ Int Int Bool)) -(define-primop zero? : (→ Int Bool)) -(define-primop sub1 : (→ Int Int)) -(define-primop add1 : (→ Int Int)) -(define-primop not : (→ Bool Bool)) -(define-primop abs : (→ Int Int)) - -(begin-for-syntax - ;; find-free-Xs : (Stx-Listof Id) Type -> (Listof Id) - ;; finds the free Xs in the type - (define (find-free-Xs Xs ty) - (for/list ([X (in-list (stx->list Xs))] - #:when (stx-contains-id? ty X)) - X)) - - ;; solve : (Stx-Listof Id) (Stx-Listof Stx) (Stx-Listof Type-Stx) - ;; -> (List Constraints (Listof (Stx-List Stx Type-Stx))) - ;; Solves for the Xs by inferring the type of each arg and unifying it against - ;; each corresponding expected-τ (which could have free Xs in them). - ;; It returns list of 2 values if successful, else throws a type error - ;; - the constraints for substituting the types - ;; - a list containing of all the arguments paired with their types - (define (solve Xs args expected-τs) - (let-values - ([(cs e+τs) - (for/fold ([cs #'()] [e+τs #'()]) - ([e_arg (syntax->list args)] - [τ_inX (syntax->list expected-τs)]) - (define τ_in (inst-type/cs Xs cs τ_inX)) - (define/with-syntax [e τ] - (infer+erase (if (empty? (find-free-Xs Xs τ_in)) - (add-expected-ty e_arg τ_in) - e_arg))) - ; (displayln #'(e τ)) - (define cs* (add-constraints Xs cs #`([#,τ_in τ]))) - (values cs* (cons #'[e τ] e+τs)))]) - (list cs (reverse (stx->list e+τs)))))) - -(define-typed-syntax define - [(define x:id e) - #:with (e- τ) (infer+erase #'e) - #:with y (generate-temporary) - #'(begin- - (define-syntax x (make-rename-transformer (⊢ y : τ))) - (define- y e-))] - [(define (~and Xs {X:id ...}) (f:id [x:id (~datum :) τ] ... (~datum →) τ_out) e) - #:when (brace? #'Xs) - #:with g (generate-temporary #'f) - #:with e_ann #'(add-expected e τ_out) - #'(begin- - (define-syntax f (make-rename-transformer - (⊢ g : #,(add-orig #'(∀ (X ...) (ext-stlc:→ τ ... τ_out)) - #'(→ τ ... τ_out))))) - (define- g (Λ (X ...) (ext-stlc:λ ([x : τ] ...) e_ann))))] - [(define (f:id [x:id (~datum :) τ] ... (~datum →) τ_out) e) - #:with g (generate-temporary #'f) - #:with e_ann #'(add-expected e τ_out) - #'(begin- - (define-syntax f (make-rename-transformer (⊢ g : (→ τ ... τ_out)))) - (define- g (ext-stlc:λ ([x : τ] ...) e_ann)))]) - -; all λs have type (∀ (X ...) (→ τ_in ... τ_out)) -(define-typed-syntax λ #:datum-literals (:) - [(λ (x:id ...) e) ; no annotations, try to infer from outer ctx, ie an application - #:with given-τ-args (syntax-property stx 'given-τ-args) - #:fail-unless (syntax-e #'given-τ-args) ; no inferred types or annotations, so error - (format "input types for ~a could not be inferred; add annotations" - (syntax->datum stx)) - #:with (τ_arg ...) #'given-τ-args - #:with [fn- τ_fn] (infer+erase #'(ext-stlc:λ ([x : τ_arg] ...) e)) - (⊢ fn- : #,(add-orig #'(∀ () τ_fn) (get-orig #'τ_fn)))] - [(_ (x:id ...) ~! e) ; no annotations, couldnt infer from ctx (eg, unapplied lam), try to infer from body - #:with (xs- e- τ_res) (infer/ctx+erase #'([x : x] ...) #'e) - #:with env (get-env #'e-) - #:fail-unless (syntax-e #'env) - (format "input types for ~a could not be inferred; add annotations" - (syntax->datum stx)) - #:with (τ_arg ...) (stx-map (λ (y) (lookup y #'env)) #'xs-) - #:fail-unless (stx-andmap syntax-e #'(τ_arg ...)) - (format "some input types for ~a could not be inferred; add annotations" - (syntax->datum stx)) - ;; propagate up inferred types of variables - #:with res (add-env #'(λ- xs- e-) #'env) -; #:with [fn- τ_fn] (infer+erase #'(ext-stlc:λ ([x : x] ...) e)) - (⊢ res : #,(add-orig #'(∀ () (ext-stlc:→ τ_arg ... τ_res)) - #`(→ #,@(stx-map get-orig #'(τ_arg ... τ_res)))))] - ;(⊢ (λ- xs- e-) : (∀ () (ext-stlc:→ τ_arg ... τ_res)))] - [(λ . rst) - #:with [fn- τ_fn] (infer+erase #'(ext-stlc:λ . rst)) - (⊢ fn- : #,(add-orig #'(∀ () τ_fn) (get-orig #'τ_fn)))]) - -(define-typed-syntax infer:#%app #:export-as #%app - [(_ e_fn e_arg ...) ; infer args first - ; #:when (printf "args first ~a\n" (syntax->datum stx)) - #:with maybe-inferred-τs (with-handlers ([exn:fail:type:infer? (λ _ #f)]) - (infers+erase #'(e_arg ...))) - #:when (syntax-e #'maybe-inferred-τs) - #:with ([e_arg- τ_arg] ...) #'maybe-inferred-τs - #:with e_fn_anno (syntax-property #'e_fn 'given-τ-args #'(τ_arg ...)) -; #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn_anno as →) - #:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn_anno as ∀) - #:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity - (type-error #:src stx - #:msg (string-append - (format "~a (~a:~a) Wrong number of arguments given to function ~a.\n" - (syntax-source stx) (syntax-line stx) (syntax-column stx) - (syntax->datum #'e_fn)) - (format "Expected: ~a arguments with types: " - (stx-length #'(τ_inX ...))) - (string-join (stx-map type->str #'(τ_inX ...)) ", " #:after-last "\n") - "Given:\n" - (string-join - (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line - (syntax->datum #'(e_arg ...)) - (stx-map type->str #'(τ_arg ...))) - "\n"))) - #:with cs (add-constraints #'(X ...) '() #'([τ_inX τ_arg] ...)) - #:with (τ_in ... τ_out) (inst-types/cs #'(X ...) #'cs #'(τ_inX ... τ_outX)) - ; some code duplication - #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) - (type-error #:src stx - #:msg (string-append - (format "~a (~a:~a) Arguments to function ~a have wrong type(s).\n" - (syntax-source stx) (syntax-line stx) (syntax-column stx) - (syntax->datum #'e_fn)) - "Given:\n" - (string-join - (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line - (syntax->datum #'(e_arg ...)) - (stx-map type->str #'(τ_arg ...))) - "\n" #:after-last "\n") - (format "Expected: ~a arguments with type(s): " - (stx-length #'(τ_in ...))) - (string-join (stx-map type->str #'(τ_in ...)) ", "))) - ; propagate inferred types for variables up - #:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e_arg- ...)))) - #:with result-app (add-env #'(#%app- e_fn- e_arg- ...) #'env) - ;(⊢ (#%app- e_fn- e_arg- ...) : τ_out)] - (⊢ result-app : τ_out)] - [(_ e_fn e_arg ...) ; infer fn first ------------------------- ; TODO: remove code dup -; #:when (printf "fn first ~a\n" (syntax->datum stx)) - #:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn as ∀) - #:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity - (type-error #:src stx - #:msg (string-append - (format "~a (~a:~a) Wrong number of arguments given to function ~a.\n" - (syntax-source stx) (syntax-line stx) (syntax-column stx) - (syntax->datum #'e_fn)) - (format "Expected: ~a arguments with types: " - (stx-length #'(τ_inX ...))) - (string-join (stx-map type->str #'(τ_inX ...)) ", " #:after-last "\n") - "Given args: " - (string-join (map ~a (syntax->datum #'(e_arg ...))) ", "))) -; #:with ([e_arg- τ_arg] ...) #'(infers+erase #'(e_arg ...)) - #:with (cs ([e_arg- τ_arg] ...)) - (solve #'(X ...) #'(e_arg ...) #'(τ_inX ...)) - #:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e_arg- ...)))) - #:with (τ_in ... τ_out) (inst-types/cs #'(X ...) #'cs #'(τ_inX ... τ_outX)) - ; some code duplication - #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) - (string-append - (format "~a (~a:~a) Arguments to function ~a have wrong type(s).\n" - (syntax-source stx) (syntax-line stx) (syntax-column stx) - (syntax->datum #'e_fn)) - "Given:\n" - (string-join - (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line - (syntax->datum #'(e_arg ...)) - (stx-map type->str #'(τ_arg ...))) - "\n" #:after-last "\n") - (format "Expected: ~a arguments with type(s): " - (stx-length #'(τ_in ...))) - (string-join (stx-map type->str #'(τ_in ...)) ", ")) - #:with result-app (add-env #'(#%app- e_fn- e_arg- ...) #'env) - ;(⊢ (#%app- e_fn- e_arg- ...) : τ_out)]) - (⊢ result-app : τ_out)]) diff --git a/tapl/mlish.rkt b/tapl/mlish.rkt @@ -1,1364 +0,0 @@ -#lang s-exp "typecheck.rkt" -(require racket/fixnum racket/flonum (for-syntax "type-constraints.rkt" "variance-constraints.rkt")) - -(extends "ext-stlc.rkt" #:except #%app λ → + - void = zero? sub1 add1 not let let* and #%datum begin - #:rename [~→ ~ext-stlc:→]) -(reuse inst #:from "sysf.rkt") -(require (only-in "ext-stlc.rkt" → →?)) -(require (only-in "sysf.rkt" ~∀ ∀ ∀? Λ)) -(reuse × tup proj define-type-alias #:from "stlc+rec-iso.rkt") -(require (only-in "stlc+rec-iso.rkt" ~× ×?)) ; using current-type=? from here -(provide (rename-out [ext-stlc:and and] [ext-stlc:#%datum #%datum])) -(reuse member length reverse list-ref cons nil isnil head tail list #:from "stlc+cons.rkt") -(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list cons nil))) -(require (only-in "stlc+cons.rkt" ~List List? List)) -(provide List) -(reuse ref deref := Ref #:from "stlc+box.rkt") -(require (rename-in (only-in "stlc+reco+var.rkt" tup proj ×) - [tup rec] [proj get] [× ××])) -(provide rec get ××) -;; for pattern matching -(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list))) -(require (prefix-in stlc+tup: (only-in "stlc+tup.rkt" tup))) - -(module+ test - (require (for-syntax rackunit))) - -(provide → →/test match2 define-type) - -;; ML-like language -;; - top level recursive functions -;; - user-definable algebraic datatypes -;; - pattern matching -;; - (local) type inference - -;; creating possibly polymorphic types -;; ?∀ only wraps a type in a forall if there's at least one type variable -(define-syntax ?∀ - (lambda (stx) - (syntax-case stx () - [(?∀ () body) - #'body] - [(?∀ (X ...) body) - #'(∀ (X ...) body)]))) - -;; ?Λ only wraps an expression in a Λ if there's at least one type variable -(define-syntax ?Λ - (lambda (stx) - (syntax-case stx () - [(?Λ () body) - #'body] - [(?Λ (X ...) body) - #'(Λ (X ...) body)]))) - -(begin-for-syntax - ;; matching possibly polymorphic types - (define-syntax ~?∀ - (pattern-expander - (lambda (stx) - (syntax-case stx () - [(?∀ vars-pat body-pat) - #'(~or (~∀ vars-pat body-pat) - (~and (~not (~∀ _ _)) - (~parse vars-pat #'()) - body-pat))])))) - - ;; find-free-Xs : (Stx-Listof Id) Type -> (Listof Id) - ;; finds the free Xs in the type - (define (find-free-Xs Xs ty) - (for/list ([X (in-list (stx->list Xs))] - #:when (stx-contains-id? ty X)) - X)) - - ;; solve for Xs by unifying quantified fn type with the concrete types of stx's args - ;; stx = the application stx = (#%app e_fn e_arg ...) - ;; tyXs = input and output types from fn type - ;; ie (typeof e_fn) = (-> . tyXs) - ;; It infers the types of arguments from left-to-right, - ;; and it expands and returns all of the arguments. - ;; It returns list of 3 values if successful, else throws a type error - ;; - a list of all the arguments, expanded - ;; - a list of all the type variables - ;; - the constraints for substituting the types - (define (solve Xs tyXs stx) - (syntax-parse tyXs - [(τ_inX ... τ_outX) - ;; generate initial constraints with expected type and τ_outX - #:with (~?∀ Vs expected-ty) (and (get-expected-type stx) - ((current-type-eval) (get-expected-type stx))) - (define initial-cs - (if (and (syntax-e #'expected-ty) (stx-null? #'Vs)) - (add-constraints Xs '() (list (list #'expected-ty #'τ_outX))) - #'())) - (syntax-parse stx - [(_ e_fn . args) - (define-values (as- cs) - (for/fold ([as- null] [cs initial-cs]) - ([a (in-list (syntax->list #'args))] - [tyXin (in-list (syntax->list #'(τ_inX ...)))]) - (define ty_in (inst-type/cs Xs cs tyXin)) - (define/with-syntax [a- ty_a] - (infer+erase (if (empty? (find-free-Xs Xs ty_in)) - (add-expected-ty a ty_in) - a))) - (values - (cons #'a- as-) - (add-constraints Xs cs (list (list ty_in #'ty_a)) - (list (list (inst-type/cs/orig - Xs cs ty_in - (λ (id1 id2) - (equal? (syntax->datum id1) - (syntax->datum id2)))) - #'ty_a)))))) - - (list (reverse as-) Xs cs)])])) - - (define (raise-app-poly-infer-error stx expected-tys given-tys e_fn) - (type-error #:src stx - #:msg (mk-app-err-msg stx #:expected expected-tys #:given given-tys - #:note (format "Could not infer instantiation of polymorphic function ~a." - (syntax->datum (get-orig e_fn)))))) - - ;; covariant-Xs? : Type -> Bool - ;; Takes a possibly polymorphic type, and returns true if all of the - ;; type variables are in covariant positions within the type, false - ;; otherwise. - (define (covariant-Xs? ty) - (syntax-parse ((current-type-eval) ty) - [(~?∀ Xs ty) - (for/and ([X (in-list (syntax->list #'Xs))]) - (covariant-X? X #'ty))])) - - ;; find-X-variance : Id Type [Variance] -> Variance - ;; Returns the variance of X within the type ty - (define (find-X-variance X ty [ctxt-variance covariant]) - (match (find-variances (list X) ty ctxt-variance) - [(list variance) variance])) - - ;; covariant-X? : Id Type -> Bool - ;; Returns true if every place X appears in ty is a covariant position, false otherwise. - (define (covariant-X? X ty) - (variance-covariant? (find-X-variance X ty covariant))) - - ;; contravariant-X? : Id Type -> Bool - ;; Returns true if every place X appears in ty is a contravariant position, false otherwise. - (define (contravariant-X? X ty) - (variance-contravariant? (find-X-variance X ty covariant))) - - ;; find-variances : (Listof Id) Type [Variance] -> (Listof Variance) - ;; Returns the variances of each of the Xs within the type ty, - ;; where it's already within a context represented by ctxt-variance. - (define (find-variances Xs ty [ctxt-variance covariant]) - (syntax-parse ty - [A:id - (for/list ([X (in-list Xs)]) - (cond [(free-identifier=? X #'A) ctxt-variance] - [else irrelevant]))] - [(~Any tycons) - (make-list (length Xs) irrelevant)] - [(~?∀ () (~Any tycons τ ...)) - #:when (get-arg-variances #'tycons) - #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) - (define τ-ctxt-variances - (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) - (variance-compose ctxt-variance arg-variance))) - (for/fold ([acc (make-list (length Xs) irrelevant)]) - ([τ (in-list (syntax->list #'[τ ...]))] - [τ-ctxt-variance (in-list τ-ctxt-variances)]) - (map variance-join - acc - (find-variances Xs τ τ-ctxt-variance)))] - [ty - #:when (not (for/or ([X (in-list Xs)]) - (stx-contains-id? #'ty X))) - (make-list (length Xs) irrelevant)] - [_ (make-list (length Xs) invariant)])) - - ;; find-variances/exprs : (Listof Id) Type [Variance-Expr] -> (Listof Variance-Expr) - ;; Like find-variances, but works with Variance-Exprs instead of - ;; concrete variance values. - (define (find-variances/exprs Xs ty [ctxt-variance covariant]) - (syntax-parse ty - [A:id - (for/list ([X (in-list Xs)]) - (cond [(free-identifier=? X #'A) ctxt-variance] - [else irrelevant]))] - [(~Any tycons) - (make-list (length Xs) irrelevant)] - [(~?∀ () (~Any tycons τ ...)) - #:when (get-arg-variances #'tycons) - #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) - (define τ-ctxt-variances - (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) - (variance-compose/expr ctxt-variance arg-variance))) - (for/fold ([acc (make-list (length Xs) irrelevant)]) - ([τ (in-list (syntax->list #'[τ ...]))] - [τ-ctxt-variance (in-list τ-ctxt-variances)]) - (map variance-join/expr - acc - (find-variances/exprs Xs τ τ-ctxt-variance)))] - [ty - #:when (not (for/or ([X (in-list Xs)]) - (stx-contains-id? #'ty X))) - (make-list (length Xs) irrelevant)] - [_ (make-list (length Xs) invariant)])) - - ;; current-variance-constraints : (U False (Mutable-Setof Variance-Constraint)) - ;; If this is false, that means that infer-variances should return concrete Variance values. - ;; If it's a mutable set, that means that infer-variances should mutate it and return false, - ;; and type constructors should return the list of variance vars. - (define current-variance-constraints (make-parameter #false)) - - ;; infer-variances : - ;; ((-> Stx) -> Stx) (Listof Variance-Var) (Listof Id) (Listof Type-Stx) - ;; -> (U False (Listof Variance)) - (define (infer-variances with-variance-vars-okay variance-vars Xs τs) - (cond - [(current-variance-constraints) - (define variance-constraints (current-variance-constraints)) - (define variance-exprs - (for/fold ([exprs (make-list (length variance-vars) irrelevant)]) - ([τ (in-list τs)]) - (define/syntax-parse (~?∀ Xs* τ*) - ;; This can mutate variance-constraints! - ;; This avoids causing an infinite loop by having the type - ;; constructors provide with-variance-vars-okay so that within - ;; this call they declare variance-vars for their variances. - (with-variance-vars-okay - (λ () ((current-type-eval) #`(∀ #,Xs #,τ))))) - (map variance-join/expr - exprs - (find-variances/exprs (syntax->list #'Xs*) #'τ* covariant)))) - (for ([var (in-list variance-vars)] - [expr (in-list variance-exprs)]) - (set-add! variance-constraints (variance= var expr))) - #f] - [else - (define variance-constraints (mutable-set)) - ;; This will mutate variance-constraints! - (parameterize ([current-variance-constraints variance-constraints]) - (infer-variances with-variance-vars-okay variance-vars Xs τs)) - (define mapping - (solve-variance-constraints variance-vars - (set->list variance-constraints) - (variance-mapping))) - (for/list ([var (in-list variance-vars)]) - (variance-mapping-ref mapping var))])) - - ;; make-arg-variances-proc : - ;; (Listof Variance-Var) (Listof Id) (Listof Type-Stx) -> (Stx -> (U (Listof Variance) - ;; (Listof Variance-Var))) - (define (make-arg-variances-proc arg-variance-vars Xs τs) - ;; variance-vars-okay? : (Parameterof Boolean) - ;; A parameter that determines whether or not it's okay for - ;; this type constructor to return a list of Variance-Vars - ;; for the variances. - (define variance-vars-okay? (make-parameter #false)) - ;; with-variance-vars-okay : (-> A) -> A - (define (with-variance-vars-okay f) - (parameterize ([variance-vars-okay? #true]) - (f))) - ;; arg-variances : (Boxof (U False (List Variance ...))) - ;; If false, means that the arg variances have not been - ;; computed yet. Otherwise, stores the complete computed - ;; variances for the arguments to this type constructor. - (define arg-variances (box #f)) - ;; arg-variances-proc : Stx -> (U (Listof Variance) (Listof Variance-Var)) - (define (arg-variance-proc stx) - (or (unbox arg-variances) - (cond - [(variance-vars-okay?) - arg-variance-vars] - [else - (define inferred-variances - (infer-variances - with-variance-vars-okay - arg-variance-vars - Xs - τs)) - (cond [inferred-variances - (set-box! arg-variances inferred-variances) - inferred-variances] - [else - arg-variance-vars])]))) - arg-variance-proc) - - ;; compute unbound tyvars in one unexpanded type ty - (define (compute-tyvar1 ty) - (syntax-parse ty - [X:id #'(X)] - [() #'()] - [(C t ...) (stx-appendmap compute-tyvar1 #'(t ...))])) - ;; computes unbound ids in (unexpanded) tys, to be used as tyvars - (define (compute-tyvars tys) - (define Xs (stx-appendmap compute-tyvar1 tys)) - (filter - (lambda (X) - (with-handlers - ([exn:fail:syntax:unbound? (lambda (e) #t)] - [exn:fail:type:infer? (lambda (e) #t)]) - (let ([X+ ((current-type-eval) X)]) - (not (or (tyvar? X+) (type? X+)))))) - (stx-remove-dups Xs)))) - -;; define -------------------------------------------------- -;; for function defs, define infers type variables -;; - since the order of the inferred type variables depends on expansion order, -;; which is not known to programmers, to make the result slightly more -;; intuitive, we arbitrarily sort the inferred tyvars lexicographically -(define-typed-syntax define - [(define x:id e) - #:with (e- τ) (infer+erase #'e) - #:with y (generate-temporary) - #'(begin- - (define-syntax x (make-rename-transformer (⊢ y : τ))) - (define- y e-))] - ; explicit "forall" - [(define Ys (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) - e_body ... e) - #:when (brace? #'Ys) - ;; TODO; remove this code duplication - #:with g (add-orig (generate-temporary #'f) #'f) - #:with e_ann #'(add-expected e τ_out) - #:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out)) - ;; TODO: check that specified return type is correct - ;; - currently cannot do it here; to do the check here, need all types of - ;; top-lvl fns, since they can call each other - #:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) - ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...))) - #`(begin- - (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) - (define- g - (Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))] - ;; alternate type sig syntax, after parameter names - [(define (f:id x:id ...) (~datum :) ty ... (~or (~datum ->) (~datum →)) ty_out . b) - #'(define (f [x : ty] ... -> ty_out) . b)] - [(define (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) - e_body ... e) - #:with Ys (compute-tyvars #'(τ ... τ_out)) - #:with g (add-orig (generate-temporary #'f) #'f) - #:with e_ann #'(add-expected e τ_out) ; must be macro bc t_out may have unbound tvs - #:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out)) - ;; TODO: check that specified return type is correct - ;; - currently cannot do it here; to do the check here, need all types of - ;; top-lvl fns, since they can call each other - #:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) - (set-stx-prop/preserved - ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...))) - 'orig - (list #'(→ τ+orig ...))) - #`(begin- - (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) - (define- g - (?Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]) - -;; define-type ----------------------------------------------- -;; TODO: should validate τ as part of define-type definition (before it's used) -;; - not completely possible, since some constructors may not be defined yet, -;; ie, mutually recursive datatypes -;; for now, validate types but punt if encountering unbound ids -(define-syntax (define-type stx) - (syntax-parse stx - [(define-type Name:id . rst) - #:with NewName (generate-temporary #'Name) - #:with Name2 (add-orig #'(NewName) #'Name) - #`(begin- - (define-type Name2 . #,(subst #'Name2 #'Name #'rst)) - (stlc+rec-iso:define-type-alias Name Name2))] - [(define-type (Name:id X:id ...) - ;; constructors must have the form (Cons τ ...) - ;; but the first ~or clause accepts 0-arg constructors as ids; - ;; the ~and is a workaround to bind the duplicate Cons ids (see Ryan's email) - (~and (~or (~and IdCons:id - (~parse (Cons [fld (~datum :) τ] ...) #'(IdCons))) - (Cons [fld (~datum :) τ] ...) - (~and (Cons τ ...) - (~parse (fld ...) (generate-temporaries #'(τ ...)))))) ...) - ;; validate tys - #:with (ty_flat ...) (stx-flatten #'((τ ...) ...)) - #:with (_ _ (_ _ (_ _ (_ _ ty+ ...)))) - (with-handlers - ([exn:fail:syntax:unbound? - (λ (e) - (define X (stx-car (exn:fail:syntax-exprs e))) - #`(lambda () (let-syntax () (let-syntax () (#%app void unbound)))))]) - (expand/df - #`(lambda (X ...) - (let-syntax - ([Name - (syntax-parser - [(_ X ...) (mk-type #'void)] - [stx - (type-error - #:src #'stx - #:msg - (format "Improper use of constructor ~a; expected ~a args, got ~a" - (syntax->datum #'Name) (stx-length #'(X ...)) - (stx-length (stx-cdr #'stx))))])] - [X (make-rename-transformer (⊢ X #%type))] ...) - (void ty_flat ...))))) - #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...))) - (stx-map - (lambda (t+ t) (unless (type? t+) - (type-error #:src t - #:msg "~a is not a valid type" t))) - #'(ty+ ...) #'(ty_flat ...))) - #:with NameExpander (format-id #'Name "~~~a" #'Name) - #:with NameExtraInfo (format-id #'Name "~a-extra-info" #'Name) - #:with (StructName ...) (generate-temporaries #'(Cons ...)) - #:with ((e_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) - #:with ((e_arg- ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) - #:with ((τ_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) - #:with ((exposed-acc ...) ...) - (stx-map - (λ (C fs) (stx-map (λ (f) (format-id C "~a-~a" C f)) fs)) - #'(Cons ...) #'((fld ...) ...)) - #:with ((acc ...) ...) (stx-map (λ (S fs) (stx-map (λ (f) (format-id S "~a-~a" S f)) fs)) - #'(StructName ...) #'((fld ...) ...)) - #:with (Cons? ...) (stx-map mk-? #'(StructName ...)) - #:with (exposed-Cons? ...) (stx-map mk-? #'(Cons ...)) - #`(begin- - (define-syntax (NameExtraInfo stx) - (syntax-parse stx - [(_ X ...) #'(('Cons 'StructName Cons? [acc τ] ...) ...)])) - (begin-for-syntax - ;; arg-variance-vars : (List Variance-Var ...) - (define arg-variance-vars - (list (variance-var (syntax-e (generate-temporary 'X))) ...))) - (define-type-constructor Name - #:arity = #,(stx-length #'(X ...)) - #:arg-variances (make-arg-variances-proc arg-variance-vars - (list #'X ...) - (list #'τ ... ...)) - #:extra-info 'NameExtraInfo - #:no-provide) - (struct- StructName (fld ...) #:reflection-name 'Cons #:transparent) ... - (define-syntax (exposed-acc stx) ; accessor for records - (syntax-parse stx - [_:id (⊢ acc (?∀ (X ...) (ext-stlc:→ (Name X ...) τ)))] - [(o . rst) ; handle if used in fn position - #:with app (datum->syntax #'o '#%app) - #`(app - #,(assign-type #'acc #'(?∀ (X ...) (ext-stlc:→ (Name X ...) τ))) - . rst)])) ... ... - (define-syntax (exposed-Cons? stx) ; predicates for each variant - (syntax-parse stx - [_:id (⊢ Cons? (?∀ (X ...) (ext-stlc:→ (Name X ...) Bool)))] - [(o . rst) ; handle if used in fn position - #:with app (datum->syntax #'o '#%app) - #`(app - #,(assign-type #'Cons? #'(?∀ (X ...) (ext-stlc:→ (Name X ...) Bool))) - . rst)])) ... - (define-syntax (Cons stx) - (syntax-parse stx - ; no args and not polymorphic - [C:id #:when (and (stx-null? #'(X ...)) (stx-null? #'(τ ...))) #'(C)] - ; no args but polymorphic, check inferred type - [C:id - #:when (stx-null? #'(τ ...)) - #:with τ-expected (syntax-property #'C 'expected-type) - #:fail-unless (syntax-e #'τ-expected) - (raise - (exn:fail:type:infer - (string-append - (format "TYPE-ERROR: ~a (~a:~a): " - (syntax-source stx) (syntax-line stx) (syntax-column stx)) - (format "cannot infer type of ~a; add annotations" - (syntax->datum #'C))) - (current-continuation-marks))) - #:with (NameExpander τ-expected-arg (... ...)) ((current-type-eval) #'τ-expected) - #'(C {τ-expected-arg (... ...)})] - [_:id (⊢ StructName (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))] ; HO fn - [(C τs e_arg ...) - #:when (brace? #'τs) ; commit to this clause - #:with {~! τ_X:type (... ...)} #'τs - #:with (τ_in:type (... ...)) ; instantiated types - (stx-map - (λ (t) (substs #'(τ_X.norm (... ...)) #'(X ...) t)) - #'(τ ...)) - #:with ([e_arg- τ_arg] ...) - (stx-map - (λ (e τ_e) - (infer+erase (set-stx-prop/preserved e 'expected-type τ_e))) - #'(e_arg ...) #'(τ_in.norm (... ...))) - #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in.norm (... ...))) - (mk-app-err-msg (syntax/loc stx (#%app C e_arg ...)) - #:expected #'(τ_in.norm (... ...)) #:given #'(τ_arg ...) - #:name (format "constructor ~a" 'Cons)) - (⊢ (StructName e_arg- ...) : (Name τ_X (... ...)))] - [(C . args) ; no type annotations, must infer instantiation - #:with StructName/ty - (set-stx-prop/preserved - (⊢ StructName : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...)))) - 'orig - (list #'C)) - ; stx/loc transfers expected-type - (syntax/loc stx (mlish:#%app StructName/ty . args))])) - ...)])) - -;; match -------------------------------------------------- -(begin-for-syntax - (define (get-ctx pat ty) - (unify-pat+ty (list pat ty))) - (define (unify-pat+ty pat+ty) - (syntax-parse pat+ty - [(pat ty) #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) - (syntax-parse #'pat - [{(~datum _)} #'()] - [{(~literal stlc+cons:nil)} #'()] - [{A:id} ; disambiguate 0-arity constructors (that don't need parens) - #:when (get-extra-info #'ty) - #'()] - ;; comma tup syntax always has parens - [{(~and ps (p1 (unq p) ...))} - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - (unify-pat+ty #'(ps ty))] - [{p ...} - (unify-pat+ty #'((p ...) ty))])] ; pair - [((~datum _) ty) #'()] - [((~or (~literal stlc+cons:nil)) ty) #'()] - [(A:id ty) ; disambiguate 0-arity constructors (that don't need parens) - #:with (_ (_ (_ C) . _) ...) (get-extra-info #'ty) - #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) - #'()] - [(x:id ty) #'((x ty))] - [((p1 (unq p) ...) ty) ; comma tup stx - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - #:with (~× t ...) #'ty - #:with (pp ...) #'(p1 p ...) - (unifys #'([pp t] ...))] - [(((~literal stlc+tup:tup) p ...) ty) ; tup - #:with (~× t ...) #'ty - (unifys #'([p t] ...))] - [(((~literal stlc+cons:list) p ...) ty) ; known length list - #:with (~List t) #'ty - (unifys #'([p t] ...))] - [(((~seq p (~datum ::)) ... rst) ty) ; nicer cons stx - #:with (~List t) #'ty - (unifys #'([p t] ... [rst ty]))] - [(((~literal stlc+cons:cons) p ps) ty) ; arb length list - #:with (~List t) #'ty - (unifys #'([p t] [ps ty]))] - [((Name p ...) ty) - #:with (_ (_ Cons) _ _ [_ _ τ] ...) - (stx-findf - (syntax-parser - [(_ 'C . rst) - (equal? (syntax->datum #'Name) (syntax->datum #'C))]) - (stx-cdr (get-extra-info #'ty))) - (unifys #'([p τ] ...))] - [p+t #:fail-when #t (format "could not unify ~a" (syntax->datum #'p+t)) - #'()])) - (define (unifys p+tys) (stx-appendmap unify-pat+ty p+tys)) - - (define (compile-pat p ty) - (syntax-parse p - [pat #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) - (syntax-parse #'pat - [{(~datum _)} #'_] - [{(~literal stlc+cons:nil)} (syntax/loc p (list))] - [{A:id} ; disambiguate 0-arity constructors (that don't need parens) - #:when (get-extra-info ty) - (compile-pat #'(A) ty)] - ;; comma tup stx always has parens - [{(~and ps (p1 (unq p) ...))} - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - (compile-pat #'ps ty)] - [{pat ...} (compile-pat (syntax/loc p (pat ...)) ty)])] - [(~datum _) #'_] - [(~literal stlc+cons:nil) ; nil - #'(list)] - [A:id ; disambiguate 0-arity constructors (that don't need parens) - #:with (_ (_ (_ C) . _) ...) (get-extra-info ty) - #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) - (compile-pat #'(A) ty)] - [x:id p] - [(p1 (unq p) ...) ; comma tup stx - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - #:with (~× t ...) ty - #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'(p1 p ...) #'(t ...)) - #'(list p- ...)] - [((~literal stlc+tup:tup) . pats) - #:with (~× . tys) ty - #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'pats #'tys) - (syntax/loc p (list p- ...))] - [((~literal stlc+cons:list) . ps) - #:with (~List t) ty - #:with (p- ...) (stx-map (lambda (p) (compile-pat p #'t)) #'ps) - (syntax/loc p (list p- ...))] - [((~seq pat (~datum ::)) ... last) ; nicer cons stx - #:with (~List t) ty - #:with (p- ...) (stx-map (lambda (pp) (compile-pat pp #'t)) #'(pat ...)) - #:with last- (compile-pat #'last ty) - (syntax/loc p (list-rest p- ... last-))] - [((~literal stlc+cons:cons) p ps) - #:with (~List t) ty - #:with p- (compile-pat #'p #'t) - #:with ps- (compile-pat #'ps ty) - #'(cons p- ps-)] - [(Name . pats) - #:with (_ (_ Cons) (_ StructName) _ [_ _ τ] ...) - (stx-findf - (syntax-parser - [(_ 'C . rst) - (equal? (syntax->datum #'Name) (syntax->datum #'C))]) - (stx-cdr (get-extra-info ty))) - #:with (p- ...) (stx-map compile-pat #'pats #'(τ ...)) - (syntax/loc p (StructName p- ...))])) - - ;; pats = compiled pats = racket pats - (define (check-exhaust pats ty) - (define (else-pat? p) - (syntax-parse p [(~literal _) #t] [_ #f])) - (define (nil-pat? p) - (syntax-parse p - [((~literal list)) #t] - [_ #f])) - (define (non-nil-pat? p) - (syntax-parse p - [((~literal list-rest) . rst) #t] - [((~literal cons) . rst) #t] - [_ #f])) - (define (tup-pat? p) - (syntax-parse p - [((~literal list) . _) #t] [_ #f])) - (cond - [(or (stx-ormap else-pat? pats) (stx-ormap identifier? pats)) #t] - [(List? ty) ; lists - (unless (stx-ormap nil-pat? pats) - (error 'match2 (let ([last (car (stx-rev pats))]) - (format "(~a:~a) missing nil clause for list expression" - (syntax-line last) (syntax-column last))))) - (unless (stx-ormap non-nil-pat? pats) - (error 'match2 (let ([last (car (stx-rev pats))]) - (format "(~a:~a) missing clause for non-empty, arbitrary length list" - (syntax-line last) (syntax-column last))))) - #t] - [(×? ty) ; tuples - (unless (stx-ormap tup-pat? pats) - (error 'match2 (let ([last (car (stx-rev pats))]) - (format "(~a:~a) missing pattern for tuple expression" - (syntax-line last) (syntax-column last))))) - (syntax-parse pats - [((_ p ...) ...) - (syntax-parse ty - [(~× t ...) - (apply stx-andmap - (lambda (t . ps) (check-exhaust ps t)) - #'(t ...) - (syntax->list #'((p ...) ...)))])])] - [else ; algebraic datatypes - (syntax-parse (get-extra-info ty) - [(_ (_ (_ C) (_ Cstruct) . rst) ...) - (syntax-parse pats - [((Cpat _ ...) ...) - (define Cs (syntax->datum #'(C ...))) - (define Cstructs (syntax->datum #'(Cstruct ...))) - (define Cpats (syntax->datum #'(Cpat ...))) - (unless (set=? Cstructs Cpats) - (error 'match2 - (let ([last (car (stx-rev pats))]) - (format "(~a:~a) clauses not exhaustive; missing: ~a" - (syntax-line last) (syntax-column last) - (string-join - (for/list ([C Cs][Cstr Cstructs] #:unless (member Cstr Cpats)) - (symbol->string C)) - ", "))))) - #t])] - [_ #t])])) - - ;; TODO: do get-ctx and compile-pat in one pass - (define (compile-pats pats ty) - (stx-map (lambda (p) (list (get-ctx p ty) (compile-pat p ty))) pats)) - ) - -(define-syntax (match2 stx) - (syntax-parse stx #:datum-literals (with) - [(match2 e with . clauses) - #:fail-when (null? (syntax->list #'clauses)) "no clauses" - #:with [e- τ_e] (infer+erase #'e) - (syntax-parse #'clauses #:datum-literals (->) - [([(~seq p ...) -> e_body] ...) - #:with (pat ...) (stx-map ; use brace to indicate root pattern - (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc stx {pp ...})])) - #'((p ...) ...)) - #:with ([(~and ctx ([x ty] ...)) pat-] ...) (compile-pats #'(pat ...) #'τ_e) - #:with ty-expected (get-expected-type stx) - #:with ([(x- ...) e_body- ty_body] ...) - (stx-map - infer/ctx+erase - #'(ctx ...) #'((add-expected e_body ty-expected) ...)) - #:when (check-exhaust #'(pat- ...) #'τ_e) - #:with τ_out (stx-foldr (current-join) (stx-car #'(ty_body ...)) (stx-cdr #'(ty_body ...))) - (⊢ (match- e- [pat- (let- ([x- x] ...) e_body-)] ...) : τ_out) - ])])) - -(define-typed-syntax match #:datum-literals (with) - [(match e with . clauses) - #:fail-when (null? (syntax->list #'clauses)) "no clauses" - #:with [e- τ_e] (infer+erase #'e) - #:with t_expect (syntax-property stx 'expected-type) ; propagate inferred type - (cond - [(×? #'τ_e) ;; e is tuple - (syntax-parse #'clauses #:datum-literals (->) - [([x ... -> e_body]) - #:with (~× ty ...) #'τ_e - #:fail-unless (stx-length=? #'(ty ...) #'(x ...)) - "match clause pattern not compatible with given tuple" - #:with [(x- ...) e_body- ty_body] (infer/ctx+erase #'([x ty] ...) - #'(add-expected e_body t_expect)) - #:with (acc ...) (for/list ([(a i) (in-indexed (syntax->list #'(x ...)))]) - #`(lambda- (s) (list-ref- s #,(datum->syntax #'here i)))) - #:with z (generate-temporary) - (⊢ (let- ([z e-]) - (let- ([x- (acc z)] ...) e_body-)) - : ty_body)])] - [(List? #'τ_e) ;; e is List - (syntax-parse #'clauses #:datum-literals (-> ::) - [([(~or (~and (~and xs [x ...]) (~parse rst (generate-temporary))) - (~and (~seq (~seq x ::) ... rst:id) (~parse xs #'()))) - -> e_body] ...+) - #:fail-unless (stx-ormap - (lambda (xx) (and (brack? xx) (zero? (stx-length xx)))) - #'(xs ...)) - "match: missing empty list case" - #:fail-when (and (stx-andmap brack? #'(xs ...)) - (= 1 (stx-length #'(xs ...)))) - "match: missing non-empty list case" - #:with (~List ty) #'τ_e - #:with ([(x- ... rst-) e_body- ty_body] ...) - (stx-map (lambda (ctx e) (infer/ctx+erase ctx e)) - #'(([x ty] ... [rst (List ty)]) ...) #'((add-expected e_body t_expect) ...)) - #:with τ_out (stx-foldr (current-join) (stx-car #'(ty_body ...)) (stx-cdr #'(ty_body ...))) - #:with (len ...) (stx-map (lambda (p) #`#,(stx-length p)) #'((x ...) ...)) - #:with (lenop ...) (stx-map (lambda (p) (if (brack? p) #'=- #'>=-)) #'(xs ...)) - #:with (pred? ...) (stx-map - (lambda (l lo) #`(λ- (lst) (#,lo (length- lst) #,l))) - #'(len ...) #'(lenop ...)) - #:with ((acc1 ...) ...) (stx-map - (lambda (xs) - (for/list ([(x i) (in-indexed (syntax->list xs))]) - #`(lambda- (lst) (list-ref- lst #,(datum->syntax #'here i))))) - #'((x ...) ...)) - #:with (acc2 ...) (stx-map (lambda (l) #`(lambda- (lst) (list-tail- lst #,l))) #'(len ...)) - (⊢ (let- ([z e-]) - (cond- - [(pred? z) - (let- ([x- (acc1 z)] ... [rst- (acc2 z)]) e_body-)] ...)) - : τ_out)])] - [else ;; e is variant - (syntax-parse #'clauses #:datum-literals (->) - [([Clause:id x:id ... - (~optional (~seq #:when e_guard) #:defaults ([e_guard #'(ext-stlc:#%datum . #t)])) - -> e_c_un] ...+) ; un = unannotated with expected ty - ;; length #'clauses may be > length #'info, due to guards - #:with info-body (get-extra-info #'τ_e) - #:with (_ (_ (_ ConsAll) . _) ...) #'info-body - #:fail-unless (set=? (syntax->datum #'(Clause ...)) - (syntax->datum #'(ConsAll ...))) - (type-error #:src stx - #:msg (string-append - "match: clauses not exhaustive; missing: " - (string-join - (map symbol->string - (set-subtract - (syntax->datum #'(ConsAll ...)) - (syntax->datum #'(Clause ...)))) - ", "))) - #:with ((_ _ _ Cons? [_ acc τ] ...) ...) - (map ; ok to compare symbols since clause names can't be rebound - (lambda (Cl) - (stx-findf - (syntax-parser - [(_ 'C . rst) (equal? Cl (syntax->datum #'C))]) - (stx-cdr #'info-body))) ; drop leading #%app - (syntax->datum #'(Clause ...))) - ;; this commented block experiments with expanding to unsafe ops - ;; #:with ((acc ...) ...) (stx-map - ;; (lambda (accs) - ;; (for/list ([(a i) (in-indexed (syntax->list accs))]) - ;; #`(lambda (s) (unsafe-struct*-ref s #,(datum->syntax #'here i))))) - ;; #'((acc-fn ...) ...)) - #:with (e_c ...+) (stx-map (lambda (ec) (add-expected-ty ec #'t_expect)) #'(e_c_un ...)) - #:with (((x- ...) (e_guard- e_c-) (τ_guard τ_ec)) ...) - (stx-map - (λ (bs eg+ec) (infers/ctx+erase bs eg+ec)) - #'(([x : τ] ...) ...) #'((e_guard e_c) ...)) - #:fail-unless (and (same-types? #'(τ_guard ...)) - (Bool? (stx-car #'(τ_guard ...)))) - "guard expression(s) must have type bool" - #:with τ_out (stx-foldr (current-join) (stx-car #'(τ_ec ...)) (stx-cdr #'(τ_ec ...))) - #:with z (generate-temporary) ; dont duplicate eval of test expr - (⊢ (let- ([z e-]) - (cond- - [(and- (Cons? z) - (let- ([x- (acc z)] ...) e_guard-)) - (let- ([x- (acc z)] ...) e_c-)] ...)) - : τ_out)])])]) - -; special arrow that computes free vars; for use with tests -; (because we can't write explicit forall -(define-syntax →/test - (syntax-parser - [(→/test (~and Xs (X:id ...)) . rst) - #:when (brace? #'Xs) - #'(?∀ (X ...) (ext-stlc:→ . rst))] - [(→/test . rst) - #:with Xs (compute-tyvars #'rst) - #'(?∀ Xs (ext-stlc:→ . rst))])) - -; redefine these to use lifted → -(define-primop + : (→ Int Int Int)) -(define-primop - : (→ Int Int Int)) -(define-primop * : (→ Int Int Int)) -(define-primop max : (→ Int Int Int)) -(define-primop min : (→ Int Int Int)) -(define-primop void : (→ Unit)) -(define-primop = : (→ Int Int Bool)) -(define-primop <= : (→ Int Int Bool)) -(define-primop < : (→ Int Int Bool)) -(define-primop > : (→ Int Int Bool)) -(define-primop modulo : (→ Int Int Int)) -(define-primop zero? : (→ Int Bool)) -(define-primop sub1 : (→ Int Int)) -(define-primop add1 : (→ Int Int)) -(define-primop not : (→ Bool Bool)) -(define-primop abs : (→ Int Int)) -(define-primop even? : (→ Int Bool)) -(define-primop odd? : (→ Int Bool)) - -; all λs have type (?∀ (X ...) (→ τ_in ... τ_out)) -(define-typed-syntax λ - [(λ (x:id ...+) body) - #:with (~?∀ Xs expected) (get-expected-type stx) - #:do [(unless (→? #'expected) - (type-error #:src stx #:msg "λ parameters must have type annotations"))] - #:with (~ext-stlc:→ arg-ty ... body-ty) #'expected - #:do [(unless (stx-length=? #'[x ...] #'[arg-ty ...]) - (type-error #:src stx #:msg - (format "expected a function of ~a arguments, got one with ~a arguments" - (stx-length #'[arg-ty ...] #'[x ...]))))] - #`(?Λ Xs (ext-stlc:λ ([x : arg-ty] ...) #,(add-expected-ty #'body #'body-ty)))] - [(λ args body) - #:with (~?∀ () (~ext-stlc:→ arg-ty ... body-ty)) (get-expected-type stx) - #`(?Λ () (ext-stlc:λ args #,(add-expected-ty #'body #'body-ty)))] - [(λ (~and x+tys ([_ (~datum :) ty] ...)) . body) - #:with Xs (compute-tyvars #'(ty ...)) - ;; TODO is there a way to have λs that refer to ids defined after them? - #'(?Λ Xs (ext-stlc:λ x+tys . body))]) - - -;; #%app -------------------------------------------------- -(define-typed-syntax mlish:#%app #:export-as #%app - [(_ e_fn . e_args) - ;; ) compute fn type (ie ∀ and →) - #:with [e_fn- (~?∀ Xs (~ext-stlc:→ . tyX_args))] (infer+erase #'e_fn) - (cond - [(stx-null? #'Xs) - (syntax-parse #'(e_args tyX_args) - [((e_arg ...) (τ_inX ... _)) - #:fail-unless (stx-length=? #'(e_arg ...) #'(τ_inX ...)) - (mk-app-err-msg stx #:expected #'(τ_inX ...) - #:note "Wrong number of arguments.") - #:with e_fn/ty (⊢ e_fn- : (ext-stlc:→ . tyX_args)) - #'(ext-stlc:#%app e_fn/ty (add-expected e_arg τ_inX) ...)])] - [else - ;; ) solve for type variables Xs - (define/with-syntax ((e_arg- ...) Xs* cs) (solve #'Xs #'tyX_args stx)) - ;; ) instantiate polymorphic function type - (syntax-parse (inst-types/cs #'Xs* #'cs #'tyX_args) - [(τ_in ... τ_out) ; concrete types - #:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out) - ;; ) arity check - #:fail-unless (stx-length=? #'(τ_in ...) #'e_args) - (mk-app-err-msg stx #:expected #'(τ_in ...) - #:note "Wrong number of arguments.") - ;; ) compute argument types - #:with (τ_arg ...) (stx-map typeof #'(e_arg- ...)) - ;; ) typecheck args - #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) - (mk-app-err-msg stx - #:given #'(τ_arg ...) - #:expected - (stx-map - (lambda (tyin) - (define old-orig (get-orig tyin)) - (define new-orig - (and old-orig - (substs - (stx-map get-orig (lookup-Xs/keep-unsolved #'Xs* #'cs)) - #'Xs* - old-orig - (lambda (x y) - (equal? (syntax->datum x) (syntax->datum y)))))) - (set-stx-prop/preserved tyin 'orig (list new-orig))) - #'(τ_in ...))) - #:with τ_out* (if (stx-null? #'(unsolved-X ...)) - #'τ_out - (syntax-parse #'τ_out - [(~?∀ (Y ...) τ_out) - (unless (→? #'τ_out) - (raise-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn)) - (for ([X (in-list (syntax->list #'(unsolved-X ...)))]) - (unless (covariant-X? X #'τ_out) - (raise-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn))) - #'(∀ (unsolved-X ... Y ...) τ_out)])) - (⊢ (#%app- e_fn- e_arg- ...) : τ_out*)])])] - [(_ e_fn . e_args) ; err case; e_fn is not a function - #:with [e_fn- τ_fn] (infer+erase #'e_fn) - (type-error #:src stx - #:msg (format "Expected expression ~a to have → type, got: ~a" - (syntax->datum #'e_fn) (type->str #'τ_fn)))]) - - -;; cond and other conditionals -(define-typed-syntax cond - [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t))) - test) - b ... body] ...+) - #:with (test- ...) (⇑s (test ...) as Bool) - #:with ty-expected (get-expected-type stx) - #:with ([body- ty_body] ...) (infers+erase #'((add-expected body ty-expected) ...)) - #:with (([b- ty_b] ...) ...) (stx-map infers+erase #'((b ...) ...)) - #:with τ_out (stx-foldr (current-join) (stx-car #'(ty_body ...)) (stx-cdr #'(ty_body ...))) - (⊢ (cond- [test- b- ... body-] ...) : τ_out)]) -(define-typed-syntax when - [(when test body ...) -; #:with test- (⇑ test as Bool) - #:with [test- _] (infer+erase #'test) - #:with [(body- _) ...] (infers+erase #'(body ...)) - (⊢ (when- test- body- ...) : Unit)]) -(define-typed-syntax unless - [(unless test body ...) -; #:with test- (⇑ test as Bool) - #:with [test- _] (infer+erase #'test) - #:with [(body- _) ...] (infers+erase #'(body ...)) - (⊢ (unless- test- body- ...) : Unit)]) - -;; sync channels and threads -(define-type-constructor Channel) - -(define-typed-syntax make-channel - [(make-channel (~and tys {ty})) - #:when (brace? #'tys) - (⊢ (make-channel-) : (Channel ty))]) -(define-typed-syntax channel-get - [(channel-get c) - #:with (c- (ty)) (⇑ c as Channel) - (⊢ (channel-get- c-) : ty)]) -(define-typed-syntax channel-put - [(channel-put c v) - #:with (c- (ty)) (⇑ c as Channel) - #:with [v- ty_v] (infer+erase #'v) - #:fail-unless (typechecks? #'ty_v #'ty) - (format "Cannot send ~a value on ~a channel." - (type->str #'ty_v) (type->str #'ty)) - (⊢ (channel-put- c- v-) : Unit)]) - -(define-base-type Thread) - -;; threads -(define-typed-syntax thread - [(thread th) - #:with (th- (~?∀ () (~ext-stlc:→ τ_out))) (infer+erase #'th) - (⊢ (thread- th-) : Thread)]) - -(define-primop random : (→ Int Int)) -(define-primop integer->char : (→ Int Char)) -(define-primop string->list : (→ String (List Char))) -(define-primop string->number : (→ String Int)) -;(define-primop number->string : (→ Int String)) -(define-typed-syntax number->string - [f:id (assign-type #'number->string- #'(→ Int String))] - [(number->string n) - #'(number->string n (ext-stlc:#%datum . 10))] - [(number->string n rad) - #:with args- (⇑s (n rad) as Int) - (⊢ (number->string- . args-) : String)]) -(define-primop string : (→ Char String)) -(define-primop sleep : (→ Int Unit)) -(define-primop string=? : (→ String String Bool)) -(define-primop string<=? : (→ String String Bool)) - -(define-typed-syntax string-append - [(string-append . strs) - #:with strs- (⇑s strs as String) - (⊢ (string-append- . strs-) : String)]) - -;; vectors -(define-type-constructor Vector) - -(define-typed-syntax vector - [(vector (~and tys {ty})) - #:when (brace? #'tys) - (⊢ (vector-) : (Vector ty))] - [(vector v ...) - #:with ([v- ty] ...) (infers+erase #'(v ...)) - #:when (same-types? #'(ty ...)) - #:with one-ty (stx-car #'(ty ...)) - (⊢ (vector- v- ...) : (Vector one-ty))]) -(define-typed-syntax make-vector - [(make-vector n) #'(make-vector n (ext-stlc:#%datum . 0))] - [(make-vector n e) - #:with n- (⇑ n as Int) - #:with [e- ty] (infer+erase #'e) - (⊢ (make-vector- n- e-) : (Vector ty))]) -(define-typed-syntax vector-length - [(vector-length e) - #:with [e- _] (⇑ e as Vector) - (⊢ (vector-length- e-) : Int)]) -(define-typed-syntax vector-ref - [(vector-ref e n) - #:with n- (⇑ n as Int) - #:with [e- (ty)] (⇑ e as Vector) - (⊢ (vector-ref- e- n-) : ty)]) -(define-typed-syntax vector-set! - [(vector-set! e n v) - #:with n- (⇑ n as Int) - #:with [e- (ty)] (⇑ e as Vector) - #:with [v- ty_v] (infer+erase #'v) - #:when (typecheck? #'ty_v #'ty) - (⊢ (vector-set!- e- n- v-) : Unit)]) -(define-typed-syntax vector-copy! - [(vector-copy! dest start src) - #:with start- (⇑ start as Int) - #:with [dest- (ty_dest)] (⇑ dest as Vector) - #:with [src- (ty_src)] (⇑ src as Vector) - #:when (typecheck? #'ty_dest #'ty_src) - (⊢ (vector-copy!- dest- start- src-) : Unit)]) - - -;; sequences and for loops - -(define-type-constructor Sequence) - -(define-typed-syntax in-range - [(in-range end) - #'(in-range (ext-stlc:#%datum . 0) end (ext-stlc:#%datum . 1))] - [(in-range start end) - #'(in-range start end (ext-stlc:#%datum . 1))] - [(in-range start end step) - #:with (e- ...) (⇑s (start end step) as Int) - (⊢ (in-range- e- ...) : (Sequence Int))]) - -(define-typed-syntax in-naturals - [(in-naturals) #'(in-naturals (ext-stlc:#%datum . 0))] - [(in-naturals start) - #:with start- (⇑ start as Int) - (⊢ (in-naturals- start-) : (Sequence Int))]) - - -(define-typed-syntax in-vector - [(in-vector e) - #:with [e- (ty)] (⇑ e as Vector) - (⊢ (in-vector- e-) : (Sequence ty))]) - -(define-typed-syntax in-list - [(in-list e) - #:with [e- (ty)] (⇑ e as List) - (⊢ (in-list- e-) : (Sequence ty))]) - -(define-typed-syntax in-lines - [(in-lines e) - #:with e- (⇑ e as String) - (⊢ (in-lines- (open-input-string e-)) : (Sequence String))]) - -(define-typed-syntax for - [(for ([x:id e]...) b ... body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) (b- ... body-) (ty_b ... ty_body)] - (infers/ctx+erase #'([x : ty] ...) #'(b ... body)) - (⊢ (for- ([x- e-] ...) b- ... body-) : Unit)]) -(define-typed-syntax for* - [(for* ([x:id e]...) body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) - (⊢ (for*- ([x- e-] ...) body-) : Unit)]) - -(define-typed-syntax for/list - [(for/list ([x:id e]...) body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) - (⊢ (for/list- ([x- e-] ...) body-) : (List ty_body))]) -(define-typed-syntax for/vector - [(for/vector ([x:id e]...) body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) - (⊢ (for/vector- ([x- e-] ...) body-) : (Vector ty_body))]) -(define-typed-syntax for*/vector - [(for*/vector ([x:id e]...) body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) - (⊢ (for*/vector- ([x- e-] ...) body-) : (Vector ty_body))]) -(define-typed-syntax for*/list - [(for*/list ([x:id e]...) body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) body- ty_body] (infer/ctx+erase #'([x : ty] ...) #'body) - (⊢ (for*/list- ([x- e-] ...) body-) : (List ty_body))]) -(define-typed-syntax for/fold - [(for/fold ([acc init]) ([x:id e] ...) body) - #:with [init- ty_init] (infer+erase #`(pass-expected init #,stx)) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(acc- x- ...) body- ty_body] - (infer/ctx+erase #'([acc : ty_init][x : ty] ...) #'body) - #:fail-unless (typecheck? #'ty_body #'ty_init) - (type-error #:src stx - #:msg - "for/fold: Type of body and initial accumulator must be the same, given ~a and ~a" - #'ty_init #'ty_body) - (⊢ (for/fold- ([acc- init-]) ([x- e-] ...) body-) : ty_body)]) - -(define-typed-syntax for/hash - [(for/hash ([x:id e]...) body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) body- (~× ty_k ty_v)] - (infer/ctx+erase #'([x : ty] ...) #'body) - (⊢ (for/hash- ([x- e-] ...) - (let- ([t body-]) - (values- (car- t) (cadr- t)))) - : (Hash ty_k ty_v))]) - -(define-typed-syntax for/sum - [(for/sum ([x:id e]... - (~optional (~seq #:when guard) #:defaults ([guard #'#t]))) - body) - #:with ([e- (ty)] ...) (⇑s (e ...) as Sequence) - #:with [(x- ...) (guard- body-) (_ ty_body)] - (infers/ctx+erase #'([x : ty] ...) #'(guard body)) - #:when (Int? #'ty_body) - (⊢ (for/sum- ([x- e-] ... #:when guard-) body-) : Int)]) - -; printing and displaying -(define-typed-syntax printf - [(printf str e ...) - #:with s- (⇑ str as String) - #:with ([e- ty] ...) (infers+erase #'(e ...)) - (⊢ (printf- s- e- ...) : Unit)]) -(define-typed-syntax format - [(format str e ...) - #:with s- (⇑ str as String) - #:with ([e- ty] ...) (infers+erase #'(e ...)) - (⊢ (format- s- e- ...) : String)]) -(define-typed-syntax display - [(display e) - #:with [e- _] (infer+erase #'e) - (⊢ (display- e-) : Unit)]) -(define-typed-syntax displayln - [(displayln e) - #:with [e- _] (infer+erase #'e) - (⊢ (displayln- e-) : Unit)]) -(define-primop newline : (→ Unit)) - -(define-typed-syntax list->vector - [(list->vector e) - #:with [e- (ty)] (⇑ e as List) - (⊢ (list->vector- e-) : (Vector ty))]) - -(define-typed-syntax let - [(let name:id (~datum :) ty:type ~! ([x:id e] ...) b ... body) - #:with ([e- ty_e] ...) (infers+erase #'(e ...)) - #:with [(name- . xs-) (body- ...) (_ ... ty_body)] - (infers/ctx+erase #'([name : (→ ty_e ... ty.norm)][x : ty_e] ...) - #'(b ... body)) - #:fail-unless (typecheck? #'ty_body #'ty.norm) - (format "type of let body ~a does not match expected typed ~a" - (type->str #'ty_body) (type->str #'ty)) - (⊢ (letrec- ([name- (λ- xs- body- ...)]) - (name- e- ...)) - : ty_body)] - [(let ([x:id e] ...) body ...) - #'(ext-stlc:let ([x e] ...) (begin body ...))]) -(define-typed-syntax let* - [(let* ([x:id e] ...) body ...) - #'(ext-stlc:let* ([x e] ...) (begin body ...))]) - -(define-typed-syntax begin - [(begin body ... b) - #:with expected (get-expected-type stx) - #:with b_ann #'(add-expected b expected) - #'(ext-stlc:begin body ... b_ann)]) - -;; hash -(define-type-constructor Hash #:arity = 2) - -(define-typed-syntax in-hash - [(in-hash e) - #:with [e- (ty_k ty_v)] (⇑ e as Hash) - (⊢ (hash-map- e- list-) - : (Sequence (stlc+rec-iso:× ty_k ty_v)))]) - -; mutable hashes -(define-typed-syntax hash - [(hash (~and tys {ty_key ty_val})) - #:when (brace? #'tys) - (⊢ (make-hash-) : (Hash ty_key ty_val))] - [(hash (~seq k v) ...) - #:with ([k- ty_k] ...) (infers+erase #'(k ...)) - #:with ([v- ty_v] ...) (infers+erase #'(v ...)) - #:when (same-types? #'(ty_k ...)) - #:when (same-types? #'(ty_v ...)) - #:with ty_key (stx-car #'(ty_k ...)) - #:with ty_val (stx-car #'(ty_v ...)) - (⊢ (make-hash- (list- (cons- k- v-) ...)) : (Hash ty_key ty_val))]) -(define-typed-syntax hash-set! - [(hash-set! h k v) - #:with [h- (ty_key ty_val)] (⇑ h as Hash) - #:with [k- ty_k] (infer+erase #'k) - #:with [v- ty_v] (infer+erase #'v) - #:when (typecheck? #'ty_k #'ty_key) - #:when (typecheck? #'ty_v #'ty_val) - (⊢ (hash-set!- h- k- v-) : Unit)]) -(define-typed-syntax hash-ref - [(hash-ref h k) - #:with [h- (ty_key ty_val)] (⇑ h as Hash) - #:with [k- ty_k] (infer+erase #'k) - #:when (typecheck? #'ty_k #'ty_key) - (⊢ (hash-ref- h- k-) : ty_val)] - [(hash-ref h k fail) - #:with [h- (ty_key ty_val)] (⇑ h as Hash) - #:with [k- ty_k] (infer+erase #'k) - #:when (typecheck? #'ty_k #'ty_key) - #:with [fail- (~?∀ () (~ext-stlc:→ ty_fail))] (infer+erase #'fail) - #:when (typecheck? #'ty_fail #'ty_val) - (⊢ (hash-ref- h- k- fail-) : ty_val)]) -(define-typed-syntax hash-has-key? - [(hash-has-key? h k) - #:with [h- (ty_key _)] (⇑ h as Hash) - #:with [k- ty_k] (infer+erase #'k) - #:when (typecheck? #'ty_k #'ty_key) - (⊢ (hash-has-key?- h- k-) : Bool)]) - -(define-typed-syntax hash-count - [(hash-count h) - #:with [h- _] (⇑ h as Hash) - (⊢ (hash-count- h-) : Int)]) - -(define-base-type String-Port) -(define-base-type Input-Port) -(define-primop open-output-string : (→ String-Port)) -(define-primop get-output-string : (→ String-Port String)) -(define-primop string-upcase : (→ String String)) - -(define-typed-syntax write-string - [(write-string str out) - #'(write-string str out (ext-stlc:#%datum . 0) (string-length str))] - [(write-string str out start end) - #:with str- (⇑ str as String) - #:with out- (⇑ out as String-Port) - #:with start- (⇑ start as Int) - #:with end- (⇑ end as Int) - (⊢ (write-string- str- out- start- end-) : Unit)]) - -(define-typed-syntax string-length - [(string-length str) - #:with str- (⇑ str as String) - (⊢ (string-length- str-) : Int)]) -(define-primop make-string : (→ Int String)) -(define-primop string-set! : (→ String Int Char Unit)) -(define-primop string-ref : (→ String Int Char)) -(define-typed-syntax string-copy! - [(string-copy! dest dest-start src) - #'(string-copy! - dest dest-start src (ext-stlc:#%datum . 0) (string-length src))] - [(string-copy! dest dest-start src src-start src-end) - #:with dest- (⇑ dest as String) - #:with src- (⇑ src as String) - #:with dest-start- (⇑ dest-start as Int) - #:with src-start- (⇑ src-start as Int) - #:with src-end- (⇑ src-end as Int) - (⊢ (string-copy!- dest- dest-start- src- src-start- src-end-) : Unit)]) - -(define-primop fl+ : (→ Float Float Float)) -(define-primop fl- : (→ Float Float Float)) -(define-primop fl* : (→ Float Float Float)) -(define-primop fl/ : (→ Float Float Float)) -(define-primop flsqrt : (→ Float Float)) -(define-primop flceiling : (→ Float Float)) -(define-primop inexact->exact : (→ Float Int)) -(define-primop exact->inexact : (→ Int Float)) -(define-primop char->integer : (→ Char Int)) -(define-primop real->decimal-string : (→ Float Int String)) -(define-primop fx->fl : (→ Int Float)) -(define-typed-syntax quotient+remainder - [(quotient+remainder x y) - #:with x- (⇑ x as Int) - #:with y- (⇑ y as Int) - (⊢ (let-values- ([[a b] (quotient/remainder- x- y-)]) - (list- a b)) - : (stlc+rec-iso:× Int Int))]) -(define-primop quotient : (→ Int Int Int)) - -(define-typed-syntax set! - [(set! x:id e) - #:with [x- ty_x] (infer+erase #'x) - #:with [e- ty_e] (infer+erase #'e) - #:when (typecheck? #'ty_e #'ty_x) - (⊢ (set!- x e-) : Unit)]) - -(define-typed-syntax provide-type [(provide-type ty ...) #'(provide- ty ...)]) - -(define-typed-syntax provide - [(provide x:id ...) - #:with ([x- ty_x] ...) (infers+erase #'(x ...)) - ; TODO: use hash-code to generate this tmp - #:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...)) - #'(begin- - (provide- x ...) - (stlc+rec-iso:define-type-alias x-ty ty_x) ... - (provide- x-ty ...))]) -(define-typed-syntax require-typed - [(require-typed x:id ... #:from mod) - #:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...)) - #:with (y ...) (generate-temporaries #'(x ...)) - #'(begin- - (require- (rename-in- (only-in- mod x ... x-ty ...) [x y] ...)) - (define-syntax x (make-rename-transformer (assign-type #'y #'x-ty))) ...)]) - -(define-base-type Regexp) -(define-primop regexp-match : (→ Regexp String (List String))) -(define-primop regexp : (→ String Regexp)) - -(define-typed-syntax equal? - [(equal? e1 e2) - #:with [e1- ty1] (infer+erase #'e1) - #:with [e2- ty2] (infer+erase #'(add-expected e2 ty1)) - #:fail-unless (typecheck? #'ty1 #'ty2) "arguments to equal? have different types" - (⊢ (equal?- e1- e2-) : Bool)]) - -(define-typed-syntax read - [(read) - (⊢ (let- ([x (read-)]) - (cond- [(eof-object?- x) ""] - [(number?- x) (number->string- x)] - [(symbol?- x) (symbol->string- x)])) : String)]) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(module+ test - (begin-for-syntax - (check-true (covariant-Xs? #'Int)) - (check-true (covariant-Xs? #'(stlc+box:Ref Int))) - (check-true (covariant-Xs? #'(→ Int Int))) - (check-true (covariant-Xs? #'(∀ (X) X))) - (check-false (covariant-Xs? #'(∀ (X) (stlc+box:Ref X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ X X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ X Int)))) - (check-true (covariant-Xs? #'(∀ (X) (→ Int X)))) - (check-true (covariant-Xs? #'(∀ (X) (→ (→ X Int) X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ (→ (→ X Int) Int) X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ (stlc+box:Ref X) Int)))) - (check-false (covariant-Xs? #'(∀ (X Y) (→ X Y)))) - (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) Y)))) - (check-false (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Y Int))))) - (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Int Y))))) - (check-false (covariant-Xs? #'(∀ (A B) (→ (→ Int (stlc+rec-iso:× A B)) - (→ String (stlc+rec-iso:× A B)) - (stlc+rec-iso:× A B))))) - (check-true (covariant-Xs? #'(∀ (A B) (→ (→ (stlc+rec-iso:× A B) Int) - (→ (stlc+rec-iso:× A B) String) - (stlc+rec-iso:× A B))))) - )) diff --git a/tapl/stlc+box.rkt b/tapl/stlc+box.rkt @@ -1,27 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+cons.rkt") - -;; Simply-Typed Lambda Calculus, plus mutable references -;; Types: -;; - types from stlc+cons.rkt -;; - Ref constructor -;; Terms: -;; - terms from stlc+cons.rkt -;; - ref deref := - -(define-type-constructor Ref) - -(define-typed-syntax ref - [(ref e) - #:with (e- τ) (infer+erase #'e) - (⊢ (box- e-) : (Ref τ))]) -(define-typed-syntax deref - [(deref e) - #:with (e- (τ)) (⇑ e as Ref) - (⊢ (unbox- e-) : τ)]) -(define-typed-syntax := #:literals (:=) - [(:= e_ref e) - #:with (e_ref- (τ1)) (⇑ e_ref as Ref) - #:with (e- τ2) (infer+erase #'e) - #:when (typecheck? #'τ1 #'τ2) - (⊢ (set-box!- e_ref- e-) : Unit)]) diff --git a/tapl/stlc+cons.rkt b/tapl/stlc+cons.rkt @@ -1,91 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+reco+var.rkt") - -;; Simply-Typed Lambda Calculus, plus cons -;; Types: -;; - types from stlc+reco+var.rkt -;; - List constructor -;; Terms: -;; - terms from stlc+reco+var.rkt - -;; TODO: enable HO use of list primitives - -(define-type-constructor List) - -(define-typed-syntax nil - [(nil ~! τi:type-ann) - (⊢ null- : (List τi.norm))] - ; minimal type inference - [nil:id #:with expected-τ (get-expected-type #'nil) - #:when (syntax-e #'expected-τ) ; 'expected-type property exists (ie, not false) - #:with ty_lst (local-expand #'expected-τ 'expression null) ; canonicalize - #:fail-unless (List? #'ty_lst) - (raise (exn:fail:type:infer - (format "~a (~a:~a): Inferred ~a type for nil, which is not a List." - (syntax-source stx) (syntax-line stx) (syntax-column stx) - (type->str #'ty_lst)) - (current-continuation-marks))) - #:with (~List τ) #'ty_lst - (⊢ null- : (List τ))] - [_:id #:fail-when #t - (raise (exn:fail:type:infer - (format "~a (~a:~a): nil requires type annotation" - (syntax-source stx) (syntax-line stx) (syntax-column stx)) - (current-continuation-marks))) - #'(void-)]) -(define-typed-syntax cons - [(cons e1 e2) - #:with [e1- τ1] (infer+erase #'e1) -; #:with e2ann (add-expected-type #'e2 #'(List τ1)) - #:with (e2- (τ2)) (⇑ (add-expected e2 (List τ1)) as List) - #:fail-unless (typecheck? #'τ1 #'τ2) - (format "trying to cons expression ~a with type ~a to list ~a with type ~a\n" - (syntax->datum #'e1) (type->str #'τ1) - (syntax->datum #'e2) (type->str #'(List τ2))) - ;; propagate up inferred types of variables - #:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e1- e2-)))) - #:with result-cons (add-env #'(cons- e1- e2-) #'env) - (⊢ result-cons : (List τ1))]) -(define-typed-syntax isnil - [(isnil e) - #:with (e- _) (⇑ e as List) - (⊢ (null?- e-) : Bool)]) -(define-typed-syntax head - [(head e) - #:with (e- (τ)) (⇑ e as List) - (⊢ (car- e-) : τ)]) -(define-typed-syntax tail - [(tail e) - #:with (e- τ-lst) (infer+erase #'e) - #:when (List? #'τ-lst) - (⊢ (cdr- e-) : τ-lst)]) -(define-typed-syntax list - [(list) #'nil] - [(_ x . rst) ; has expected type - #:with expected-τ (get-expected-type stx) - #:when (syntax-e #'expected-τ) - #:with (~List τ) (local-expand #'expected-τ 'expression null) - #'(cons (add-expected x τ) (list . rst))] - [(_ x . rst) ; no expected type - #'(cons x (list . rst))]) -(define-typed-syntax reverse - [(reverse e) - #:with (e- τ-lst) (infer+erase #'e) - #:when (List? #'τ-lst) - (⊢ (reverse- e-) : τ-lst)]) -(define-typed-syntax length - [(length e) - #:with (e- τ-lst) (infer+erase #'e) - #:when (List? #'τ-lst) - (⊢ (length- e-) : Int)]) -(define-typed-syntax list-ref - [(list-ref e n) - #:with (e- (ty)) (⇑ e as List) - #:with n- (⇑ n as Int) - (⊢ (list-ref- e- n-) : ty)]) -(define-typed-syntax member - [(member v e) - #:with (e- (ty)) (⇑ e as List) - #:with [v- ty_v] (infer+erase #'(add-expected v ty)) - #:when (typecheck? #'ty_v #'ty) - (⊢ (member- v- e-) : Bool)]) diff --git a/tapl/stlc+effect.rkt b/tapl/stlc+effect.rkt @@ -1,138 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+box.rkt" #:except ref deref := #%app λ) - -(provide (for-syntax get-new-effects)) - -;; Simply-Typed Lambda Calculus, plus mutable references -;; Types: -;; - types from stlc+cons.rkt -;; - Ref constructor -;; Terms: -;; - terms from stlc+cons.rkt -;; - ref deref := - -(begin-for-syntax - (define (add-news e locs) (syntax-property e 'ν locs)) - (define (add-assigns e locs) (syntax-property e ':= locs)) - (define (add-derefs e locs) (syntax-property e '! locs)) - (define (add-effects e new-locs assign-locs deref-locs) - (add-derefs - (add-assigns - (add-news e new-locs) - assign-locs) - deref-locs)) - - (define (get-effects e tag [vs '()]) - (or (syntax-property - (local-expand (if (null? vs) e #`(stlc+box:λ #,vs #,e)) 'expression null) - tag) - null)) - (define (get-new-effects e [vs '()]) (get-effects e 'ν vs)) - (define (get-assign-effects e [vs '()]) (get-effects e ':= vs)) - (define (get-deref-effects e [vs '()]) (get-effects e '! vs)) - - (define (print-effects e) - (printf "expr ~a\n" (syntax->datum e)) - (define e+ (local-expand e 'expression null)) - (printf "new locs: ~a\n" (syntax-property e+ 'ν)) - (printf "deref locs: ~a\n" (syntax-property e+ '!)) - (printf "assign locs: ~a\n" (syntax-property e+ ':=))) - - (define (loc-union locs1 locs2) - (cond - [(not locs1) locs2] - [(not locs2) locs1] - [else (set-union locs1 locs2)]))) - - -(define-typed-syntax effect:#%app #:export-as #%app - [(_ efn e ...) - #:with [e_fn- ty_fn fns fas fds] (infer+erase/eff #'efn) - #:with tyns (get-new-effects #'ty_fn) - #:with tyas (get-assign-effects #'ty_fn) - #:with tyds (get-deref-effects #'ty_fn) - #:with (~→ τ_in ... τ_out) #'ty_fn - #:with ([e_arg- τ_arg ns as ds] ...) (infers+erase/eff #'(e ...)) -; #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn as →) - #:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...)) - (mk-app-err-msg stx #:expected #'(τ_in ...) - #:given #'(τ_arg ...) - #:note "Wrong number of arguments.") - #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) - (mk-app-err-msg stx #:expected #'(τ_in ...) - #:given #'(τ_arg ...)) - (assign-type/eff #'(#%app- e_fn- e_arg- ...) #'τ_out - (stx-flatten #'(fns tyns . (ns ...))) - (stx-flatten #'(fas tyas . (as ...))) - (stx-flatten #'(fds tyds . (ds ...)))) - #;(let ([φ-news (stx-map get-new-effects #'(τfn efn e ...))] - [φ-assigns (stx-map get-assign-effects #'(τfn efn e ...))] - [φ-derefs (stx-map get-deref-effects #'(τfn efn e ...))]) - (add-effects #'(stlc+box:#%app efn e ...) - (foldl loc-union (set) φ-news) - (foldl loc-union (set) φ-assigns) - (foldl loc-union (set) φ-derefs)))]) - -(define-typed-syntax λ - [(λ bvs:type-ctx e) - #:with [xs- e- τ_res ns as ds] (infer/ctx+erase/eff #'bvs #'e) - (assign-type #'(λ- xs- e-) - (add-effects #'(→ bvs.type ... τ_res) #'ns #'as #'ds))]) - -#;(define-typed-syntax λ - [(λ bvs:type-ctx e) - #:with (xs- e- τ_res) (infer/ctx+erase #'bvs #'e) - (let ([φ-news (get-new-effects #'e-)] - [φ-assigns (get-assign-effects #'e-)] - [φ-derefs (get-deref-effects #'e-)]) - (assign-type - #'(λ- xs- e-) - (add-effects #'(→ bvs.type ... τ_res) φ-news φ-assigns φ-derefs)))]) - -(define-type-constructor Ref) - -(begin-for-syntax - (define (infer+erase/eff e) - (define/with-syntax [e- ty] (infer+erase e)) - (list - #'e- #'ty - (get-new-effects #'e-) (get-assign-effects #'e-) (get-deref-effects #'e-))) - (define (infers+erase/eff es) - (stx-map infer+erase/eff es)) - (define (infer/ctx+erase/eff bvs e) - (define/with-syntax [xs- e- ty] (infer/ctx+erase bvs e)) - (list #'xs- #'e- #'ty - (get-new-effects #'e-) (get-assign-effects #'e-) (get-deref-effects #'e-))) - (define (assign-type/eff e ty news assigns derefs) - (assign-type (add-effects e news assigns derefs) ty))) - -(define-typed-syntax ref - [(ref e) - #:with (e- τ ns as ds) (infer+erase/eff #'e) - (assign-type/eff #'(box- e-) #'(Ref τ) - (cons (syntax-position stx) #'ns) #'as #'ds)]) -(define-typed-syntax deref - [(deref e) - #:with (e- (~Ref ty) ns as ds) (infer+erase/eff #'e) - (assign-type/eff #'(unbox- e-) #'ty - #'ns #'as (cons (syntax-position stx) #'ds))]) -(define-typed-syntax := #:literals (:=) - [(:= e_ref e) - ;#:with (e_ref- (τ1)) (⇑ e_ref as Ref) - #:with [e_ref- (~Ref ty1) ns1 as1 ds1] (infer+erase/eff #'e_ref) - #:with [e- ty2 ns2 as2 ds2] (infer+erase/eff #'e) - #:when (typecheck? #'ty1 #'ty2) - (assign-type/eff #'(set-box!- e_ref- e-) #'Unit - (stx-append #'ns1 #'ns2) - (cons (syntax-position stx) (stx-append #'as1 #'as2)) - (stx-append #'ds1 #'ds2))]) -;(define-typed-syntax ref -; [(_ e) -; (syntax-property #'(stlc+box:ref e) 'ν (set (syntax-position stx)))]) -;(define-typed-syntax deref -; [(_ e) -; (syntax-property #'(stlc+box:deref e) '! (set (syntax-position stx)))]) -;(define-typed-syntax := -; [(_ e_ref e) -; (syntax-property #'(stlc+box::= e_ref e) ':= (set (syntax-position stx)))]) - diff --git a/tapl/stlc+lit.rkt b/tapl/stlc+lit.rkt @@ -1,39 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc.rkt") -(provide define-primop) - -;; Simply-Typed Lambda Calculus, plus numeric literals and primitives -;; Types: -;; - types from stlc.rkt -;; - Int -;; Terms: -;; - terms from stlc.rkt -;; - numeric literals -;; - prim + -;; Typechecking forms: -;; - define-primop - -(define-base-type Int) - -(define-syntax define-primop - (syntax-parser #:datum-literals (:) - [(_ op:id : τ:type) - #:with op/tc (generate-temporary #'op) - #'(begin - (provide (rename-out [op/tc op])) - (define-primop op/tc op : τ))] - [(_ op/tc op : τ) - #'(begin - #;(define-syntax op/tc (make-rename-transformer (assign-type #'op #'τ))) - ; rename transformer doesnt seem to expand at the right time - ; - op still has no type in #%app - (define-syntax op/tc - (make-variable-like-transformer (assign-type #'op #'τ))))])) - -(define-primop + : (→ Int Int Int)) - -(define-typed-syntax #%datum #:literals (#%datum) - [(#%datum . n:integer) (⊢ #,(syntax/loc stx (#%datum- . n)) : Int)] - [(#%datum . x) - #:when (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x) - #'(#%datum- . x)]) diff --git a/tapl/stlc+occurrence.rkt b/tapl/stlc+occurrence.rkt @@ -1,355 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+sub.rkt" #:except #%datum) -(extends "stlc+cons.rkt" #:except + #%datum and tup × proj ~× list) -(reuse tup × proj #:from "stlc+tup.rkt") -(require (only-in "stlc+tup.rkt" ~×)) - -;; Calculus for occurrence typing. -;; - Types can be simple, or sets of simple types -;; (aka "ambiguous types"; -;; the run-time value will have one of a few ambiguous possible types.) -;; - The ∪ constructor makes ambiguous types -;; - `(test [τ ? x] e1 e2)` form will insert a run-time check to discriminate ∪ -;; -- If the value at identifier x has type τ, then we continue to e1 with [x : τ] -;; -- Otherwise, we move to e2 with [x : (- (typeof x) τ)]. -;; i.e., [x : τ] is not possible -;; - Subtyping rules: -;; -- ALL : t ... <: t' => (U t ...) <: t' -;; -- AMB : t <: (U ... t ...) -;; -- EXT : (U t' ...) <: (U t t' ...) -;; -- ONE : a<:b => (U a t' ...) <: (U b t' ...) - -;; ============================================================================= - -(define-base-type Bot) ;; For empty unions -(define-base-type Boolean) -(define-base-type Str) - -(define-typed-syntax #%datum - [(#%datum . n:boolean) (⊢ (#%datum- . n) : Boolean)] - [(#%datum . n:str) (⊢ (#%datum- . n) : Str)] - [(#%datum . x) #'(stlc+sub:#%datum . x)]) - -(define-type-constructor ∪ #:arity >= 1) - -;; ----------------------------------------------------------------------------- -;; --- Union operations - -;; Occurrence type operations -;; These assume that τ is a type in 'normal form' -(begin-for-syntax - (define (∪->list τ) - ;; Ignore type constructor & the kind - ;; (because there are no bound identifiers) - (syntax-parse τ - [(~∪ τ* ...) - (syntax->list #'(τ* ...))] - [_ - (error '∪->list (format "Given non-ambiguous type '~a'" τ))])) - - (define (list->∪ τ*) - (if (null? τ*) - #'Bot - (τ-eval #`(∪ #,@τ*)))) - - (define (∖ τ1 τ2) - (cond - [(∪? τ1) - (define (not-τ2? τ) - (not (typecheck? τ τ2))) - (list->∪ (filter not-τ2? (∪->list τ1)))] - [else ; do nothing not non-union types - τ1])) -) - -;; ----------------------------------------------------------------------------- -;; --- Normal Form -;; Evaluate each type in the union, -;; remove duplicates -;; determinize the ordering of members -;; flatten nested unions - -(begin-for-syntax - - (define τ-eval (current-type-eval)) - - (define (τ->symbol τ) - (syntax-parse τ - [(_ κ) - (syntax->datum #'κ)] - [(_ κ (_ () _ τ* ...)) - (define κ-str (symbol->string (syntax->datum #'κ))) - (define τ-str* - (map (compose1 symbol->string τ->symbol) (syntax->list #'(τ* ...)))) - (string->symbol - (string-append - (apply string-append "(" κ-str τ-str*) - ")"))] - [_ - (error 'τ->symbol (~a (syntax->datum τ)))])) - - (define ∪-eval - ;; Private helper: check that all functions have unique arities - ;; It's private because it assumes all τ* have been evaluated - (let ([assert-unique-arity-arrows - (lambda (τ*) - (for/fold ([seen '()]) - ([τ (in-list τ*)]) - (syntax-parse τ - [(~→ τ-dom* ... τ-cod) - (define arity (stx-length #'(τ-dom* ...))) - (when (memv arity seen) - (error '∪ (format "Cannot discriminate types in the union ~a. Multiple functions have arity ~a." (cons '∪ (map syntax->datum τ*)) arity))) - (cons arity seen)] - [_ seen])))]) - (lambda (τ-stx) - (syntax-parse (τ-eval τ-stx) - [(~∪ τ-stx* ...) - ;; Recursively evaluate members - (define τ** - (for/list ([τ (in-list (syntax->list #'(τ-stx* ...)))]) - (let ([τ+ (∪-eval τ)]) - (if (∪? τ+) - (∪->list τ+) - (list τ+))))) - ;; Remove duplicates from the union, sort members - (define τ* - (sort - (remove-duplicates (apply append τ**) (current-type=?)) - symbol<? - #:key τ->symbol)) - ;; Check for empty & singleton lists - (define τ - (cond - [(null? τ*) - (raise-user-error 'τ-eval "~a (~a:~a) empty union type ~a\n" - (syntax-source τ-stx) (syntax-line τ-stx) (syntax-column τ-stx) - (syntax->datum τ-stx))] - [(null? (cdr τ*)) - #`#,(car τ*)] - [else - (assert-unique-arity-arrows τ*) - #`#,(cons #'∪ τ*)])) - (τ-eval τ)] - [_ - (τ-eval τ-stx)])))) - (current-type-eval ∪-eval)) - -;; ----------------------------------------------------------------------------- -;; --- Subtyping - -(begin-for-syntax - ;; True if one ordered list (of types) is a subset of another - (define (subset? x* y* #:leq [cmp (current-typecheck-relation)]) - (let loop ([x* x*] [y* y*]) - (cond - [(null? x*) #t] - [(null? y*) #f] - [(cmp (car x*) (car y*)) - (loop (cdr x*) (cdr y*))] - [else - (loop x* (cdr y*))]))) - - (define ∪-sub? - (let ([sub? (current-sub?)]) - (lambda (τ1-stx τ2-stx) - (define τ1 ((current-type-eval) τ1-stx)) - (define τ2 ((current-type-eval) τ2-stx)) - (or (Bot? τ1) (Top? τ2) - (match `(,(∪? τ1) ,(∪? τ2)) - ['(#f #t) - ;; AMB : a<:b => a <: (U ... b ...) - (for/or ([τ (in-list (∪->list τ2))]) - ((current-sub?) τ1 τ))] - ['(#t #t) - (define τ1* (∪->list τ1)) - (define τ2* (∪->list τ2)) - (match `(,(length τ1*) ,(length τ2*)) - [`(,L1 ,L2) #:when (< L1 L2) - ;; - EXT : (U t' ...) <: (U t t' ...) - (subset? τ1* τ2* #:leq (current-sub?))] - [`(,L1 ,L2) #:when (= L1 L2) - ;; - SUB : a<:b => (U a t' ...) <: (U b t' ...) - ;; `∪->list` guarantees same order on type members - ;; `sub?` is reflexive - (andmap (current-sub?) τ1* τ2*)] - [_ #f])] - ['(#t #f) - ;; - ALL : t... <: t' => (U t ...) <: t' - (andmap (lambda (τ) ((current-sub?) τ τ2)) (∪->list τ1))] - ['(#f #f) - ;; Fall back to OLD sub - (sub? τ1 τ2)]))))) - - (current-sub? ∪-sub?) - (current-typecheck-relation (current-sub?)) -) - -;; ----------------------------------------------------------------------------- -;; --- Filters -;; These are stored imperatively, in a function. -;; Makes it easy to add a new filter & avoids duplicating this map - -(begin-for-syntax - (define current-Π (make-parameter (lambda (x) (error 'Π)))) - - (define (type->filter τ) - (define f ((current-Π) τ)) - (unless f - (error 'τ->filter (format "Could not express type '~a' as a filter." (syntax->datum τ)))) - f) - - (define (type*->filter* τ*) - (map (current-Π) τ*)) - - (define (simple-Π τ) - (syntax-parse (τ-eval τ) - [~Boolean - #'boolean?-] - [~Int - #'integer?-] - [~Str - #'string?-] - [~Num - #'number?-] - [~Nat - #'(lambda- (n) (and- (integer?- n) (not- (negative?- n))))] - [(~→ τ* ... τ) - (define k (stx-length #'(τ* ...))) - #`(lambda- (f) (and- (procedure?- f) (procedure-arity-includes?- f #,k #f)))] - [(~∪ τ* ...) - (define filter* (type*->filter* (syntax->list #'(τ* ...)))) - #`(lambda- (v) (for/or- ([f (in-list- (list- #,@filter*))]) (f v)))] - [_ - (error 'Π "Cannot make filter for type ~a\n" (syntax->datum τ))])) - (current-Π simple-Π) - -) - -;; (test (τ ? x) e1 e2) -;; - drop absurd branches? -;; - allow x not identifier (1. does nothing 2. latent filters) -(define-typed-syntax test #:datum-literals (?) - ;; -- THIS CASE BELONGS IN A NEW FILE - [(test [τ0+:type ? (unop x-stx:id n-stx:nat)] e1 e2) - ;; 1. Check that we're using a known eliminator - #:when (free-identifier=? #'stlc+tup:proj #'unop) - ;; 2. Make sure we're filtering with a valid type - #:with f (type->filter #'τ0+) - ;; 3. Typecheck the eliminator call. Remember the type & apply the filter. - ;; (This type is PROBABLY a union -- else why bother testing!) - #:with (e0+ τ0) (infer+erase #'(unop x-stx n-stx)) - #:with τ0- (∖ #'τ0 #'τ0+) - ;; 4. Build the +/- types for our identifier; the thing we apply the elim. + test to - ;; We know that x has a pair type because (proj x n) typechecked - #:with (x (~× τi* ...)) (infer+erase #'x-stx) - #:with τ+ #`(stlc+tup:× #,@(replace-at (syntax->list #'(τi* ...)) (syntax-e #'n-stx) #'τ0+)) - #:with τ- #`(stlc+tup:× #,@(replace-at (syntax->list #'(τi* ...)) (syntax-e #'n-stx) #'τ0-)) - ;; 5. Check the branches with the refined types - #:with [x1 e1+ τ1] (infer/ctx+erase #'([x-stx : τ+]) #'e1) - #:with [x2 e2+ τ2] (infer/ctx+erase #'([x-stx : τ-]) #'e2) - ;; 6. Desugar, replacing the filtered identifier - (⊢ (if- (f e0+) - ((lambda- x1 e1+) x-stx) - ((lambda- x2 e2+) x-stx)) - : (∪ τ1 τ2))] - ;; TODO lists - ;; For now, we can't express the type (List* A (U A B)), so our filters are too strong - ;; -- THE ORIGINAL - [(test [τ0+:type ? x-stx:id] e1 e2) - #:with f (type->filter #'τ0+) - #:with (x τ0) (infer+erase #'x-stx) - #:with τ0- (∖ #'τ0 #'τ0+) - #:with [x1 e1+ τ1] (infer/ctx+erase #'([x-stx : τ0+]) #'e1) - #:with [x2 e2+ τ2] (infer/ctx+erase #'([x-stx : τ0-]) #'e2) - ;; Expand to a conditional, using the runtime predicate - (⊢ (if- (f x-stx) - ((lambda- x1 e1+) x-stx) - ((lambda- x2 e2+) x-stx)) - : (∪ τ1 τ2))]) - -;; ============================================================================= -;; === BELONGS IN A NEW FILE - -;; (extends "stlc+occurrence.rkt"); #:rename [test ot:test]) -;; (extends "stlc+tup.rkt" #:except + #%datum) - -(define-for-syntax (replace-at τ* n τ-new) - (for/list ([τ-old (in-list τ*)] - [i (in-naturals)]) - (if (= i n) - τ-new - τ-old))) - -;; Add subtyping for tuples -(begin-for-syntax - (define ×-sub? - (let ([sub? (current-sub?)]) - (lambda (τ1-stx τ2-stx) - (define τ1 ((current-type-eval) τ1-stx)) - (define τ2 ((current-type-eval) τ2-stx)) - (or (Bot? τ1) (Top? τ2) - (syntax-parse `(,τ1 ,τ2) - [((~× τi1* ...) - (~× τi2* ...)) - (and (stx-length=? #'(τi1* ...) - #'(τi2* ...)) - ;; Gotta use (current-sub?), because products may be recursive - (stx-andmap (current-sub?) #'(τi1* ...) #'(τi2* ...)))] - [_ - (sub? τ1 τ2)]))))) - (current-sub? ×-sub?) - (current-typecheck-relation (current-sub?))) - -;; --- Update Π for products -(begin-for-syntax - (define π-Π - (let ([Π (current-Π)]) - (lambda (τ) - (syntax-parse (τ-eval τ) - [(~× τ* ...) - (define filter* (type*->filter* (syntax->list #'(τ* ...)))) - #`(lambda- (v*) - (and- (list?- v*) - (for/and- ([v (in-list- v*)] - [f (in-list- (list- #,@filter*))]) - (f v))))] - [_ ;; Fall back - (Π τ)])))) - (current-Π π-Π)) - -;; ============================================================================= -;; === Lists - -;; Subtyping for lists -(begin-for-syntax - (define list-sub? - (let ([sub? (current-sub?)]) - (lambda (τ1-stx τ2-stx) - (define τ1 ((current-type-eval) τ1-stx)) - (define τ2 ((current-type-eval) τ2-stx)) - (or (Bot? τ1) (Top? τ2) - (syntax-parse `(,τ1 ,τ2) - [((~List τi1) - (~List τi2)) - ((current-sub?) #'τi1 #'τi2)] - [_ - (sub? τ1 τ2)]))))) - (current-sub? list-sub?) - (current-typecheck-relation (current-sub?))) - -;; --- Update Π for lists -(begin-for-syntax - (define list-Π - (let ([Π (current-Π)]) - (lambda (τ) - (syntax-parse (τ-eval τ) - [(~List τi) - (define f ((current-Π) #'τi)) - #`(lambda- (v*) - (and- (list?- v*) - (for/and- ([v (in-list- v*)]) - (#,f v))))] - [_ ;; Fall back - (Π τ)])))) - (current-Π list-Π)) diff --git a/tapl/stlc+overloading.rkt b/tapl/stlc+overloading.rkt @@ -1,164 +0,0 @@ -#lang s-exp "typecheck.rkt" -(reuse List cons nil #:from "stlc+cons.rkt") -(reuse #:from "stlc+rec-iso.rkt") ; to load current-type=? -(extends "stlc+sub.rkt" #:except #%datum) - -;; Revision of overloading, using identifier macros instead of overriding #%app - -;; ============================================================================= - -(define-base-type Bot) -(define-base-type Str) - -(define-typed-syntax #%datum - [(#%datum . n:str) (⊢ (#%datum- . n) : Str)] - [(#%datum . x) #'(stlc+sub:#%datum . x)]) - -(define-for-syntax xerox syntax->datum) - -;; ============================================================================= -;; === Resolvers - -(begin-for-syntax - (struct ℜ ( - name ;; Symbol - dom* ;; (Box (Listof (Pairof Type Expr))) - cod ;; Type - ) #:constructor-name make-ℜ - #:transparent - #:property prop:procedure - (lambda (self τ-or-e #:exact? [exact? #f]) - (define r - (if (syntax? τ-or-e) ;; Can I ask "type?" - (ℜ-resolve-syntax self τ-or-e #:exact? exact?) - (ℜ-resolve-value self τ-or-e #:exact? exact?))) - (or r - (error 'ℜ (format "Resolution for '~a' failed at type ~a" - (syntax->datum (ℜ-name self)) - τ-or-e)))) - ) - - ;; Rad! - (define (ℜ-add! ℜ τ e) - (define dom* (ℜ-dom* ℜ)) - (set-box! dom* (cons (cons τ e) (unbox dom*)))) - - (define (ℜ-init name τ-cod) - (make-ℜ name (box '()) τ-cod)) - - (define (ℜ->type ℜ #:subst [τ-dom (assign-type #''α #'#%type)]) - ((current-type-eval) #`(→ #,τ-dom #,(ℜ-cod ℜ)))) - - (define (ℜ-find ℜ τ #:=? =?) - (define (τ=? τ2) - (=? τ τ2)) - (assf τ=? (unbox (ℜ-dom* ℜ)))) - - (define (ℜ-resolve-syntax ℜ τ #:exact? [exact? #f]) - ;; First try exact matches, then fall back to subtyping (unless 'exact?' is set). - ;; When subtyping, the __order instances were declared__ resolves ties. - (define result - (or (ℜ-find ℜ τ #:=? (current-type=?)) - (and (not exact?) - (ℜ-find ℜ τ #:=? (current-typecheck-relation))))) - (and (pair? result) - (cdr result))) - - (define (ℜ-resolve-value ℜ e #:exact? [exact? #f]) - (error 'ℜ (format "Runtime resolution not implemented. Anyway your value was ~a" e))) - - (define (ℜ-unbound? ℜ τ) - (not (ℜ-resolve-syntax ℜ τ #:exact? #t))) - - (define (syntax->ℜ id) - ;; Don't care about the type - (define stx+τ (infer+erase id)) - ;; Boy, I wish I had a monad - (define (fail) - (error 'resolve (format "Identifier '~a' is not overloaded" (syntax->datum id)))) - (unless (pair? stx+τ) (fail)) - (define stx (car stx+τ)) - (unless (syntax? stx) (fail)) - (define ℜ-stx (syntax->datum (car stx+τ))) - (unless (and (list? ℜ-stx) - (not (null? ℜ-stx)) - (not (null? (cdr ℜ-stx)))) - (fail)) - (define ℜ (cadr ℜ-stx)) - (unless (ℜ? ℜ) (fail)) - ℜ) - - (define-syntax-rule (error-template sym id τ reason) - (error sym (format "Failure for '~a' at type '~a'. ~a" - (syntax->datum id) - (syntax->datum τ) - reason))) - - (define-syntax-rule (instance-error id τ reason) - (error-template 'instance id τ reason)) - - (define-syntax-rule (resolve-error id τ reason) - (error-template 'resolve id τ reason)) -) - -;; ============================================================================= -;; === Overloaded signature environment - -(define-typed-syntax signature - [(signature (name:id α:id) τ) - #:with ((α+) (~→ τ_α:id τ-cod) _) (infer/tyctx+erase #'([α : #%type]) #'τ) - (define ℜ (ℜ-init #'name #'τ-cod)) - (⊢ (define-syntax name - (syntax-parser - [_:id - #'(quote- #,ℜ)] ;; Is there a way to transmit ℜ directly? - [(n e) - #:with [e+ τ+] (infer+erase #'e) - #:with n+ (#,ℜ #'τ+) - (⊢ (#%app- n+ e+) - : τ-cod)] - [(_ e* (... ...)) - #'(raise-arity-error- (syntax->datum- name) 1 e* (... ...))])) - : Bot)] - [(signature e* ...) - (error 'signature (format "Expected (signature (NAME VAR) (→ VAR τ)), got ~a" (xerox #'(e* ...))))]) - -(define-typed-syntax resolve - [(resolve name:id τ) - #:with τ+ ((current-type-eval) #'τ) - ;; Extract a resolver from the syntax object - (define ℜ (syntax->ℜ #'name)) - ;; Apply the resolver to the argument type. woo-wee! - (⊢ #,(ℜ #'τ+ #:exact? #t) : #,(ℜ->type ℜ #:subst #'τ+))]) - -(define-typed-syntax instance - [(instance (name:id τ-stx) e) - #:with τ ((current-type-eval) #'τ-stx) - #:with [e+ τ+] (infer+erase #'e) - (define ℜ (syntax->ℜ #'name)) - (unless (ℜ-unbound? ℜ #'τ) (instance-error #'name #'τ "Overlaps with existing instance.")) - (define _unify ;; Should be a helper function - (syntax-parse #`(τ+ #,(ℜ->type ℜ)) - [((~→ τ_dom1 τ_cod1) - (~→ _ τ_cod2)) - ;; Really, need to unify this type with the template - ;; (unless ((current-type=?) τ_dom1 τ_dom2) - ;; (instance-error #'name #'τ (format "Domain '~a' must unify with template domain '~a'." - ;; (syntax->datum #'τ_dom1) (syntax->datum #'τ_dom2)))) - (unless ((current-type=?) ((current-type-eval) #'τ) #'τ_dom1) - (instance-error #'name #'τ (format "Domain '~a' must be the instance type, for now (2015-10-20)." (syntax->datum #'τ_dom1)))) - (unless ((current-type=?) #'τ_cod1 #'τ_cod2) - (instance-error #'name #'τ (format "Codomain '~a' must match template codomain '~a'" - (syntax->datum #'τ_cod1) (syntax->datum #'τ_cod2)))) - (void)] - [(a b) - (instance-error #'name #'τ (format "May only overload single-argument functions. (Got ~a and ~a)" - (syntax->datum #'a) (syntax->datum #'b)) - )])) - ;; Should we use syntax instead of e+ ? - (ℜ-add! ℜ #'τ #'e+) - (⊢ (void-) : Bot)] - [_ - (error 'instance "Expected (instance (id τ) e).")]) - - diff --git a/tapl/stlc+rec-iso.rkt b/tapl/stlc+rec-iso.rkt @@ -1,70 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+tup.rkt") -(reuse ∨ var case define-type-alias define #:from "stlc+reco+var.rkt") - -;; stlc + (iso) recursive types -;; Types: -;; - types from stlc+tup.rkt -;; - also ∨ from stlc+reco+var -;; - μ -;; Terms: -;; - terms from stlc+tup.rkt -;; - also var and case from stlc+reco+var -;; - fld, unfld -;; Other: -;; - extend type=? to handle lambdas - -(define-type-constructor μ #:bvs = 1) - -(begin-for-syntax - (define stlc:type=? (current-type=?)) - ;; extend to handle μ, ie lambdas - (define (type=? τ1 τ2) -; (printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum τ1)) -; (printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum τ2)) - (syntax-parse (list τ1 τ2) - ;; alternative #4: use old type=? for everything except lambda - [(((~literal #%plain-lambda) (x:id ...) t1 ...) - ((~literal #%plain-lambda) (y:id ...) t2 ...)) - (and (stx-length=? #'(x ...) #'(y ...)) - (stx-length=? #'(t1 ...) #'(t2 ...)) - (stx-andmap - (λ (t1 t2) - ((current-type=?) (substs #'(y ...) #'(x ...) t1) t2)) - #'(t1 ...) #'(t2 ...)))] - #;[(((~literal #%plain-app) tycon1 ((~literal #%plain-lambda) (x:id ...) k1 ... t1)) - ((~literal #%plain-app) tycon2 ((~literal #%plain-lambda) (y:id ...) k2 ... t2))) - #:when ((current-type=?) #'tycon1 #'tycon2) - #:when (types=? #'(k1 ...) #'(k2 ...)) - #:when (stx-length=? #'(x ...) #'(y ...)) - #:with (z ...) (generate-temporaries #'(x ...)) - ;; alternative #1: install wrappers that checks for x and y and return true - #;(define old-type=? (current-type=?)) - #;(define (new-type=? ty1 ty2) - (or (and (identifier? ty1) (identifier? ty2) - (stx-ormap (λ (x y) - (and (bound-identifier=? ty1 x) (bound-identifier=? ty2 y))) - #'(x ...) #'(y ...))) - (old-type=? ty1 ty2))) - #;(parameterize ([current-type=? new-type=?]) ((current-type=?) #'t1 #'t2)) - ;; alternative #2: subst fresh identifier for both x and y - #;((current-type=?) (substs #'(z ...) #'(x ...) #'t1) - (substs #'(z ...) #'(y ...) #'t2)) - ;; alternative #3: subst y for x in t1 - ((current-type=?) (substs #'(y ...) #'(x ...) #'t1) #'t2)] - [_ (stlc:type=? τ1 τ2)])) - (current-type=? type=?) - (current-typecheck-relation type=?)) - -(define-typed-syntax unfld - [(unfld τ:type-ann e) - #:with (~μ* (tv) τ_body) #'τ.norm - #:with [e- τ_e] (infer+erase #'e) - #:when (typecheck? #'τ_e #'τ.norm) - (⊢ e- : #,(subst #'τ.norm #'tv #'τ_body))]) -(define-typed-syntax fld - [(fld τ:type-ann e) - #:with (~μ* (tv) τ_body) #'τ.norm - #:with [e- τ_e] (infer+erase #'e) - #:when (typecheck? #'τ_e (subst #'τ.norm #'tv #'τ_body)) - (⊢ e- : τ.norm)]) diff --git a/tapl/stlc+reco+sub.rkt b/tapl/stlc+reco+sub.rkt @@ -1,48 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+sub.rkt" #:except #%app #%datum) -(extends "stlc+reco+var.rkt" #:except #%datum +) -;;use type=? and eval-type from stlc+reco+var.rkt, not stlc+sub.rkt -;; but extend sub? from stlc+sub.rkt - -;; Simply-Typed Lambda Calculus, plus subtyping, plus records -;; Types: -;; - types from stlc+sub.rkt -;; Type relations: -;; - sub? extended to records -;; Terms: -;; - terms from stlc+sub.rkt -;; - records and variants from stlc+reco+var - -(define-typed-syntax #%datum - [(#%datum . n:number) #'(stlc+sub:#%datum . n)] - [(#%datum . x) #'(stlc+reco+var:#%datum . x)]) - -(begin-for-syntax - (define old-sub? (current-sub?)) - (define (sub? τ1 τ2) -; (printf "t1 = ~a\n" (syntax->datum τ1)) -; (printf "t2 = ~a\n" (syntax->datum τ2)) - (or - (old-sub? τ1 τ2) - (syntax-parse (list τ1 τ2) - [((~× [k : τk] ...) (~× [l : τl] ...)) - #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) - (stx-map syntax-e (syntax->list #'(k ...)))) - (stx-andmap - (syntax-parser - [(label τlabel) - #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) - ((current-sub?) #'τk_match #'τlabel)]) - #'([l τl] ...))] - [((~∨ [k : τk] ...) (~∨ [l : τl] ...)) - #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) - (stx-map syntax-e (syntax->list #'(k ...)))) - (stx-andmap - (syntax-parser - [(label τlabel) - #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) - ((current-sub?) #'τk_match #'τlabel)]) - #'([l τl] ...))] - [_ #f]))) - (current-sub? sub?) - (current-typecheck-relation (current-sub?))) diff --git a/tapl/stlc+reco+var.rkt b/tapl/stlc+reco+var.rkt @@ -1,132 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+tup.rkt" #:except × ×? tup proj - #:rename [~× ~stlc:×]) -(provide × ∨ (for-syntax ~× ~×* ~∨ ~∨*)) - - -;; Simply-Typed Lambda Calculus, plus records and variants -;; Types: -;; - types from stlc+tup.rkt -;; - redefine tuple type × to records -;; - sum type constructor ∨ -;; Terms: -;; - terms from stlc+tup.rkt -;; - redefine tup to records -;; - sums (var) -;; TopLevel: -;; - define (values only) -;; - define-type-alias - -(provide define-type-alias) -(define-syntax define-type-alias - (syntax-parser - [(_ alias:id τ:type) - #'(define-syntax alias (make-variable-like-transformer #'τ.norm) #;(syntax-parser [x:id #'τ.norm]))] - [(_ (f:id x:id ...) ty) - #'(define-syntax (f stx) - (syntax-parse stx - [(_ x ...) #'ty]))])) - -(define-typed-syntax define - [(define x:id e) - #:with (e- τ) (infer+erase #'e) - #:with y (generate-temporary) - #'(begin- - (define-syntax x (make-rename-transformer (⊢ y : τ))) - (define- y e-))]) - -; re-define tuples as records -; dont use define-type-constructor because I want the : literal syntax -(define-syntax × - (syntax-parser #:datum-literals (:) - [(_ [label:id : τ:type] ...) - #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) - #`(stlc+tup:× valid-τ ...)])) -(begin-for-syntax - (define-syntax ~× - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~stlc:× ((~literal #%plain-app) (quote l) τ_l) ddd)] - [(_ . args) - #'(~and (~stlc:× ((~literal #%plain-app) (quote l) τ_l) (... ...)) - (~parse args #'((l τ_l) (... ...))))]))) - (define ×? stlc+tup:×?) - (define-syntax ~×* - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~or (~× [l : τ_l] ddd) - (~and any (~do (type-error - #:src #'any - #:msg "Expected × type, got: ~a" #'any))))])))) - -;; records -(define-typed-syntax tup #:datum-literals (=) - [(tup [l:id = e] ...) - #:with ([e- τ] ...) (infers+erase #'(e ...)) - (⊢ (list- (list- 'l e-) ...) : (× [l : τ] ...))]) -(define-typed-syntax proj #:literals (quote) - [(proj e_rec l:id) - #:with (e_rec- ([l_τ τ] ...)) (⇑ e_rec as ×) - #:with (_ τ_match) (stx-assoc #'l #'([l_τ τ] ...)) - (⊢ (cadr- (assoc- 'l e_rec-)) : τ_match)]) - -(define-type-constructor ∨/internal #:arity >= 0) - -;; variants -(define-syntax ∨ - (syntax-parser #:datum-literals (:) - [(_ (~and [label:id : τ:type] x) ...) - #:when (> (stx-length #'(x ...)) 0) - #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) - #'(∨/internal valid-τ ...)] - [any - (type-error #:src #'any - #:msg (string-append - "Improper usage of type constructor ∨: ~a, " - "expected (∨ [label:id : τ:type] ...+)") - #'any)])) -(begin-for-syntax - (define ∨? ∨/internal?) - (define-syntax ~∨ - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~∨/internal ((~literal #%plain-app) (quote l) τ_l) ddd)] - [(_ . args) - #'(~and (~∨/internal ((~literal #%plain-app) (quote l) τ_l) (... ...)) - (~parse args #'((l τ_l) (... ...))))]))) - (define-syntax ~∨* - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~and (~or (~∨ [l : τ_l] ddd) - (~and any (~do (type-error - #:src #'any - #:msg "Expected ∨ type, got: ~a" #'any)))) - ~!)])))) ; dont backtrack here - -(define-typed-syntax var #:datum-literals (as =) - [(var l:id = e as τ:type) - #:with (~∨* [l_τ : τ_l] ...) #'τ.norm - #:with match_res (stx-assoc #'l #'((l_τ τ_l) ...)) - #:fail-unless (syntax-e #'match_res) - (format "~a field does not exist" (syntax->datum #'l)) - #:with (_ τ_match) #'match_res - #:with (e- τ_e) (infer+erase #'e) - #:when (typecheck? #'τ_e #'τ_match) - (⊢ (list- 'l e) : τ)]) -(define-typed-syntax case - #:datum-literals (of =>) - [(case e [l:id x:id => e_l] ...) - #:fail-when (null? (syntax->list #'(l ...))) "no clauses" - #:with (e- ([l_x τ_x] ...)) (⇑ e as ∨) - #:fail-unless (= (stx-length #'(l ...)) (stx-length #'(l_x ...))) "wrong number of case clauses" - #:fail-unless (typechecks? #'(l ...) #'(l_x ...)) "case clauses not exhaustive" - #:with (((x-) e_l- τ_el) ...) - (stx-map (λ (bs e) (infer/ctx+erase bs e)) #'(([x : τ_x]) ...) #'(e_l ...)) - #:fail-unless (same-types? #'(τ_el ...)) "branches have different types" - (⊢ (let- ([l_e (car- e-)]) - (cond- [(symbol=?- l_e 'l) (let- ([x- (cadr- e-)]) e_l-)] ...)) - : #,(stx-car #'(τ_el ...)))]) diff --git a/tapl/stlc+sub.rkt b/tapl/stlc+sub.rkt @@ -1,97 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+lit.rkt" #:except #%datum +) -(reuse Bool String add1 #:from "ext-stlc.rkt") -(require (prefix-in ext: (only-in "ext-stlc.rkt" #%datum)) - (only-in "ext-stlc.rkt" current-join)) -(provide (for-syntax subs? current-sub?)) - -;; Simply-Typed Lambda Calculus, plus subtyping -;; Types: -;; - types from and stlc+lit.rkt -;; - Top, Num, Nat -;; Type relations: -;; - sub? -;; - Any <: Top -;; - Nat <: Int -;; - Int <: Num -;; - → -;; Terms: -;; - terms from stlc+lit.rkt, except redefined: datum and + -;; - also * -;; Other: sub? current-sub? - -(define-base-types Top Num Nat) - -(define-primop + : (→ Num Num Num)) -(define-primop * : (→ Num Num Num)) - -(define-typed-syntax #%datum - [(#%datum . n:nat) (⊢ (#%datum- . n) : Nat)] - [(#%datum . n:integer) (⊢ (#%datum- . n) : Int)] - [(#%datum . n:number) (⊢ (#%datum- . n) : Num)] - [(#%datum . x) #'(ext:#%datum . x)]) - -(begin-for-syntax - (define (sub? t1 t2) - ; need this because recursive calls made with unexpanded types - (define τ1 ((current-type-eval) t1)) - (define τ2 ((current-type-eval) t2)) -; (printf "t1 = ~a\n" (syntax->datum τ1)) -; (printf "t2 = ~a\n" (syntax->datum τ2)) - (or ((current-type=?) τ1 τ2) - (Top? τ2))) - (define current-sub? (make-parameter sub?)) - (current-typecheck-relation sub?) - (define (subs? τs1 τs2) - (and (stx-length=? τs1 τs2) - (stx-andmap (current-sub?) τs1 τs2))) - - (define-syntax (define-sub-relation stx) - (syntax-parse stx #:datum-literals (<: =>) - [(_ τ1:id <: τ2:id) - #:with τ1-expander (format-id #'τ1 "~~~a" #'τ1) - #:with τ2-expander (format-id #'τ2 "~~~a" #'τ2) - #:with fn (generate-temporary) - #:with old-sub? (generate-temporary) - #'(begin - (define old-sub? (current-sub?)) - (define (fn t1 t2) - (define τ1 ((current-type-eval) t1)) - (define τ2 ((current-type-eval) t2)) - (syntax-parse (list τ1 τ2) - [(τ1-expander τ) ((current-sub?) #'τ2 #'τ)] - [(τ τ2-expander) ((current-sub?) #'τ #'τ1)] - [_ #f])) - (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) - (current-typecheck-relation (current-sub?)))] - [(_ (~seq τ1:id <: τ2:id (~and (~literal ...) ddd)) - (~seq τ3:id <: τ4:id) - => - (tycon1 . rst1) <: (tycon2 . rst2)) - #:with tycon1-expander (format-id #'tycon1 "~~~a" #'tycon1) - #:with tycon2-expander (format-id #'tycon2 "~~~a" #'tycon2) - #:with fn (generate-temporary) - #:with old-sub? (generate-temporary) - #'(begin - (define old-sub? (current-sub?)) - (define (fn t1 t2) - (define τ1 ((current-type-eval) t1)) - (define τ2 ((current-type-eval) t2)) - (syntax-parse (list τ1 τ2) - [((tycon1-expander . rst1) (tycon2-expander . rst2)) - (and (subs? #'(τ1 ddd) #'(τ2 ddd)) - ((current-sub?) #'τ3 #'τ4))] - [_ #f])) - (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) - (current-typecheck-relation (current-sub?)))])) - - (define-sub-relation Nat <: Int) - (define-sub-relation Int <: Num) - (define-sub-relation t1 <: s1 ... s2 <: t2 => (→ s1 ... s2) <: (→ t1 ... t2)) - - (define (join t1 t2) - (cond - [((current-sub?) t1 t2) t2] - [((current-sub?) t2 t1) t1] - [else #'Top])) - (current-join join)) diff --git a/tapl/stlc+tup.rkt b/tapl/stlc+tup.rkt @@ -1,33 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "ext-stlc.rkt") - -(require (for-syntax racket/list)) - -;; Simply-Typed Lambda Calculus, plus tuples -;; Types: -;; - types from ext-stlc.rkt -;; - × -;; Terms: -;; - terms from ext-stlc.rkt -;; - tup and proj - -(define-type-constructor × #:arity >= 0 - #:arg-variances (λ (stx) - (make-list (stx-length (stx-cdr stx)) covariant))) - -(define-typed-syntax tup - [(tup e ...) - #:with ty-expected (get-expected-type stx) - #:with (e_ann ...) (if (syntax-e #'ty-expected) - (syntax-parse (local-expand #'ty-expected 'expression null) - [(~× ty_exp ...) #'((add-expected e ty_exp) ...)] - [_ #'(e ...)]) - #'(e ...)) - #:with ([e- τ] ...) (infers+erase #'(e_ann ...)) - (⊢ (list- e- ...) : (× τ ...))]) -(define-typed-syntax proj - [(proj e_tup n:nat) - #:with [e_tup- τs_tup] (⇑ e_tup as ×) - #:fail-unless (< (syntax-e #'n) (stx-length #'τs_tup)) "index too large" - (⊢ (list-ref- e_tup- n) : #,(stx-list-ref #'τs_tup (syntax-e #'n)))]) - diff --git a/tapl/stlc.rkt b/tapl/stlc.rkt @@ -1,130 +0,0 @@ -#lang s-exp "typecheck.rkt" -(provide (for-syntax current-type=? types=?)) -(provide (for-syntax mk-app-err-msg)) - -(require (for-syntax racket/list)) - -;; Simply-Typed Lambda Calculus -;; - no base types; can't write any terms -;; Types: multi-arg → (1+) -;; Terms: -;; - var -;; - multi-arg λ (0+) -;; - multi-arg #%app (0+) -;; Other: -;; - "type" syntax category; defines: -;; - define-base-type -;; - define-type-constructor -;; Typechecking forms: -;; - current-type-eval -;; - current-type=? - -(begin-for-syntax - ;; type eval - ;; - type-eval == full expansion == canonical type representation - ;; - must expand because: - ;; - checks for unbound identifiers (ie, undefined types) - ;; - checks for valid types, ow can't distinguish types and terms - ;; - could parse types but separate parser leads to duplicate code - ;; - later, expanding enables reuse of same mechanisms for kind checking - ;; and type application - (define (type-eval τ) - ; TODO: optimization: don't expand if expanded - ; currently, this causes problems when - ; combining unexpanded and expanded types to create new types - (add-orig (expand/df τ) τ)) - - (current-type-eval type-eval) - - ;; type=? : Type Type -> Boolean - ;; Two types are equivalent when structurally free-identifier=? - ;; - assumes canonical (ie expanded) representation - ;; (new: without syntax-parse) - ;; 2015-10-04: moved to define-syntax-category - #;(define (type=? t1 t2) - ;(printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum t1)) - ;(printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum t2)) - (or (and (identifier? t1) (identifier? t2) (free-identifier=? t1 t2)) - (and (stx-null? t1) (stx-null? t2)) - (and (stx-pair? t1) (stx-pair? t2) - (with-syntax ([(ta ...) t1][(tb ...) t2]) - #;(types=? #'(ta ...) #'(tb ...)) (types=? t1 t2))))) - ;; (old: uses syntax-parse) - #;(define (type=? τ1 τ2) -; (printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum τ1)) -; (printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum τ2)) - (syntax-parse (list τ1 τ2) - [(x:id y:id) (free-identifier=? τ1 τ2)] - [((τa ...) (τb ...)) (types=? #'(τa ...) #'(τb ...))] - [_ #f])) - - #;(define current-type=? (make-parameter type=?)) - #;(current-typecheck-relation type=?) - - ;; convenience fns for current-type=? - #;(define (types=? τs1 τs2) - (and (stx-length=? τs1 τs2) - (stx-andmap (current-type=?) τs1 τs2)))) - -(define-syntax-category type) - -(define-type-constructor → #:arity >= 1 - #:arg-variances (λ (stx) - (syntax-parse stx - [(_ τ_in ... τ_out) - (append - (make-list (stx-length #'[τ_in ...]) contravariant) - (list covariant))]))) - -(define-typed-syntax λ - [(λ bvs:type-ctx e) - #:with (xs- e- τ_res) (infer/ctx+erase #'bvs #'e) - (⊢ (λ- xs- e-) : (→ bvs.type ... τ_res))]) - -(define-for-syntax (mk-app-err-msg stx #:expected [expected-τs #'()] - #:given [given-τs #'()] - #:note [note ""] - #:name [name #f]) - (syntax-parse stx - #;[(app . rst) - #:when (not (equal? '#%app (syntax->datum #'app))) - (mk-app-err-msg (syntax/loc stx (#%app app . rst)) - #:expected expected-τs - #:given given-τs - #:note note - #:name name)] - [(app e_fn e_arg ...) - (define fn-name - (if name name - (format "function ~a" - (syntax->datum (or (get-orig #'e_fn) #'e_fn))))) - (string-append - (format "~a (~a:~a):\nType error applying " - (syntax-source stx) (syntax-line stx) (syntax-column stx)) - fn-name ". " note "\n" - (format " Expected: ~a argument(s) with type(s): " (stx-length expected-τs)) - (string-join (stx-map type->str expected-τs) ", " #:after-last "\n") - " Given:\n" - (string-join - (map (λ (e t) (format " ~a : ~a" e t)) ; indent each line - (syntax->datum #'(e_arg ...)) - (if (stx-length=? #'(e_arg ...) given-τs) - (stx-map type->str given-τs) - (stx-map (lambda (e) "?") #'(e_arg ...)))) - "\n") - "\n")])) - -(define-typed-syntax #%app #:literals (#%app) - [(#%app e_fn e_arg ...) - #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn as →) - #:with ([e_arg- τ_arg] ...) (infers+erase #'(e_arg ...)) - #:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...)) - (type-error #:src stx - #:msg (mk-app-err-msg stx #:expected #'(τ_in ...) - #:given #'(τ_arg ...) - #:note "Wrong number of arguments.")) - #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...)) - (type-error #:src stx - #:msg (mk-app-err-msg stx #:expected #'(τ_in ...) - #:given #'(τ_arg ...))) - (⊢ (#%app- e_fn- e_arg- ...) : τ_out)]) diff --git a/tapl/sysf.rkt b/tapl/sysf.rkt @@ -1,29 +0,0 @@ -#lang s-exp "typecheck.rkt" -(extends "stlc+lit.rkt") -(reuse #:from "stlc+rec-iso.rkt") ; want this type=? - -;; System F -;; Type relation: -;; - extend type=? with ∀ -;; Types: -;; - types from stlc+lit.rkt -;; - ∀ -;; Terms: -;; - terms from stlc+lit.rkt -;; - Λ and inst - -(define-type-constructor ∀ #:bvs >= 0) - -(define-typed-syntax Λ - [(Λ (tv:id ...) e) - #:with ((tv- ...) e- τ) (infer/tyctx+erase #'([tv : #%type] ...) #'e) - (⊢ e- : (∀ (tv- ...) τ))]) -(define-typed-syntax inst - [(inst e τ:type ...) - #:with (e- (tvs (τ_body))) (⇑ e as ∀) - ;#:with [e- (~and t (~∀ tvs τ_body))] (infer+erase #'e) - ;#:with (_ Xs τ_orig) (get-orig #'t) ; doesnt work with implicit lifted→ - ;#:with new-orig (substs #'(τ ...) #'Xs #'τ_orig) - ;(⊢ e- : #,(add-orig (substs #'(τ.norm ...) #'tvs #'τ_body) #'new-orig))] - (⊢ e- : #,(substs #'(τ.norm ...) #'tvs #'τ_body))] - [(_ e) #'e]) diff --git a/tapl/tests/exist-tests.rkt b/tapl/tests/exist-tests.rkt @@ -1,370 +0,0 @@ -#lang s-exp "../typed-lang-builder/exist.rkt" -(require "rackunit-typechecking.rkt") - -(check-type (pack (Int 0) as (∃ (X) X)) : (∃ (X) X)) -(check-type (pack (Int 0) as (∃ (X) X)) : (∃ (Y) Y)) -(typecheck-fail (pack (Int 0) as (∃ (X) Y))) -(check-type (pack (Bool #t) as (∃ (X) X)) : (∃ (X) X)) -(typecheck-fail (pack (Int #t) as (∃ (X) X))) - -(check-type (pack (Int (pack (Int 0) as (∃ (X) X))) as (∃ (Y) (∃ (X) X))) - : (∃ (Y) (∃ (X) X))) -(check-type (pack (Int +) as (∃ (X) (→ X Int Int))) : (∃ (X) (→ X Int Int))) -(check-type (pack (Int (pack (Int +) as (∃ (X) (→ X Int Int)))) - as (∃ (Y) (∃ (X) (→ X Y Int)))) - : (∃ (Y) (∃ (X) (→ X Y Int)))) -(check-not-type (pack (Int (pack (Int +) as (∃ (X) (→ X Int Int)))) - as (∃ (Y) (∃ (X) (→ X Y Int)))) - : (∃ (X) (∃ (X) (→ X X Int)))) - -; cant typecheck bc X has local scope, and no X elimination form -;(check-type (open [x <= (pack (Int 0) as (∃ (X) X)) with X] x) : X) - -(check-type 0 : Int) -(check-type (+ 0 1) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (+ x 1)) 0) : Int ⇒ 1) -(typecheck-fail (open [x <= (pack (Int 0) as (∃ (X) X)) with] (+ x 1))) ; can't use as Int - -(check-type (λ ([x : (∃ (X) X)]) x) : (→ (∃ (X) X) (∃ (Y) Y))) -(check-type ((λ ([x : (∃ (X) X)]) x) (pack (Int 0) as (∃ (Z) Z))) - : (∃ (X) X) ⇒ 0) -(check-type ((λ ([x : (∃ (X) X)]) x) (pack (Bool #t) as (∃ (Z) Z))) - : (∃ (X) X) ⇒ #t) - -;; example where the two binding X's are conflated, see exist.rkt for explanation -(check-type (open [x <= (pack (Int 0) as (∃ (X) X)) with X] ((λ ([y : X]) 1) x)) - : Int ⇒ 1) - -(check-type - (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) - as (∃ (X) (× [a : X] [f : (→ X X)]))) - : (∃ (X) (× [a : X] [f : (→ X X)]))) - -(define p4 - (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) - as (∃ (X) (× [a : X] [f : (→ X Int)])))) -(check-type p4 : (∃ (X) (× [a : X] [f : (→ X Int)]))) - -(check-not-type (open [x <= p4 with X] (proj x a)) : Int) ; type is X, not Int -; type is (→ X X), not (→ Int Int) -(check-not-type (open [x <= p4 with X] (proj x f)) : (→ Int Int)) -(typecheck-fail (open [x <= p4 with X] (+ 1 (proj x a)))) -(check-type (open [x <= p4 with X] ((proj x f) (proj x a))) : Int ⇒ 6) -(check-type (open [x <= p4 with X] ((λ ([y : X]) ((proj x f) y)) (proj x a))) : Int ⇒ 6) - -(check-type - (open [x <= (pack (Int 0) as (∃ (Y) Y)) with X] - ((λ ([y : X]) 1) x)) - : Int ⇒ 1) - -(check-type - (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) - as (∃ (X) (× [a : Int] [f : (→ Int Int)]))) - : (∃ (X) (× [a : Int] [f : (→ Int Int)]))) - -(typecheck-fail - (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) - as (∃ (X) (× [a : Int] [f : (→ Bool Int)])))) - -(typecheck-fail - (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) - as (∃ (X) (× [a : X] [f : (→ X Bool)])))) - -(check-type - (pack (Bool (tup [a = #t] [f = (λ ([x : Bool]) (if x 1 2))])) - as (∃ (X) (× [a : X] [f : (→ X Int)]))) - : (∃ (X) (× [a : X] [f : (→ X Int)]))) - -(define counterADT - (pack (Int (tup [new = 1] - [get = (λ ([i : Int]) i)] - [inc = (λ ([i : Int]) (+ i 1))])) - as (∃ (Counter) (× [new : Counter] - [get : (→ Counter Int)] - [inc : (→ Counter Counter)])))) -(check-type counterADT : - (∃ (Counter) (× [new : Counter] - [get : (→ Counter Int)] - [inc : (→ Counter Counter)]))) -(typecheck-fail - (open [counter <= counterADT with Counter] - (+ (proj counter new) 1)) - #:with-msg "expected Int, given Counter\n *expression: \\(proj counter new\\)") -(typecheck-fail - (open [counter <= counterADT with Counter] - ((λ ([x : Int]) x) (proj counter new))) - #:with-msg "expected Int, given Counter\n *expression: \\(proj counter new\\)") -(check-type - (open [counter <= counterADT with Counter] - ((proj counter get) ((proj counter inc) (proj counter new)))) - : Int ⇒ 2) - - (check-type - (open [counter <= counterADT with Counter] - (let ([inc (proj counter inc)] - [get (proj counter get)]) - (let ([add3 (λ ([c : Counter]) (inc (inc (inc c))))]) - (get (add3 (proj counter new)))))) - : Int ⇒ 4) - -(check-type - (open [counter <= counterADT with Counter] - (let ([get (proj counter get)] - [inc (proj counter inc)] - [new (λ () (proj counter new))]) - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (open [flipflop <= - (pack (Counter (tup [new = (new)] - [read = (λ ([c : Counter]) (is-even? (get c)))] - [toggle = (λ ([c : Counter]) (inc c))] - [reset = (λ ([c : Counter]) (new))])) - as (∃ (FlipFlop) (× [new : FlipFlop] - [read : (→ FlipFlop Bool)] - [toggle : (→ FlipFlop FlipFlop)] - [reset : (→ FlipFlop FlipFlop)]))) - with FlipFlop] - (let ([read (proj flipflop read)] - [togg (proj flipflop toggle)]) - (read (togg (togg (togg (togg (proj flipflop new))))))))))) - : Bool ⇒ #f) - -(define counterADT2 - (pack ((× [x : Int]) - (tup [new = (tup [x = 1])] - [get = (λ ([i : (× [x : Int])]) (proj i x))] - [inc = (λ ([i : (× [x : Int])]) (tup [x = (+ 1 (proj i x))]))])) - as (∃ (Counter) (× [new : Counter] - [get : (→ Counter Int)] - [inc : (→ Counter Counter)])))) -(check-type counterADT2 : - (∃ (Counter) (× [new : Counter] - [get : (→ Counter Int)] - [inc : (→ Counter Counter)]))) - -;; same as above, but with different internal counter representation -(check-type - (open [counter <= counterADT2 with Counter] - (let ([get (proj counter get)] - [inc (proj counter inc)] - [new (λ () (proj counter new))]) - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (open [flipflop <= - (pack (Counter (tup [new = (new)] - [read = (λ ([c : Counter]) (is-even? (get c)))] - [toggle = (λ ([c : Counter]) (inc c))] - [reset = (λ ([c : Counter]) (new))])) - as (∃ (FlipFlop) (× [new : FlipFlop] - [read : (→ FlipFlop Bool)] - [toggle : (→ FlipFlop FlipFlop)] - [reset : (→ FlipFlop FlipFlop)]))) - with - FlipFlop] - (let ([read (proj flipflop read)] - [togg (proj flipflop toggle)]) - (read (togg (togg (togg (togg (proj flipflop new))))))))))) - : Bool ⇒ #f) - -;; err cases -(typecheck-fail - (pack (Int 1) as Int) - #:with-msg - "Expected ∃ type, got: Int") -(typecheck-fail - (open [x <= 2 with X] 3) - #:with-msg - "Expected ∃ type, got: Int") - -;; previous tets from stlc+reco+var-tests.rkt --------------------------------- -;; define-type-alias -(define-type-alias Integer Int) -(define-type-alias ArithBinOp (→ Int Int Int)) -;(define-type-alias C Complex) ; error, Complex undefined - -(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) -(check-type + : ArithBinOp) -(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) - -;; records (ie labeled tuples) -(check-type "Stephen" : String) -(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [male? : Bool])) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) - : Int ⇒ 781) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) - : Bool ⇒ #t) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [my-name : String] [phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [my-phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [is-male? : Bool])) - -;; variants -(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) -(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) - (var coffee = (void) as (∨ [coffee : Unit])))) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1])) ; not enough clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [teaaaaaa x => 2])) ; wrong clause -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [tea x => 2] - [coke x => 3])) ; too many clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => "1"] - [tea x => 2])) ; mismatched branch types -(check-type - (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) - [coffee x => x] - [tea x => 2]) : Int ⇒ 1) -(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) -(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) -(check-type - (case ((λ ([d : Drink]) d) - (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -(check-type - (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -;; previous tests: ------------------------------------------------------------ -;; tests for tuples ----------------------------------------------------------- -;; old tuple syntax not supported here -;(check-type (tup 1 2 3) : (× Int Int Int)) -;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) -; -;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) -;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") -;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) -;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large -;(typecheck-fail (proj 1 2)) ; not tuple - -;; ext-stlc.rkt tests --------------------------------------------------------- -;; should still pass - -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) -(typecheck-fail ((λ ([x : Unit]) x) 2)) -(typecheck-fail ((λ ([x : Unit])) void)) -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(typecheck-fail (begin)) -(check-type (begin 1) : Int) -;(typecheck-fail (begin 1 2 3)) -(check-type (begin (void) 1) : Int ⇒ 1) - -;;ascription -(typecheck-fail (ann 1 : Bool)) -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(typecheck-fail (let ([x #f]) (+ x 1))) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) - -; letrec -(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) -(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/ext-stlc-tests.rkt b/tapl/tests/ext-stlc-tests.rkt @@ -1,170 +0,0 @@ -#lang s-exp "../typed-lang-builder/ext-stlc.rkt" -(require "rackunit-typechecking.rkt") - -;; tests for stlc extensions -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) - -(typecheck-fail - ((λ ([x : Unit]) x) 2) - #:with-msg "expected Unit, given Int\n *expression: 2") -(typecheck-fail - ((λ ([x : Unit]) x) void) - #:with-msg "expected Unit, given \\(→ Unit\\)\n *expression: void") - -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(check-type (begin 1) : Int) - -(typecheck-fail (begin) #:with-msg "expected more terms") -;; 2016-03-06: begin terms dont need to be Unit -(check-type (begin 1 2 3) : Int) -#;(typecheck-fail - (begin 1 2 3) - #:with-msg "Expected expression 1 to have Unit type, got: Int") - -(check-type (begin (void) 1) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (begin (void) x)) 1) : Int) -(check-type ((λ ([x : Int]) (begin x)) 1) : Int) -(check-type ((λ ([x : Int]) (begin (begin x))) 1) : Int) -(check-type ((λ ([x : Int]) (begin (void) (begin (void) x))) 1) : Int) -(check-type ((λ ([x : Int]) (begin (begin (void) x))) 1) : Int) - -;;ascription -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) -(typecheck-fail (ann 1 : Bool) - #:with-msg "ann: type mismatch: expected Bool, given Int\n *expression: 1") -;ann errs -(typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier") -(typecheck-fail (ann 1 : 1) #:with-msg "not a valid type") -(typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a valid type") -(typecheck-fail (ann Int : Int) - #:with-msg "ann: type mismatch: expected Int, given #%type\n *expression: Int") - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail - (let ([x #f]) (+ x 1)) - #:with-msg "expected Int, given Bool\n *expression: x") -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y)) - #:with-msg "x: unbound identifier") - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail - (let* ([x #t] [y (+ x 1)]) 1) - #:with-msg "expected Int, given Bool\n *expression: x") - -; letrec -(typecheck-fail - (letrec ([(x : Int) #f] [(y : Int) 1]) y) - #:with-msg - "letrec: type mismatch: expected Int, given Bool\n *expression: #f") -(typecheck-fail - (letrec ([(y : Int) 1] [(x : Int) #f]) x) - #:with-msg - "letrec: type mismatch: expected Int, given Bool\n *expression: #f") -(typecheck-fail - (ann (letrec ([(x : Int) #f] [(y : Int) 1]) y) : Int) - #:with-msg - "letrec: type mismatch: expected Int, given Bool\n *expression: #f") -(typecheck-fail - (ann (letrec ([(y : Int) 1] [(x : Int) #f]) x) : Int) - #:with-msg - "letrec: type mismatch: expected Int, given Bool\n *expression: #f") - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; check some more err msgs -(typecheck-fail - (and "1" #f) - #:with-msg - "and: type mismatch: expected Bool, given String\n *expression: \"1\"") -(typecheck-fail - (and #t "2") - #:with-msg - "and: type mismatch: expected Bool, given String\n *expression: \"2\"") -(typecheck-fail - (or "1" #f) - #:with-msg - "or: type mismatch: expected Bool, given String\n *expression: \"1\"") -(typecheck-fail - (or #t "2") - #:with-msg - "or: type mismatch: expected Bool, given String\n *expression: \"2\"") -;; 2016-03-10: change if to work with non-false vals -(check-type (if "true" 1 2) : Int -> 1) -(typecheck-fail - (if #t 1 "2") - #:with-msg - "branches have incompatible types: Int and String") - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) - -(typecheck-fail - ((λ ([x : Bool]) x) 1) - #:with-msg "expected Bool, given Int\n *expression: 1") -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail - (λ ([f : Int]) (f 1 2)) - #:with-msg - "Expected → type, got: Int") - -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) - : Int ⇒ 3) - -(typecheck-fail - (+ 1 (λ ([x : Int]) x)) - #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: \\(λ \\(\\(x : Int\\)\\) x\\)") -(typecheck-fail - (λ ([x : (→ Int Int)]) (+ x x)) - #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: x") -(typecheck-fail - ((λ ([x : Int] [y : Int]) y) 1) - #:with-msg "wrong number of arguments: expected 2, given 1") - -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/fomega-tests.rkt b/tapl/tests/fomega-tests.rkt @@ -1,211 +0,0 @@ -#lang s-exp "../typed-lang-builder/fomega.rkt" -(require "rackunit-typechecking.rkt") - -(check-type Int : ★) -(check-type String : ★) -(typecheck-fail →) -(check-type (→ Int Int) : ★) -(typecheck-fail (→ →)) -(typecheck-fail (→ 1)) -(check-type 1 : Int) - -(typecheck-fail (tyλ ([x : ★]) 1) #:with-msg "not a valid type: 1") - -(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) -(check-not-type (Λ ([X : ★]) (λ ([x : X]) x)) : - (∀ ([X : (∀★ ★)]) (→ X X))) - -;(check-type (∀ ([t : ★]) (→ t t)) : ★) -(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★)) -(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★) - -(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) - -(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x))) - : (∀ ([X : ★]) (→ X X))) -(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x)))) - -(check-type (tyλ ([t : ★]) t) : (⇒ ★ ★)) -(check-type (tyλ ([t : ★] [s : ★]) t) : (⇒ ★ ★ ★)) -(check-type (tyλ ([t : ★]) (tyλ ([s : ★]) t)) : (⇒ ★ (⇒ ★ ★))) -(check-type (tyλ ([t : (⇒ ★ ★)]) t) : (⇒ (⇒ ★ ★) (⇒ ★ ★))) -(check-type (tyλ ([t : (⇒ ★ ★ ★)]) t) : (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★))) -(check-type (tyλ ([arg : ★] [res : ★]) (→ arg res)) : (⇒ ★ ★ ★)) - -(check-type (tyapp (tyλ ([t : ★]) t) Int) : ★) -(check-type (λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) : (→ Int Int)) -(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1) -(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2) -(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2) -(typecheck-fail ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) "a-string")) - -;; partial-apply → -(check-type (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int) - : (⇒ ★ ★)) -;; f's type must have kind ★ -(typecheck-fail (λ ([f : (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)]) f)) -(check-type (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) : - (∀ ([tyf : (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String)))) -(check-type (inst - (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) - (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) - : (→ (→ Int String) (→ Int String))) -(typecheck-fail - (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1) - #:with-msg "inst: type mismatch: expected ★, given Int\n *expression: 1") - -(typecheck-fail - (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1))) - #:with-msg "Expected → type, got: \\(tyapp tyf String\\)") -;; applied f too early -(typecheck-fail - (inst - (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1))) - (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) - #:with-msg "Expected → type, got: \\(tyapp tyf String\\)") -(check-type ((inst - (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) - (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) - (λ ([x : Int]) "int")) : (→ Int String)) -(check-type (((inst - (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) - (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) - (λ ([x : Int]) "int")) 1) : String ⇒ "int") - -;; tapl examples, p441 -(typecheck-fail - (define-type-alias tmp 1) - #:with-msg "not a valid type: 1") -(define-type-alias Id (tyλ ([X : ★]) X)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (tyapp Id String)) Int)) -(check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int (tyapp Id String)) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (tyapp Id Int) (tyapp Id String)) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (tyapp Id Int) String) Int)) -(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (tyapp Id (→ Int String)) Int)) -(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (→ Int String)) Int)) -(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (tyapp Id (→ Int String))) Int)) - -;; tapl examples, p451 -(define-type-alias Pair (tyλ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X)))) - -;(check-type Pair : (⇒ ★ ★ ★)) -(check-type Pair : (⇒ ★ ★ (∀★ ★))) - -(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X))) -; parametric pair constructor -(check-type - (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - : (∀ ([X : ★][Y : ★]) (→ X Y (tyapp Pair X Y)))) -; concrete Pair Int String constructor -(check-type - (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) - : (→ Int String (tyapp Pair Int String))) -;; Pair Int String value -(check-type - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1") - : (tyapp Pair Int String)) -;; fst: parametric -(check-type - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) X))) -;; fst: concrete Pair Int String accessor -(check-type - (inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - Int String) - : (→ (tyapp Pair Int String) Int)) -;; apply fst -(check-type - ((inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - Int String) - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1")) - : Int ⇒ 1) -;; snd -(check-type - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) Y))) -(check-type - (inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - Int String) - : (→ (tyapp Pair Int String) String)) -(check-type - ((inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - Int String) - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1")) - : String ⇒ "1") - -;; sysf tests wont work, unless augmented with kinds -(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) - -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv - -(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2))))) - -(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4))))) - -(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4))))) - -(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int)) -(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int) -; first inst should be discarded -(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) -; second inst is discarded -(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) - -;; polymorphic arguments -(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t))) -(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u)))) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u)))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) -(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u))) -(check-type - (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int)) -(check-type - ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10) - : Int ⇒ 10) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int))) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int)) -(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) - (Λ ([s : ★]) (λ ([y : s]) y))) - : Int ⇒ 10) - - -;; previous tests ------------------------------------------------------------- -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -;(typecheck-fail #f) ; unsupported literal -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type -(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/tapl/tests/fomega2-tests.rkt b/tapl/tests/fomega2-tests.rkt @@ -1,203 +0,0 @@ -#lang s-exp "../typed-lang-builder/fomega2.rkt" -(require "rackunit-typechecking.rkt") - -(check-type Int : ★) -(check-type String : ★) -(typecheck-fail →) -(check-type (→ Int Int) : ★) -(typecheck-fail (→ →)) -(typecheck-fail (→ 1)) -(check-type 1 : Int) - -;; this should error but it doesnt -#;(λ ([x : ★]) 1) - -;(check-type (∀ ([t : ★]) (→ t t)) : ★) -(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★)) -(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★) - -(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) - -(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x))) - : (∀ ([X : ★]) (→ X X))) -(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (→ ★ ★)]) (λ ([x : X]) x)))) - -(check-type (λ ([t : ★]) t) : (→ ★ ★)) -(check-type (λ ([t : ★] [s : ★]) t) : (→ ★ ★ ★)) -(check-type (λ ([t : ★]) (λ ([s : ★]) t)) : (→ ★ (→ ★ ★))) -(check-type (λ ([t : (→ ★ ★)]) t) : (→ (→ ★ ★) (→ ★ ★))) -(check-type (λ ([t : (→ ★ ★ ★)]) t) : (→ (→ ★ ★ ★) (→ ★ ★ ★))) -(check-type (λ ([arg : ★] [res : ★]) (→ arg res)) : (→ ★ ★ ★)) - -(check-type ((λ ([t : ★]) t) Int) : ★) -(check-type (λ ([x : ((λ ([t : ★]) t) Int)]) x) : (→ Int Int)) -(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1) -(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2) -(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2) -(typecheck-fail ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) "a-string")) - -;; partial-apply → -(check-type ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int) - : (→ ★ ★)) -; f's type must have kind ★ -(typecheck-fail (λ ([f : ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)]) f)) -(check-type (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) : - (∀ ([tyf : (→ ★ ★)]) (→ (tyf String) (tyf String)))) -(check-type (inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) - : (→ (→ Int String) (→ Int String))) -(typecheck-fail - (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)) - ;#:with-msg "not a valid type: 1") - -;; applied f too early -(typecheck-fail (inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1))) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))) -(check-type ((inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) - (λ ([x : Int]) "int")) : (→ Int String)) -(check-type (((inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) - (λ ([x : Int]) "int")) 1) : String ⇒ "int") - -;; tapl examples, p441 -(typecheck-fail - (define-type-alias tmp 1)) - ;#:with-msg "not a valid type: 1") -(define-type-alias Id (λ ([X : ★]) X)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (Id String)) Int)) -(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int (Id String)) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) (Id String)) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) String) Int)) -(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (Id (→ Int String)) Int)) -(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (→ Int String)) Int)) -(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (Id (→ Int String))) Int)) - -;; tapl examples, p451 -(define-type-alias Pair (λ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X)))) - -;(check-type Pair : (→ ★ ★ ★)) -(check-type Pair : (→ ★ ★ (∀★ ★))) - -(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X))) -; parametric pair constructor -(check-type - (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - : (∀ ([X : ★][Y : ★]) (→ X Y (Pair X Y)))) -; concrete Pair Int String constructor -(check-type - (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) - : (→ Int String (Pair Int String))) -; Pair Int String value -(check-type - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1") - : (Pair Int String)) -; fst: parametric -(check-type - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) X))) -; fst: concrete Pair Int String accessor -(check-type - (inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - Int String) - : (→ (Pair Int String) Int)) -; apply fst -(check-type - ((inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - Int String) - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1")) - : Int ⇒ 1) -; snd -(check-type - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) Y))) -(check-type - (inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - Int String) - : (→ (Pair Int String) String)) -(check-type - ((inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - Int String) - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1")) - : String ⇒ "1") - -;;; sysf tests wont work, unless augmented with kinds -(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) - -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv - -(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2))))) - -(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4))))) - -(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4))))) - -(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int)) -(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int) -; first inst should be discarded -(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) -; second inst is discarded -(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) - -;; polymorphic arguments -(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t))) -(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u)))) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u)))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) -(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u))) -(check-type - (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int)) -(check-type - ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10) - : Int ⇒ 10) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int))) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int)) -(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) - (Λ ([s : ★]) (λ ([y : s]) y))) - : Int ⇒ 10) - - -;; previous tests ------------------------------------------------------------- -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -;(typecheck-fail #f) ; unsupported literal -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type -(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/tapl/tests/fomega3-tests.rkt b/tapl/tests/fomega3-tests.rkt @@ -1,200 +0,0 @@ -#lang s-exp "../typed-lang-builder/fomega3.rkt" -(require "rackunit-typechecking.rkt") - -(check-type Int : ★) -(check-type String : ★) -(typecheck-fail →) -(check-type (→ Int Int) : ★) -(typecheck-fail (→ →)) -(typecheck-fail (→ 1)) -(check-type 1 : Int) - -;(check-type (∀ ([t : ★]) (→ t t)) : ★) -(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★)) -(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★) - -(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) - -(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x))) - : (∀ ([X : ★]) (→ X X))) -(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (→ ★ ★)]) (λ ([x : X]) x)))) - -(check-type (λ ([t : ★]) t) : (→ ★ ★)) -(check-type (λ ([t : ★] [s : ★]) t) : (→ ★ ★ ★)) -(check-type (λ ([t : ★]) (λ ([s : ★]) t)) : (→ ★ (→ ★ ★))) -(check-type (λ ([t : (→ ★ ★)]) t) : (→ (→ ★ ★) (→ ★ ★))) -(check-type (λ ([t : (→ ★ ★ ★)]) t) : (→ (→ ★ ★ ★) (→ ★ ★ ★))) -(check-type (λ ([arg : ★] [res : ★]) (→ arg res)) : (→ ★ ★ ★)) - -(check-type ((λ ([t : ★]) t) Int) : ★) -(check-type (λ ([x : ((λ ([t : ★]) t) Int)]) x) : (→ Int Int)) -(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1) -(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2) -(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2) -(typecheck-fail ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) "a-string")) - -;; partial-apply → -(check-type ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int) - : (→ ★ ★)) -; f's type must have kind ★ -(typecheck-fail (λ ([f : ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)]) f)) -(check-type (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) : - (∀ ([tyf : (→ ★ ★)]) (→ (tyf String) (tyf String)))) -(check-type (inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) - : (→ (→ Int String) (→ Int String))) -(typecheck-fail - (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)) - ;#:with-msg "not a valid type: 1") - -;; applied f too early -(typecheck-fail (inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1))) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))) -(check-type ((inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) - (λ ([x : Int]) "int")) : (→ Int String)) -(check-type (((inst - (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) - ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) - (λ ([x : Int]) "int")) 1) : String ⇒ "int") - -;; tapl examples, p441 -(typecheck-fail - (define-type-alias tmp 1)) - ;#:with-msg "not a valid type: 1") -(define-type-alias Id (λ ([X : ★]) X)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (Id String)) Int)) -(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int (Id String)) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) (Id String)) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) String) Int)) -(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (→ Int String) Int)) -(check-type (λ ([f : (→ Int String)]) 1) : (→ (Id (→ Int String)) Int)) -(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (→ Int String)) Int)) -(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (Id (→ Int String))) Int)) - -;; tapl examples, p451 -(define-type-alias Pair (λ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X)))) - -;(check-type Pair : (→ ★ ★ ★)) -(check-type Pair : (→ ★ ★ (∀★ ★))) - -(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X))) -; parametric pair constructor -(check-type - (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - : (∀ ([X : ★][Y : ★]) (→ X Y (Pair X Y)))) -; concrete Pair Int String constructor -(check-type - (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) - : (→ Int String (Pair Int String))) -; Pair Int String value -(check-type - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1") - : (Pair Int String)) -; fst: parametric -(check-type - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) X))) -; fst: concrete Pair Int String accessor -(check-type - (inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - Int String) - : (→ (Pair Int String) Int)) -; apply fst -(check-type - ((inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) - Int String) - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1")) - : Int ⇒ 1) -; snd -(check-type - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) Y))) -(check-type - (inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - Int String) - : (→ (Pair Int String) String)) -(check-type - ((inst - (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) - Int String) - ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) - Int String) 1 "1")) - : String ⇒ "1") - -;;; sysf tests wont work, unless augmented with kinds -(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) - -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false -(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv - -(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2))))) - -(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4))))) - -(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4))))) - -(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int)) -(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int) -; first inst should be discarded -(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) -; second inst is discarded -(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) - -;; polymorphic arguments -(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t))) -(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s)))) -(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u)))) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u)))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) -(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u))) -(check-type - (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int)) -(check-type - ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10) - : Int ⇒ 10) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int))) -(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int)) -(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) - (Λ ([s : ★]) (λ ([y : s]) y))) - : Int ⇒ 10) - - -;; previous tests ------------------------------------------------------------- -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -;(typecheck-fail #f) ; unsupported literal -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type -(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/tapl/tests/fsub-tests.rkt b/tapl/tests/fsub-tests.rkt @@ -1,153 +0,0 @@ -#lang s-exp "../typed-lang-builder/fsub.rkt" -(require "rackunit-typechecking.rkt") - -;; examples from tapl ch26, bounded quantification -;; (same tests from stlc+reco+sub.rkt, but last one should not typecheck) -(check-type (λ ([x : (× [a : Int])]) x) : (→ (× [a : Int]) (× [a : Int]))) - -(define ra (tup [a = 0])) -(check-type ((λ ([x : (× [a : Int])]) x) ra) - : (× [a : Int]) ⇒ (tup [a = 0])) -(define rab (tup [a = 0][b = #t])) -(check-type ((λ ([x : (× [a : Int])]) x) rab) - : (× [a : Int]) ⇒ (tup [a = 0][b = #t])) - -(check-type (proj ((λ ([x : (× [a : Int])]) x) rab) a) - : Int ⇒ 0) - -(check-type (Λ ([X <: Top]) (λ ([x : X]) x)) : (∀ ([X <: Top]) (→ X X))) -(check-type (inst (Λ ([X <: Top]) (λ ([x : X]) x)) (× [a : Int][b : Bool])) - : (→ (× [a : Int][b : Bool]) (× [a : Int][b : Bool]))) - -(check-type (proj ((inst (Λ ([X <: Top]) (λ ([x : X]) x)) - (× [a : Int][b : Bool])) - rab) b) - : Bool ⇒ #t) - -(define f2 (λ ([x : (× [a : Nat])]) (tup [orig = x] [asucc = (+ 1 (proj x a))]))) -(check-type f2 : (→ (× [a : Nat]) (× [orig : (× [a : Nat])] [asucc : Nat]))) -(check-type (f2 ra) : (× [orig : (× [a : Nat])][asucc : Nat])) -(check-type (f2 rab) : (× [orig : (× [a : Nat])][asucc : Nat])) - -; check expose properly called for primops -(define fNat (Λ ([X <: Nat]) (λ ([x : X]) (+ x 1)))) -(check-type fNat : (∀ ([X <: Nat]) (→ X Nat))) - -;; check type constructors properly call expose -(define f2poly - (Λ ([X <: (× [a : Nat])]) - (λ ([x : X]) - (tup [orig = x][asucc = (+ (proj x a) 1)])))) - -(check-type f2poly : (∀ ([X <: (× [a : Nat])]) (→ X (× [orig : X][asucc : Nat])))) - -; inst f2poly with (× [a : Nat]) -(check-type (inst f2poly (× [a : Nat])) - : (→ (× [a : Nat]) - (× [orig : (× [a : Nat])][asucc : Nat]))) -(check-type ((inst f2poly (× [a : Nat])) ra) - : (× [orig : (× [a : Nat])][asucc : Nat]) - ⇒ (tup [orig = ra][asucc = 1])) - -(check-type ((inst f2poly (× [a : Nat])) rab) - : (× [orig : (× [a : Nat])][asucc : Nat]) - ⇒ (tup [orig = rab][asucc = 1])) - -(typecheck-fail (proj (proj ((inst f2poly (× [a : Nat])) rab) orig) b)) - -;; inst f2poly with (× [a : Nat][b : Bool]) -(check-type (inst f2poly (× [a : Nat][b : Bool])) - : (→ (× [a : Nat][b : Bool]) - (× [orig : (× [a : Nat][b : Bool])][asucc : Nat]))) -(typecheck-fail ((inst f2poly (× [a : Nat][b : Bool])) ra)) - -(check-type ((inst f2poly (× [a : Nat][b : Bool])) rab) - : (× [orig : (× [a : Nat][b : Bool])][asucc : Nat]) - ⇒ (tup [orig = rab][asucc = 1])) - -(check-type (proj (proj ((inst f2poly (× [a : Nat][b : Bool])) rab) orig) b) - : Bool ⇒ #t) - -;; make sure inst still checks args -(typecheck-fail (inst (Λ ([X <: Nat]) 1) Int)) - -; ch28 -(define f (Λ ([X <: (→ Nat Nat)]) (λ ([y : X]) (y 5)))) -(check-type f : (∀ ([X <: (→ Nat Nat)]) (→ X Nat))) -(check-type (inst f (→ Nat Nat)) : (→ (→ Nat Nat) Nat)) -(check-type (inst f (→ Int Nat)) : (→ (→ Int Nat) Nat)) -(typecheck-fail (inst f (→ Nat Int))) -(check-type ((inst f (→ Int Nat)) (λ ([z : Int]) 5)) : Nat) -(check-type ((inst f (→ Int Nat)) (λ ([z : Num]) 5)) : Nat) -(typecheck-fail ((inst f (→ Int Nat)) (λ ([z : Nat]) 5))) - - -;; old sysf tests ------------------------------------------------------------- -;; old syntax no longer valid -;(check-type (Λ (X) (λ ([x : X]) x)) : (∀ (X) (→ X X))) -; -;(check-type (Λ (X) (λ ([t : X] [f : X]) t)) : (∀ (X) (→ X X X))) ; true -;(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (X) (→ X X X))) ; false -;(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (Y) (→ Y Y Y))) ; false, alpha equiv -; -;(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) -; : (∀ (t1) (∀ (t2) (→ t1 (→ t2 t2))))) -; -;(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) -; : (∀ (t3) (∀ (t4) (→ t3 (→ t4 t4))))) -; -;(check-not-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) -; : (∀ (t4) (∀ (t3) (→ t3 (→ t4 t4))))) -; -;(check-type (inst (Λ (t) (λ ([x : t]) x)) Int) : (→ Int Int)) -;(check-type (inst (Λ (t) 1) (→ Int Int)) : Int) -;; first inst should be discarded -;(check-type (inst (inst (Λ (t) (Λ (t) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) -;; second inst is discarded -;(check-type (inst (inst (Λ (t1) (Λ (t2) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) -; -;;;; polymorphic arguments -;(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (t) (→ t t))) -;(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (s) (→ s s))) -;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (s) (∀ (t) (→ t t)))) -;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (t) (→ t t)))) -;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (s) (→ s s)))) -;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (u) (→ u u)))) -;(check-type (λ ([x : (∀ (t) (→ t t))]) x) : (→ (∀ (s) (→ s s)) (∀ (u) (→ u u)))) -;(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) -;(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) -;(check-type ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) : (∀ (u) (→ u u))) -;(check-type -; (inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) : (→ Int Int)) -;(check-type -; ((inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) 10) -; : Int ⇒ 10) -;(check-type (λ ([x : (∀ (t) (→ t t))]) (inst x Int)) : (→ (∀ (t) (→ t t)) (→ Int Int))) -;(check-type (λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) : (→ (∀ (t) (→ t t)) Int)) -;(check-type ((λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) -; (Λ (s) (λ ([y : s]) y))) -; : Int ⇒ 10) - - -;;; previous tests ------------------------------------------------------------- -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -;; strings and boolean literals now ok -;(typecheck-fail "one") ; unsupported literal -;(typecheck-fail #f) ; unsupported literal -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -;; edited from sysf test to handle subtyping -(check-type ((λ ([f : (→ Nat Nat Nat)] [x : Nat] [y : Nat]) (f x y)) + 1 2) : Num ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Nat]) (+ x x)) 10) : Num ⇒ 20) diff --git a/tapl/tests/infer-tests.rkt b/tapl/tests/infer-tests.rkt @@ -1,364 +0,0 @@ -#lang s-exp "../infer.rkt" -(require "rackunit-typechecking.rkt") - -(typecheck-fail (λ (x) x) #:with-msg "could not infer type of x; add annotation\\(s\\)") - -; should bidirectional checking work for this case? -; I think no, since TR doesnt handle it either -;(typecheck-fail (λ (x) (+ x 1)) #:with-msg "add annotations") -; 2015-12-18: can infer this type now -(check-type (λ (x) (+ x 1)) : (→ Int Int)) -; can't check this case either -(typecheck-fail ((λ (f) (f 10)) (λ (x) x)) #:with-msg "add annotation\\(s\\)") - -; stlc+lit tests with app, but infer types (no annotations) -(check-type ((λ (x) x) 1) : Int ⇒ 1) -(check-type ((λ (f x y) (f x y)) + 1 2) : Int ⇒ 3) -(check-type ((λ (x) (+ x x)) 10) : Int ⇒ 20) - -(check-type ((λ (x) ((λ (y) y) x)) 10) : Int ⇒ 10) - -; top level functions -(define (f [x : Int] → Int) x) -(check-type f : (→ Int Int)) -(check-type (f 1) : Int ⇒ 1) -(typecheck-fail (f (λ ([x : Int]) x))) - -(define {X} (g [x : X] → X) x) -(check-type g : (→ {X} X X)) - -; (inferred) polymorpic instantiation -(check-type (g 1) : Int ⇒ 1) -(check-type (g #f) : Bool ⇒ #f) ; different instantiation -(check-type (g add1) : (→ Int Int)) -(check-type (g +) : (→ Int Int Int)) - -; function polymorphic in list element -(define {X} (g2 [lst : (List X)] → (List X)) lst) -(check-type g2 : (→ {X} (List X) (List X))) -(typecheck-fail (g2 1) #:with-msg "expected: \\(List X\\)\n *given: Int") ; TODO: more precise err msg -(check-type (g2 (nil {Int})) : (List Int) ⇒ (nil {Int})) -(check-type (g2 (nil {Bool})) : (List Bool) ⇒ (nil {Bool})) -(check-type (g2 (nil {(List Int)})) : (List (List Int)) ⇒ (nil {(List Int)})) -(check-type (g2 (nil {(→ Int Int)})) : (List (→ Int Int)) ⇒ (nil {(List (→ Int Int))})) -(check-type (g2 (cons 1 nil)) : (List Int) ⇒ (cons 1 nil)) -(check-type (g2 (cons "1" nil)) : (List String) ⇒ (cons "1" nil)) - -(define {X} (g3 [lst : (List X)] → X) (hd lst)) -(check-type g3 : (→ {X} (List X) X)) -(check-type g3 : (→ {A} (List A) A)) -(check-not-type g3 : (→ {A B} (List A) B)) -(typecheck-fail (g3) #:with-msg "Expected.+arguments with type.+List") ; TODO: more precise err msg -(check-type (g3 (nil {Int})) : Int) ; runtime fail -(check-type (g3 (nil {Bool})) : Bool) ; runtime fail -(check-type (g3 (cons 1 nil)) : Int ⇒ 1) -(check-type (g3 (cons "1" nil)) : String ⇒ "1") - -; recursive fn -(define (recf [x : Int] → Int) (recf x)) -(check-type recf : (→ Int Int)) - -(define (countdown [x : Int] → Int) - (if (zero? x) - 0 - (countdown (sub1 x)))) -(check-type (countdown 0) : Int ⇒ 0) -(check-type (countdown 10) : Int ⇒ 0) -(typecheck-fail (countdown "10") #:with-msg "expected: Int\n *given: String") - -; list abbrv -(check-type (list 1 2 3) : (List Int)) -(typecheck-fail (list 1 "3") - #:with-msg "cons expression.+with type Int to list.+with type \\(List String\\)") - - -(define {X Y} (map [f : (→ X Y)] [lst : (List X)] → (List Y)) - (if (nil? lst) - nil ; test expected-type propagation of if and define - ; recursive call should instantiate to "concrete" X and Y types - (cons (f (hd lst)) (map f (tl lst))))) - -(check-type map : (→ {X Y} (→ X Y) (List X) (List Y))) -(check-type map : (→ {Y X} (→ Y X) (List Y) (List X))) -(check-type map : (→ {A B} (→ A B) (List A) (List B))) -(check-not-type map : (→ {X Y} (→ X X) (List X) (List X))) -(check-not-type map : (→ {X} (→ X X) (List X) (List X))) - -; nil without annotation tests fn-first, left-to-right arg inference (2nd #%app case) -(check-type (map add1 nil) : (List Int) ⇒ (nil {Int})) -(check-type (map add1 (list)) : (List Int) ⇒ (nil {Int})) -(check-type (map add1 (list 1 2 3)) : (List Int) ⇒ (list 2 3 4)) -(typecheck-fail (map add1 (list "1")) #:with-msg - (string-append - "couldn't unify Int and String\n" - " *expected: \\(→ X Y\\), \\(List X\\)\n" - " *given: \\(→ Int Int\\), \\(List String\\)")) -(check-type (map (λ ([x : Int]) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) -; doesnt work yet -;; 2015-12-18: dont need annotations on lambdas with concrete type -(check-type (map (λ (x) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) - -(define {X} (filter [p? : (→ X Bool)] [lst : (List X)] → (List X)) - (if (nil? lst) - nil - (if (p? (hd lst)) - (cons (hd lst) (filter p? (tl lst))) - (filter p? (tl lst))))) -(define {X} (filter/let [p? : (→ X Bool)] [lst : (List X)] → (List X)) - (if (nil? lst) - nil - (let ([x (hd lst)] [filtered-rst (filter p? (tl lst))]) - (if (p? x) (cons x filtered-rst) filtered-rst)))) - -(check-type (filter zero? nil) : (List Int) ⇒ (nil {Int})) -(check-type (filter zero? (list 1 2 3)) : (List Int) ⇒ (nil {Int})) -(check-type (filter zero? (list 0 1 2)) : (List Int) ⇒ (list 0)) -(check-type (filter (λ ([x : Int]) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) -;; 2015-12-18: dont need annotations on lambdas with concrete type -(check-type (filter (λ (x) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) - -(define {X Y} (foldr [f : (→ X Y Y)] [base : Y] [lst : (List X)] → Y) - (if (nil? lst) - base - (f (hd lst) (foldr f base (tl lst))))) -(define {X Y} (foldl [f : (→ X Y Y)] [acc : Y] [lst : (List X)] → Y) - (if (nil? lst) - acc - (foldr f (f (hd lst) acc) (tl lst)))) - -(define {X} (all? [p? : (→ X Bool)] [lst : (List X)] → Bool) - (if (nil? lst) - #t - (and (p? (hd lst)) (all? p? (tl lst))))) - -(define {X} (tails [lst : (List X)] → (List (List X))) - (if (nil? lst) - (list nil) - (cons lst (tails (tl lst))))) - -; creates backwards list -(define {X} (build-list [n : Int] [f : (→ Int X)] → (List X)) - (if (zero? (sub1 n)) - (list (f 0)) - (cons (f (sub1 n)) (build-list (sub1 n) f)))) -(check-type (build-list 1 add1) : (List Int) ⇒ (list 1)) -(check-type (build-list 3 add1) : (List Int) ⇒ (list 3 2 1)) -(check-type (build-list 5 sub1) : (List Int) ⇒ (list 3 2 1 0 -1)) - -(define {X} (append [lst1 : (List X)] [lst2 : (List X)] → (List X)) - (if (nil? lst1) - lst2 - (cons (hd lst1) (append (tl lst1) lst2)))) - -; nqueens -(define-type-alias Queen (× Int Int)) -(define (q-x [q : Queen] → Int) (proj q 0)) -(define (q-y [q : Queen] → Int) (proj q 1)) -(define (Q [x : Int] [y : Int] → Queen) (tup x y)) - -(define (safe? [q1 : Queen] [q2 : Queen] → Bool) - (let ([x1 (q-x q1)][y1 (q-y q1)] - [x2 (q-x q2)][y2 (q-y q2)]) - (not (or (= x1 x2) (= y1 y2) (= (abs (- x1 x2)) (abs (- y1 y2))))))) -(define (safe/list? [qs : (List Queen)] → Bool) - (if (nil? qs) - #t - (let ([q1 (hd qs)]) - (all? (λ ([q2 : Queen]) (safe? q1 q2)) (tl qs))))) -(define (valid? [lst : (List Queen)] → Bool) - (all? safe/list? (tails lst))) - -(define (nqueens [n : Int] → (List Queen)) - (let* ([process-row - (λ ;([r : Int] [all-possible-so-far : (List (List Queen))]) - (r all-possible-so-far) - (foldr - ;; 2015-12-18: dont need annotations on lambdas with concrete type - (λ ;([qs : (List Queen)] [new-qss : (List (List Queen))]) - (qs new-qss) - (append - (map - ;; 2015-12-18: dont need annotations on lambdas with concrete type - (λ (c) (cons (Q r c) qs)) - (build-list n add1)) - new-qss)) - nil - all-possible-so-far))] - [all-possible (foldl process-row (list nil) (build-list n add1))]) - (let ([solns (filter valid? all-possible)]) - (if (nil? solns) - nil - (hd solns))))) - -(check-type nqueens : (→ Int (List Queen))) -(check-type (nqueens 1) : (List Queen) ⇒ (list (list 1 1))) -(check-type (nqueens 2) : (List Queen) ⇒ (nil {Queen})) -(check-type (nqueens 3) : (List Queen) ⇒ (nil {Queen})) -(check-type (nqueens 4) : (List Queen) ⇒ (list (Q 3 1) (Q 2 4) (Q 1 2) (Q 4 3))) -(check-type (nqueens 5) : (List Queen) ⇒ (list (Q 4 2) (Q 3 4) (Q 2 1) (Q 1 3) (Q 5 5))) - -; -------------------------------------------------- -; all ext-stlc tests should still pass (copied below): -;; tests for stlc extensions -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) - -(typecheck-fail - ((λ ([x : Unit]) x) 2) - #:with-msg - "expected: Unit\n *given: Int") -(typecheck-fail - ((λ ([x : Unit]) x) void) - #:with-msg - "expected: Unit\n *given: \\(→ Unit\\)") - -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(check-type (begin 1) : Int) - -(typecheck-fail (begin) #:with-msg "expected more terms") -;; 2016-03-06: begin terms dont need to be Unit -(check-type (begin 1 2 3) : Int) -#;(typecheck-fail - (begin 1 2 3) - #:with-msg "Expected expression 1 to have Unit type, got: Int") - -(check-type (begin (void) 1) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (begin (void) x)) 1) : Int) -(check-type ((λ ([x : Int]) (begin x)) 1) : Int) -(check-type ((λ ([x : Int]) (begin (begin x))) 1) : Int) -(check-type ((λ ([x : Int]) (begin (void) (begin (void) x))) 1) : Int) -(check-type ((λ ([x : Int]) (begin (begin (void) x))) 1) : Int) - -;;ascription -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) -(typecheck-fail (ann 1 : Bool) #:with-msg "ann: 1 does not have type Bool") -;ann errs -(typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier") -(typecheck-fail (ann 1 : 1) #:with-msg "not a valid type") -(typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a valid type") -(typecheck-fail (ann Int : Int) #:with-msg "does not have type Int") - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail - (let ([x #f]) (+ x 1)) - #:with-msg - "expected: Int, Int\n *given: Bool, Int") -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y)) - #:with-msg "x: unbound identifier") - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail - (let* ([x #t] [y (+ x 1)]) 1) - #:with-msg - "expected: Int, Int\n *given: Bool, Int") - -; letrec -(typecheck-fail - (letrec ([(x : Int) #f] [(y : Int) 1]) y) - #:with-msg - "letrec: type check fail, args have wrong type:\n#f has type Bool, expected Int") -(typecheck-fail - (letrec ([(y : Int) 1] [(x : Int) #f]) x) - #:with-msg - "letrec: type check fail, args have wrong type:.+#f has type Bool, expected Int") - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; check some more err msgs -(typecheck-fail - (and "1" #f) - #:with-msg "Expected expression \"1\" to have Bool type, got: String") -(typecheck-fail - (and #t "2") - #:with-msg - "Expected expression \"2\" to have Bool type, got: String") -(typecheck-fail - (or "1" #f) - #:with-msg - "Expected expression \"1\" to have Bool type, got: String") -(typecheck-fail - (or #t "2") - #:with-msg - "Expected expression \"2\" to have Bool type, got: String") -;; 2016-03-10: change if to work with non-false vals -(check-type (if "true" 1 2) : Int -> 1) -(typecheck-fail - (if #t 1 "2") - #:with-msg - "branches have incompatible types: Int and String") - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) - -(typecheck-fail - ((λ ([x : Bool]) x) 1) - #:with-msg - "expected: Bool\n *given: Int") -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail - (λ ([f : Int]) (f 1 2)) - #:with-msg - "Expected expression f to have ∀ type, got: Int") - -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) - : Int ⇒ 3) - -(typecheck-fail - (+ 1 (λ ([x : Int]) x)) - #:with-msg - "expected: Int, Int\n *given: Int, \\(→ Int Int\\)") -(typecheck-fail - (λ ([x : (→ Int Int)]) (+ x x)) - #:with-msg - "expected: Int, Int\n *given: \\(→ Int Int\\), \\(→ Int Int\\)") -(typecheck-fail - ((λ ([x : Int] [y : Int]) y) 1) - #:with-msg "Wrong number of arguments") - -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/mlish-tests.rkt b/tapl/tests/mlish-tests.rkt @@ -1,778 +0,0 @@ -#lang s-exp "../typed-lang-builder/mlish.rkt" -(require "rackunit-typechecking.rkt") - -;; match on tups -(check-type - (match (tup 1 2) with - [x y -> (+ x y)]) - : Int -> 3) - -;; tests more or less copied from infer-tests.rkt ------------------------------ -(typecheck-fail (λ (x) x) #:with-msg "λ: no expected type, add annotations") - -;; top-level defines -(define (f [x : Int] → Int) x) -(typecheck-fail (f 1 2) #:with-msg "f: wrong number of arguments: expected 1, given 2") -(check-type f : (→ Int Int)) -(check-type (f 1) : Int ⇒ 1) -(typecheck-fail (f (λ ([x : Int]) x))) - -(define (g [x : X] → X) x) -(check-type g : (→/test X X)) - -;; (inferred) polymorpic instantiation -(check-type (g 1) : Int ⇒ 1) -(check-type (g #f) : Bool ⇒ #f) ; different instantiation -(check-type (g add1) : (→ Int Int)) -(check-type (g +) : (→ Int Int Int)) - -;; function polymorphic in list element -(define-type (List X) - Nil - (Cons X (List X))) - -;; arity err -(typecheck-fail (Cons 1) #:with-msg "Cons: wrong number of arguments: expected 2, given 1") - -;; type err -(typecheck-fail (Cons 1 1) - #:with-msg "expected: \\(List Int\\)\n *given: Int") - -(typecheck-fail - (match (Cons 1 Nil) with - [Nil -> 1]) - #:with-msg "match: clauses not exhaustive; missing: Cons") -(typecheck-fail - (match (Cons 1 Nil) with - [Cons x xs -> 1]) - #:with-msg "match: clauses not exhaustive; missing: Nil") - -(define (g2 [lst : (List Y)] → (List Y)) lst) -(check-type g2 : (→/test (List Y) (List Y))) -(typecheck-fail (g2 1) - #:with-msg - "expected: \\(List Y\\)\n *given: Int") - -;; todo? allow polymorphic nil? -(check-type (g2 (Nil {Int})) : (List Int) ⇒ (Nil {Int})) -(check-type (g2 (Nil {Bool})) : (List Bool) ⇒ (Nil {Bool})) -(check-type (g2 (Nil {(List Int)})) : (List (List Int)) ⇒ (Nil {(List Int)})) -(check-type (g2 (Nil {(→ Int Int)})) : (List (→ Int Int)) ⇒ (Nil {(List (→ Int Int))})) -;; annotations unneeded: same as tests above, but without annotations -(check-type (g2 Nil) : (List Int) ⇒ Nil) -(check-type (g2 Nil) : (List Bool) ⇒ Nil) -(check-type (g2 Nil) : (List (List Int)) ⇒ Nil) -(check-type (g2 Nil) : (List (→ Int Int)) ⇒ Nil) - -(check-type (g2 (Cons 1 Nil)) : (List Int) ⇒ (Cons 1 Nil)) -(check-type (g2 (Cons "1" Nil)) : (List String) ⇒ (Cons "1" Nil)) - -;; mlish cant type this fn (ie, incomplete cases on variant --- what to put for Nil case?) -;(define (g3 [lst : (List X)] → X) (hd lst)) -;(check-type g3 : (→ {X} (List X) X)) -;(check-type g3 : (→ {A} (List A) A)) -;(check-not-type g3 : (→ {A B} (List A) B)) -;(typecheck-fail (g3) #:with-msg "Expected.+arguments with type.+List") ; TODO: more precise err msg -;(check-type (g3 (nil {Int})) : Int) ; runtime fail -;(check-type (g3 (nil {Bool})) : Bool) ; runtime fail -;(check-type (g3 (cons 1 nil)) : Int ⇒ 1) -;(check-type (g3 (cons "1" nil)) : String ⇒ "1") - -;; recursive fn -(define (recf [x : Int] → Int) (recf x)) -(check-type recf : (→ Int Int)) - -(define (countdown [x : Int] → Int) - (if (zero? x) - 0 - (countdown (sub1 x)))) -(check-type (countdown 0) : Int ⇒ 0) -(check-type (countdown 10) : Int ⇒ 0) -(typecheck-fail (countdown "10") #:with-msg "expected: Int\n *given: String") - -;; list fns ---------- - -; map: tests whether match and define properly propagate 'expected-type -(define (map [f : (→ X Y)] [lst : (List X)] → (List Y)) - (match lst with - [Nil -> Nil] - [Cons x xs -> (Cons (f x) (map f xs))])) -(check-type map : (→/test (→ X Y) (List X) (List Y))) -(check-type map : (→/test {Y X} (→ Y X) (List Y) (List X))) -(check-type map : (→/test (→ A B) (List A) (List B))) -(check-not-type map : (→/test (→ A B) (List B) (List A))) -(check-not-type map : (→/test (→ X X) (List X) (List X))) ; only 1 bound tyvar - -; nil without annotation; tests fn-first, left-to-right arg inference -; does work yet, need to add left-to-right inference in #%app -(check-type (map add1 Nil) : (List Int) ⇒ Nil) -(check-type (map add1 (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ (Cons 2 (Cons 3 (Cons 4 Nil)))) -(typecheck-fail (map add1 (Cons "1" Nil)) - #:with-msg "expected: Int\n *given: String") -(check-type (map (λ ([x : Int]) (+ x 2)) (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ (Cons 3 (Cons 4 (Cons 5 Nil)))) -;; ; doesnt work yet: all lambdas need annotations -;; (check-type (map (λ (x) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) - -(define (filter [p? : (→ X Bool)] [lst : (List X)] → (List X)) - (match lst with - [Nil -> Nil] - [Cons x xs -> (if (p? x) - (Cons x (filter p? xs)) - (filter p? xs))])) -(define (filter/guard [p? : (→ X Bool)] [lst : (List X)] → (List X)) - (match lst with - [Nil -> Nil] - [Cons x xs #:when (p? x) -> (Cons x (filter p? xs))] - [Cons x xs -> (filter p? xs)])) -(check-type (filter zero? Nil) : (List Int) ⇒ Nil) -(check-type (filter zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ Nil) -(check-type (filter zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 0 Nil)) -(check-type (filter (λ (x) (not (zero? x))) (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) -(check-type (filter/guard zero? Nil) : (List Int) ⇒ Nil) -(check-type (filter/guard zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ Nil) -(check-type (filter/guard zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 0 Nil)) -(check-type - (filter/guard (λ (x) (not (zero? x))) (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) -; doesnt work yet: all lambdas need annotations -;(check-type (filter (λ (x) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) - -(define (foldr [f : (→ X Y Y)] [base : Y] [lst : (List X)] → Y) - (match lst with - [Nil -> base] - [Cons x xs -> (f x (foldr f base xs))])) -(define (foldl [f : (→ X Y Y)] [acc : Y] [lst : (List X)] → Y) - (match lst with - [Nil -> acc] - [Cons x xs -> (foldr f (f x acc) xs)])) - -(define (all? [p? : (→ X Bool)] [lst : (List X)] → Bool) - (match lst with - [Nil -> #t] - [Cons x xs #:when (p? x) -> (all? p? xs)] - [Cons x xs -> #f])) - -(define (tails [lst : (List X)] → (List (List X))) - (match lst with - [Nil -> (Cons Nil Nil)] - [Cons x xs -> (Cons lst (tails xs))])) - -(define (build-list [n : Int] [f : (→ Int X)] → (List X)) - (if (zero? (sub1 n)) - (Cons (f 0) Nil) - (Cons (f (sub1 n)) (build-list (sub1 n) f)))) -(check-type (build-list 1 add1) : (List Int) ⇒ (Cons 1 Nil)) -(check-type (build-list 3 add1) : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 Nil)))) -(check-type (build-list 5 sub1) - : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 (Cons 0 (Cons -1 Nil)))))) -(check-type (build-list 5 (λ (x) (add1 (add1 x)))) - : (List Int) ⇒ (Cons 6 (Cons 5 (Cons 4 (Cons 3 (Cons 2 Nil)))))) - -(define (build-list/comp [i : Int] [n : Int] [nf : (→ Int Int)] [f : (→ Int X)] → (List X)) - (if (= i n) - Nil - (Cons (f (nf i)) (build-list/comp (add1 i) n nf f)))) - -(define built-list-1 (build-list/comp 0 3 (λ (x) (* 2 x)) add1)) -(define built-list-2 (build-list/comp 0 3 (λ (x) (* 2 x)) number->string)) -(check-type built-list-1 : (List Int) -> (Cons 1 (Cons 3 (Cons 5 Nil)))) -(check-type built-list-2 : (List String) -> (Cons "0" (Cons "2" (Cons "4" Nil)))) - -(define (~>2 [a : A] [f : (→ A A)] [g : (→ A B)] → B) - (g (f a))) - -(define ~>2-result-1 (~>2 1 (λ (x) (* 2 x)) add1)) -(define ~>2-result-2 (~>2 1 (λ (x) (* 2 x)) number->string)) -(check-type ~>2-result-1 : Int -> 3) -(check-type ~>2-result-2 : String -> "2") - -(define (append [lst1 : (List X)] [lst2 : (List X)] → (List X)) - (match lst1 with - [Nil -> lst2] - [Cons x xs -> (Cons x (append xs lst2))])) - -;; end infer.rkt tests -------------------------------------------------- - -;; algebraic data types -(define-type IntList - INil - (ConsI Int IntList)) - -;; HO, monomorphic -(check-type ConsI : (→ Int IntList IntList)) -(define (new-cons [c : (→ Int IntList IntList)] [x : Int] [xs : IntList] - -> IntList) - (c x xs)) -(check-type (new-cons ConsI 1 INil) : IntList -> (ConsI 1 INil)) - -;; check that ConsI and INil are available as tyvars -(define (f10 [x : INil] [y : ConsI] -> ConsI) y) -(check-type f10 : (→/test X Y Y)) - -(check-type INil : IntList) -(check-type (ConsI 1 INil) : IntList) -(check-type - (match INil with - [INil -> 1] - [ConsI x xs -> 2]) : Int ⇒ 1) -(check-type - (match (ConsI 1 INil) with - [INil -> 1] - [ConsI x xs -> 2]) : Int ⇒ 2) -(typecheck-fail (match 1 with [INil -> 1])) - -(typecheck-fail (ConsI #f INil) - #:with-msg - "expected: Int\n *given: Bool") - -;; annotated -(check-type (Nil {Int}) : (List Int)) -(check-type (Cons {Int} 1 (Nil {Int})) : (List Int)) -(check-type (Cons {Int} 1 (Cons 2 (Nil {Int}))) : (List Int)) -;; partial annotations -(check-type (Cons 1 (Nil {Int})) : (List Int)) -(check-type (Cons 1 (Cons 2 (Nil {Int}))) : (List Int)) -(check-type (Cons {Int} 1 Nil) : (List Int)) -(check-type (Cons {Int} 1 (Cons 2 Nil)) : (List Int)) -(check-type (Cons 1 (Cons {Int} 2 Nil)) : (List Int)) -; no annotations -(check-type (Cons 1 Nil) : (List Int)) -(check-type (Cons 1 (Cons 2 Nil)) : (List Int)) - -(define-type (Tree X) - (Leaf X) - (Node (Tree X) (Tree X))) -(check-type (Leaf 10) : (Tree Int)) -(check-type (Node (Leaf 10) (Leaf 11)) : (Tree Int)) - -(typecheck-fail Nil #:with-msg "Nil: no expected type, add annotations") -(typecheck-fail (Cons 1 (Nil {Bool})) - #:with-msg - "expected: \\(List Int\\)\n *given: \\(List Bool\\)") -(typecheck-fail (Cons {Bool} 1 (Nil {Int})) - #:with-msg - "Cons: type mismatch: expected Bool, given Int\n *expression: 1") -(typecheck-fail (Cons {Bool} 1 Nil) - #:with-msg - "Cons: type mismatch: expected Bool, given Int\n *expression: 1") - -(typecheck-fail (match Nil with [Cons x xs -> 2] [Nil -> 1]) - #:with-msg "Nil: no expected type, add annotations") -(check-type - (match (Nil {Int}) with - [Cons x xs -> 2] - [Nil -> 1]) - : Int ⇒ 1) - -(check-type - (match (Nil {Int}) with - [Nil -> 1] - [Cons x xs -> 2]) - : Int ⇒ 1) - -(check-type - (match (Cons 1 Nil) with - [Nil -> 3] - [Cons y ys -> (+ y 4)]) - : Int ⇒ 5) - -(check-type - (match (Cons 1 Nil) with - [Cons y ys -> (+ y 5)] - [Nil -> 3]) - : Int ⇒ 6) - -;; check expected-type propagation for other match paterns - -(define-type (Option A) - (None) - (Some A)) - -(define (None* → (Option A)) None) - -(check-type (match (tup 1 2) with [a b -> None]) : (Option Int) -> None) -(check-type - (match (list 1 2) with - [[] -> None] - [[x y] -> None]) - : (Option Int) -> None) - -(check-type - (match (list 1 2) with - [[] -> None] - [x :: xs -> None]) - : (Option Int) -> None) - -(define-type (Pairof A B) (C A B)) -(check-type (match (C 1 2) with [C a b -> None]) : (Option Int) -> None) - -;; type variable inference - -; F should remain valid tyvar, even though it's bound -(define (F [x : X] -> X) x) -(define (tvf1 [x : F] -> F) x) -(check-type tvf1 : (→/test X X)) - -; G should remain valid tyvar -(define-type (Type1 X) (G X)) -(define (tvf5 [x : G] -> G) x) -(check-type tvf5 : (→/test X X)) - -; TY should not be tyvar, bc it's a valid type -(define-type-alias TY (Pairof Int Int)) -(define (tvf2 [x : TY] -> TY) x) -(check-not-type tvf2 : (→/test X X)) - -; same with Bool -(define (tvf3 [x : Bool] -> Bool) x) -(check-not-type tvf3 : (→/test X X)) - -;; X in lam should not be a new tyvar -(define (tvf4 [x : X] -> (→ X X)) - (λ (y) x)) -(check-type tvf4 : (→/test X (→ X X))) -(check-not-type tvf4 : (→/test X (→ Y X))) - -(define (tvf6 [x : X] -> (→ Y X)) - (λ (y) x)) -(check-type tvf6 : (→/test X (→ Y X))) - -;; nested lambdas - -(check-type (λ ([x : X]) (λ ([y : X]) y)) : (→/test X (→ X X))) -(check-not-type (λ ([x : X]) (λ ([y : X]) y)) : (→/test {X} X (→/test {Y} Y Y))) -(check-type (λ ([x : X]) (λ ([y : Y]) y)) : (→/test {X} X (→/test {Y} Y Y))) -(check-not-type (λ ([x : X]) (λ ([y : Y]) x)) : (→/test X (→ X X))) - -(check-type - ((λ ([x : X]) (λ ([y : Y]) y)) 1) - : (→/test Y Y)) - -;; TODO? -;; - this fails if polymorphic functions are allowed as HO args -;; - do we want to allow this? -;; - must explicitly instantiate before passing fn -(check-type - ((λ ([x : (→ X (→ Y Y))]) x) - (inst (λ ([x : X]) (inst (λ ([y : Y]) y) Int)) Int)) - : (→ Int (→ Int Int))) - -(check-type - ((λ ([x : X]) (λ ([y : Y]) (λ ([z : Z]) z))) 1) - : (→/test {Y} Y (→/test {Z} Z Z))) - -(check-type (inst Cons (→/test X X)) - : (→ (→/test X X) (List (→/test X X)) (List (→/test X X)))) -(check-type map : (→/test (→ X Y) (List X) (List Y))) - -(check-type (Cons (λ ([x : X]) x) Nil) - : (List (→/test {X} X X))) - -(define (nn [x : X] -> (→ (× X (→ Y Y)))) - (λ () (tup x (λ ([x : Y]) x)))) -(typecheck-fail (nn 1) #:with-msg "Could not infer instantiation of polymorphic function nn.") -(check-type (nn 1) : (→ (× Int (→ String String)))) -(check-type (nn 1) : (→ (× Int (→ (List Int) (List Int))))) - -(define (nn2 [x : X] -> (→ (× X (→ Y Y) (List Z)))) - (λ () (tup x (λ ([x : Y]) x) Nil))) -(typecheck-fail (nn2 1) #:with-msg "Could not infer instantiation of polymorphic function nn2.") -(check-type (nn2 1) : (→ (× Int (→ String String) (List (List Int))))) -(check-type (nn2 1) : (→ (× Int (→ (List Int) (List Int)) (List String)))) -;; test inst order -(check-type ((inst nn2 Int String (List Int)) 1) - : (→ (× Int (→ String String) (List (List Int))))) -(check-type ((inst nn2 Int (List Int) String) 1) - : (→ (× Int (→ (List Int) (List Int)) (List String)))) - -(define (nn3 [x : X] -> (→ (× X (Option Y) (Option Z)))) - (λ () (tup x None None))) -(check-type (nn3 1) : (→/test (× Int (Option Y) (Option Z)))) -(check-type (nn3 1) : (→ (× Int (Option String) (Option (List Int))))) -(check-type ((nn3 1)) : (× Int (Option String) (Option (List Int)))) -(check-type ((nn3 1)) : (× Int (Option (List Int)) (Option String))) -;; test inst order -(check-type ((inst (nn3 1) String (List Int))) : (× Int (Option String) (Option (List Int)))) -(check-type ((inst (nn3 1) (List Int) String)) : (× Int (Option (List Int)) (Option String))) - -(define (nn4 -> (→ (Option X))) - (λ () (None*))) -(check-type (let ([x (nn4)]) - x) - : (→/test (Option X))) - -(define (nn5 -> (→ (Ref (Option X)))) - (λ () (ref (None {X})))) -(typecheck-fail (let ([x (nn5)]) - x) - #:with-msg "Could not infer instantiation of polymorphic function nn5.") - -(define (nn6 -> (→ (Option X))) - (let ([r (((inst nn5 X)))]) - (λ () (deref r)))) -(check-type (nn6) : (→/test (Option X))) - -;; A is covariant, B is invariant. -(define-type (Cps A B) - (cps (→ (→ A B) B))) -(define (cps* [f : (→ (→ A B) B)] → (Cps A B)) - (cps f)) - -(define (nn7 -> (→ (Cps (Option A) B))) - (let ([r (((inst nn5 A)))]) - (λ () (cps* (λ (k) (k (deref r))))))) -(typecheck-fail (let ([x (nn7)]) - x) - #:with-msg "Could not infer instantiation of polymorphic function nn7.") - -(define (nn8 -> (→ (Cps (Option A) Int))) - (nn7)) -(check-type (let ([x (nn8)]) - x) - : (→/test (Cps (Option A) Int))) - -(define-type (Result A B) - (Ok A) - (Error B)) - -(define (ok [a : A] → (Result A B)) - (Ok a)) -(define (error [b : B] → (Result A B)) - (Error b)) - -(define (ok-fn [a : A] -> (→ (Result A B))) - (λ () (ok a))) -(define (error-fn [b : B] -> (→ (Result A B))) - (λ () (error b))) - -(check-type (let ([x (ok-fn 1)]) - x) - : (→/test (Result Int B))) -(check-type (let ([x (error-fn "bad")]) - x) - : (→/test (Result A String))) - -(define (nn9 [a : A] -> (→ (Result A (Ref B)))) - (ok-fn a)) -(define (nn10 [a : A] -> (→ (Result A (Ref String)))) - (nn9 a)) -(define (nn11 -> (→ (Result (Option A) (Ref String)))) - (nn10 (None*))) - -(typecheck-fail (let ([x (nn9 1)]) - x) - #:with-msg "Could not infer instantiation of polymorphic function nn9.") -(check-type (let ([x (nn10 1)]) - x) - : (→ (Result Int (Ref String)))) -(check-type (let ([x (nn11)]) - x) - : (→/test (Result (Option A) (Ref String)))) - -(check-type (if (zero? (random 2)) - (ok 0) - (error "didn't get a zero")) - : (Result Int String)) - -(define result-if-0 - (λ ([b : (Result A1 B1)] [succeed : (→ A1 (Result A2 B2))] [fail : (→ B1 (Result A2 B2))]) - (match b with - [Ok a -> (succeed a)] - [Error b -> (fail b)]))) -(check-type result-if-0 - : (→/test (Result A1 B1) (→ A1 (Result A2 B2)) (→ B1 (Result A2 B2)) - (Result A2 B2))) - -(define (result-if-1 [b : (Result A1 B1)] - → (→ (→ A1 (Result A2 B2)) (→ B1 (Result A2 B2)) - (Result A2 B2))) - (λ ([succeed : (→ A1 (Result A2 B2))] [fail : (→ B1 (Result A2 B2))]) - (result-if-0 b succeed fail))) -(check-type result-if-1 - : (→/test (Result A1 B1) (→ (→ A1 (Result A2 B2)) (→ B1 (Result A2 B2)) - (Result A2 B2)))) -(check-type ((inst result-if-1 Int String (List Int) (List String)) (Ok 1)) - : (→ (→ Int (Result (List Int) (List String))) - (→ String (Result (List Int) (List String))) - (Result (List Int) (List String)))) -(check-type ((inst result-if-1 Int String (List Int) (List String)) (Error "bad")) - : (→ (→ Int (Result (List Int) (List String))) - (→ String (Result (List Int) (List String))) - (Result (List Int) (List String)))) -(check-type (((inst result-if-1 Int String (List Int) (List String)) (Ok 1)) - (λ ([a : Int]) (ok (Cons a Nil))) - (λ ([b : String]) (error (Cons b Nil)))) - : (Result (List Int) (List String))) -;; same thing, but without the lambda annotations: -(check-type (((inst result-if-1 Int String (List Int) (List String)) (Ok 1)) - (λ (a) (ok (Cons a Nil))) - (λ (b) (error (Cons b Nil)))) - : (Result (List Int) (List String))) - -(define (result-if-2 [b : (Result A1 B1)] - → (→ (→ A1 (Result A2 B2)) - (→ (→ B1 (Result A2 B2)) - (Result A2 B2)))) - (λ ([succeed : (→ A1 (Result A2 B2))]) - (λ ([fail : (→ B1 (Result A2 B2))]) - (result-if-0 b succeed fail)))) -(check-type result-if-2 - : (→/test (Result A1 B1) (→ (→ A1 (Result A2 B2)) - (→ (→ B1 (Result A2 B2)) - (Result A2 B2))))) -(check-type ((inst result-if-2 Int String (List Int) (List String)) (Ok 1)) - : (→/test (→ Int (Result (List Int) (List String))) - (→ (→ String (Result (List Int) (List String))) - (Result (List Int) (List String))))) -(check-type (((inst result-if-2 Int String (List Int) (List String)) (Ok 1)) - (λ (a) (Ok (Cons a Nil)))) - : (→/test (→ String (Result (List Int) (List String))) - (Result (List Int) (List String)))) -(check-type ((((inst result-if-2 Int String (List Int) (List String)) (Ok 1)) - (λ (a) (Ok (Cons a Nil)))) - (λ (b) (Error (Cons b Nil)))) - : (Result (List Int) (List String))) - -(define (tup* [a : A] [b : B] -> (× A B)) - (tup a b)) - -(define (nn12 -> (→ (× (Option A) (Option B)))) - (λ () (tup* (None*) (None*)))) -(check-type (let ([x (nn12)]) - x) - : (→/test (× (Option A) (Option B)))) - -(define (nn13 -> (→ (× (Option A) (Option (Ref B))))) - (nn12)) -(typecheck-fail (let ([x (nn13)]) - x) - #:with-msg "Could not infer instantiation of polymorphic function nn13.") - -;; records and automatically-defined accessors and predicates -(define-type (RecoTest X Y) - (RT1 [x : X] [y : Y] [z : String]) - (RT2 [a : Y] [b : X] [c : (List X)]) - (RT3 X Y)) ; mixing records and non-records allowed - -(check-type RT1-x : (→/test (RecoTest X Y) X)) -(check-type RT1-y : (→/test (RecoTest X Y) Y)) -(check-type RT1-z : (→/test (RecoTest X Y) String)) -(check-type RT2-a : (→/test (RecoTest X Y) Y)) -(check-type RT2-b : (→/test (RecoTest X Y) X)) - -(check-type RT1? : (→/test (RecoTest X Y) Bool)) -(check-type RT2? : (→/test (RecoTest X Y) Bool)) -(check-type RT3? : (→/test (RecoTest X Y) Bool)) - -(check-type (RT1-x (RT1 1 #t "2")) : Int -> 1) -(check-type (RT1-y (RT1 1 #t "2")) : Bool -> #t) -(check-type (RT1-z (RT1 1 #t "2")) : String -> "2") - -(check-type (RT2-a (RT2 1 #f Nil)) : Int -> 1) -(check-type (RT2-b (RT2 1 #f Nil)) : Bool -> #f) -(check-type (RT2-c (RT2 1 #f Nil)) : (List Bool) -> Nil) - -(check-type (RT1? (RT1 1 2 "3")) : Bool -> #t) -(check-type (RT1? (RT2 1 2 Nil)) : Bool -> #f) -(check-type (RT1? (RT3 1 "2")) : Bool -> #f) -(check-type (RT3? (RT3 1 2)) : Bool -> #t) -(check-type (RT3? (RT1 1 2 "3")) : Bool -> #f) - -(typecheck-fail RT3-x #:with-msg "unbound identifier") - -;; accessors produce runtime exception if given wrong variant -(check-runtime-exn (RT1-x (RT2 1 #f (Cons #t Nil)))) -(check-runtime-exn (RT1-y (RT2 1 #f (Cons #t Nil)))) -(check-runtime-exn (RT1-z (RT2 1 #f (Cons #t Nil)))) -(check-runtime-exn (RT1-x (RT3 1 2))) -(check-runtime-exn (RT2-a (RT1 1 #f "2"))) -(check-runtime-exn (RT2-c (RT1 1 #f "2"))) -(check-runtime-exn (RT2-c (RT1 1 #f "2"))) -(check-runtime-exn (RT2-a (RT3 #f #t))) - -;; non-match version -(define (rt-fn [rt : (RecoTest X Y)] -> X) - (if (RT1? rt) - (RT1-x rt) - (if (RT2? rt) - (RT2-b rt) - (match rt with [RT3 x y -> x][RT1 x y z -> x][RT2 a b c -> b])))) -(check-type (rt-fn (RT1 1 #f "3")) : Int -> 1) -(check-type (rt-fn (RT2 #f 2 Nil)) : Int -> 2) -(check-type (rt-fn (RT3 10 20)) : Int -> 10) - -;; HO constructors -(check-type RT1 : (→/test X Y String (RecoTest X Y))) -(check-type RT2 : (→/test {X Y} Y X (List X) (RecoTest X Y))) -(check-type RT3 : (→/test X Y (RecoTest X Y))) - -(typecheck-fail (for/fold ([x 1]) () "hello") - #:with-msg "for/fold: type mismatch: expected Int, given String\n *expression: \"hello\"") - -; ext-stlc tests -------------------------------------------------- - -; tests for stlc extensions -; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) - -(typecheck-fail - ((λ ([x : Unit]) x) 2) - #:with-msg - "expected: Unit\n *given: Int") -(typecheck-fail - ((λ ([x : Unit]) x) void) - #:with-msg - "expected: Unit\n *given: \\(→ Unit\\)") - -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(check-type (begin 1) : Int) - -(typecheck-fail (begin) #:with-msg "expected more terms") -;; 2016-03-06: begin terms dont need to be Unit -(check-type (begin 1 2 3) : Int) -#;(typecheck-fail - (begin 1 2 3) - #:with-msg "Expected expression 1 to have Unit type, got: Int") - -(check-type (begin (void) 1) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (begin (void) x)) 1) : Int) -(check-type ((λ ([x : Int]) (begin x)) 1) : Int) -(check-type ((λ ([x : Int]) (begin (begin x))) 1) : Int) -(check-type ((λ ([x : Int]) (begin (void) (begin (void) x))) 1) : Int) -(check-type ((λ ([x : Int]) (begin (begin (void) x))) 1) : Int) - -;;ascription -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) -(typecheck-fail (ann 1 : Bool) #:with-msg "expected Bool, given Int\n *expression: 1") -;ann errs -(typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier") -(typecheck-fail (ann 1 : 1) #:with-msg "not a valid type") -(typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a valid type") -(typecheck-fail (ann Int : Int) #:with-msg "expected Int, given #%type\n *expression: Int") - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail - (let ([x #f]) (+ x 1)) - #:with-msg "expected: Int\n *given: Bool") -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y)) - #:with-msg "x: unbound identifier") - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail - (let* ([x #t] [y (+ x 1)]) 1) - #:with-msg "expected: Int\n *given: Bool") - -; letrec -(typecheck-fail - (letrec ([(x : Int) #f] [(y : Int) 1]) y) - #:with-msg - "letrec: type mismatch: expected Int, given Bool\n *expression: #f") -(typecheck-fail - (letrec ([(y : Int) 1] [(x : Int) #f]) x) - #:with-msg - "letrec: type mismatch: expected Int, given Bool\n *expression: #f") - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ (i) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ (n) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ (n) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; check some more err msgs -(typecheck-fail - (and "1" #f) - #:with-msg "and: type mismatch: expected Bool, given String\n *expression: \"1\"") -(typecheck-fail - (and #t "2") - #:with-msg - "and: type mismatch: expected Bool, given String\n *expression: \"2\"") -(typecheck-fail - (or "1" #f) - #:with-msg - "or: type mismatch: expected Bool, given String\n *expression: \"1\"") -(typecheck-fail - (or #t "2") - #:with-msg - "or: type mismatch: expected Bool, given String\n *expression: \"2\"") -;; 2016-03-09: now ok -(check-type (if "true" 1 2) : Int -> 1) -(typecheck-fail - (if #t 1 "2") - #:with-msg - "branches have incompatible types: Int and String") - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ (x y) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ (x) x) : (→ Int Int)) -(check-type (λ (f) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) - -(typecheck-fail - ((λ ([x : Bool]) x) 1) - #:with-msg "expected: Bool\n *given: Int") -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail - (λ ([f : Int]) (f 1 2)) - #:with-msg - "Expected → type, got: Int") - -(check-type (λ (f x y) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) - : Int ⇒ 3) - -(typecheck-fail - (+ 1 (λ ([x : Int]) x)) - #:with-msg "expected: Int\n *given: \\(→ Int Int\\)") -(typecheck-fail - (λ ([x : (→ Int Int)]) (+ x x)) - #:with-msg "expected: Int\n *given: \\(→ Int Int\\)") -(typecheck-fail - ((λ ([x : Int] [y : Int]) y) 1) - #:with-msg "wrong number of arguments: expected 2, given 1\n *expected: +Int, Int\n *arguments: 1") - -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/mlish/ack.mlish b/tapl/tests/mlish/ack.mlish @@ -1,27 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; tests cond with else - -(define (ack/else [m : Int] [n : Int] -> Int) - (cond - [(zero? m) (add1 n)] - [(zero? n) (ack/else (sub1 m) 1)] - [else - (ack/else (sub1 m) (ack/else m (sub1 n)))])) - -(check-type (ack/else 0 0) : Int -> 1) -(check-type (ack/else 1 1) : Int -> 3) -(check-type (ack/else 2 2) : Int -> 7) -(check-type (ack/else 3 4) : Int -> 125) - -(define (ack [m : Int] [n : Int] -> Int) - (cond - [(zero? m) (add1 n)] - [(zero? n) (ack (sub1 m) 1)] - [#t (ack (sub1 m) (ack m (sub1 n)))])) - -(check-type (ack 0 0) : Int -> 1) -(check-type (ack 1 1) : Int -> 3) -(check-type (ack 2 2) : Int -> 7) -(check-type (ack 3 4) : Int -> 125) diff --git a/tapl/tests/mlish/alex.mlish b/tapl/tests/mlish/alex.mlish @@ -1,25 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; the following function def produces error: -;; define: Function should-err's body (let ((y (f x))) x) has type X, which -;; does not match given type Y. -;; TODO: add check-_ rackunit form for functions -#;(define (should-err [x : X] [f : (→ X Y)] -> Y) - (let ([y (f x)]) - x)) - -(define (try [x : X][f : (→ X Y)] → X) - (let ([y (f x)]) x)) - -(check-type try : (→/test X (→ X Y) X)) - -(define (accept-A×A [pair : (× A A)] → (× A A)) - pair) - -(typecheck-fail (accept-A×A (tup 8 "ate")) - #:with-msg "couldn't unify Int and String\n *expected: \\(× A A\\)\n *given: \\(× Int String\\)") - -(typecheck-fail (ann (accept-A×A (tup 8 "ate")) : (× String String)) - #:with-msg "expected: \\(× String String\\)\n *given: \\(× Int String\\)") - diff --git a/tapl/tests/mlish/ary.mlish b/tapl/tests/mlish/ary.mlish @@ -1,26 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; test vectors and for loops -(define (main [args : (Vector String)] -> (× Int Int)) - (let* ([n (if (zero? (vector-length args)) - 1 - (string->number (vector-ref args 0)))] - [x (make-vector n 0)] - [y (make-vector n 0)] - [last (sub1 n)]) - (begin - (for ([i (in-range n)]) - (vector-set! x i (add1 i))) - (for* ([k (in-range 1000)] - [i (in-range last -1 -1)]) - (vector-set! y i (+ (vector-ref x i) (vector-ref y i)))) - (tup (vector-ref y 0) - (vector-ref y last))))) - -(check-type (main (vector "100")) - : (× Int Int) -> (tup 1000 100000)) -(check-type (main (vector "1000")) - : (× Int Int) -> (tup 1000 1000000)) -(check-type (main (vector "10000")) - : (× Int Int) -> (tup 1000 10000000)) diff --git a/tapl/tests/mlish/bg/basics-general.mlish b/tapl/tests/mlish/bg/basics-general.mlish @@ -1,59 +0,0 @@ -#lang s-exp "../../../typed-lang-builder/mlish.rkt" - -(define-type (List X) - Nil - (Cons X (List X))) -(define-type (** X Y) - (Pair X Y)) -(define-type Bool - True - False) - -(define (map [f : (→ A B)] [x* : (List A)] → (List B)) - (match x* with - [Nil -> Nil] - [Cons x x* -> (Cons (f x) (map f x*))])) - -(define (append [x* : (List A)] [y* : (List A)] → (List A)) - (match x* with - [Nil -> y*] - [Cons x x* -> (Cons x (append x* y*))])) - -(define (fst [xy : (** A B)] → A) - (match xy with - [Pair x y -> x])) - -(define (snd [xy : (** A B)] → B) - (match xy with - [Pair x y -> y])) - -(define (member [x* : (List A)] [y : A] → Bool) - (match x* with - [Nil -> False] - [Cons x x* -> - (if (equal? x y) True (member x* y))])) - -(define (foldl [f : (→ A B A)] [acc : A] [x* : (List B)] → A) - (match x* with - [Nil -> acc] - [Cons x x* -> (foldl f (f acc x) x*)])) - -(define (foldr [f : (→ A B B)] [x* : (List A)] [acc : B] → B) - (match x* with - [Nil -> acc] - [Cons x x* -> (f x (foldr f x* acc))])) - -(define (filter [f : (→ A Bool)] [x* : (List A)] → (List A)) - (foldr (λ ([x : A] [acc : (List A)]) (match (f x) with [True -> (Cons x acc)] [False -> acc])) - x* - Nil)) - -(define (sum [x* : (List Float)] → Float) - (foldl fl+ (exact->inexact 0) x*)) - -(define (reverse [x* : (List A)] → (List A)) - (foldl (λ ([x* : (List A)] [x : A]) (Cons x x*)) Nil x*)) - -(provide-type List Nil Cons ** Pair Bool True False) - -(provide map append fst snd member foldl foldr filter sum reverse) diff --git a/tapl/tests/mlish/bg/basics.mlish b/tapl/tests/mlish/bg/basics.mlish @@ -1,370 +0,0 @@ -#lang s-exp "../../../typed-lang-builder/mlish.rkt" -(require "../../rackunit-typechecking.rkt") -(require "basics-general.mlish") -(require-typed map append fst snd member foldl foldr filter sum reverse - #:from "basics-general.mlish") - -;; ============================================================================= -;; http://www.cs.cornell.edu/courses/cs3110/2011fa/hw/ps1/ps1.html - -(define (fn-list [f* : (List (→ A A))] [a : A] → A) - (match f* with - [Nil -> a] - [Cons f f* -> (fn-list f* (f a))])) - -(check-type - (fn-list (Cons (λ ([x : Int]) (+ x 1)) (Cons (λ ([x : Int]) (* x 2)) Nil)) 4) - : Int - ⇒ 10) - -;; ----------------------------------------------------------------------------- - -(define (count-letters/one [s : String] [c : Char] → Int) - (for/sum ([i (in-range (string-length s))]) - (if (equal? (string-ref s i) c) - 1 - 0))) - -(define (count-letters [s* : (List String)] [c : Char] → Int) - (match s* with - [Nil -> 0] - [Cons s s* -> (+ (count-letters/one s c) - (count-letters s* c))])) - -(check-type - (count-letters (Cons "OCaml" (Cons "Is" (Cons "Alot" (Cons "Better" (Cons "Than" (Cons "Java" Nil)))))) (string-ref "a" 0)) - : Int - ⇒ 4) - -;; ----------------------------------------------------------------------------- - -(define (flatten [x** : (List (List A))] → (List A)) - (match x** with - [Nil -> Nil] - [Cons x* x** -> (append x* (flatten x**))])) - -(define (insert [x : A] → (→ (List A) (List (List A)))) - (λ ([x* : (List A)]) - (Cons (Cons x x*) - (match x* with - [Nil -> Nil] - [Cons y y* -> (map (λ ([z* : (List A)]) (Cons y z*)) - ((insert x) y*))])))) - -(define (permutations [x* : (List A)] → (List (List A))) - (match x* with - [Nil -> (Cons Nil Nil)] - [Cons x x* -> (flatten (map (insert x) (permutations x*)))])) - -(check-type - (permutations Nil) - : (List (List Int)) - ⇒ (Cons Nil Nil)) - -(check-type - (permutations (Cons 1 Nil)) - : (List (List Int)) - ⇒ (Cons (Cons 1 Nil) Nil)) - -(check-type - (permutations (Cons 1 (Cons 2 Nil))) - : (List (List Int)) - ⇒ (Cons (Cons 1 (Cons 2 Nil)) (Cons (Cons 2 (Cons 1 Nil)) Nil))) - -(check-type - (permutations (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List (List Int)) - ⇒ (Cons (Cons 1 (Cons 2 (Cons 3 Nil))) - (Cons (Cons 2 (Cons 1 (Cons 3 Nil))) - (Cons (Cons 2 (Cons 3 (Cons 1 Nil))) - (Cons (Cons 1 (Cons 3 (Cons 2 Nil))) - (Cons (Cons 3 (Cons 1 (Cons 2 Nil))) - (Cons (Cons 3 (Cons 2 (Cons 1 Nil))) - Nil))))))) - -;; ============================================================================= -;; http://www.cs.cornell.edu/courses/cs3110/2011sp/hw/ps1/ps1.htm - -(define (split [ab* : (List (** A B))] → (** (List A) (List B))) - (match ab* with - [Nil -> (Pair Nil Nil)] - [Cons ab ab* -> - (match ab with - [Pair a b -> - (match (split ab*) with - [Pair a* b* -> - (Pair (Cons a a*) - (Cons b b*))])])])) - -(check-type - (split Nil) - : (** (List Int) (List Int)) - ⇒ (Pair Nil Nil)) - -(check-type - (split (Cons (Pair 1 2) (Cons (Pair 3 4) Nil))) - : (** (List Int) (List Int)) - ⇒ (Pair (Cons 1 (Cons 3 Nil)) - (Cons 2 (Cons 4 Nil)))) - -(check-type - (split (Cons (Pair 1 "one") (Cons (Pair 2 "two") (Cons (Pair 3 "three") Nil)))) - : (** (List Int) (List String)) - ⇒ (Pair (Cons 1 (Cons 2 (Cons 3 Nil))) - (Cons "one" (Cons "two" (Cons "three" Nil))))) - -;; ----------------------------------------------------------------------------- - -(define (combine [a*b* : (** (List A) (List B))] → (List (** A B))) - (match a*b* with - [Pair a* b* -> - (match a* with - [Nil -> - (match b* with - [Nil -> - Nil] - [Cons b b* -> - Nil])] ;; Error - [Cons a a* -> - (match b* with - [Nil -> - Nil] ;; Error - [Cons b b* -> - (Cons (Pair a b) (combine (Pair a* b*)))])])])) - -(check-type - (combine (Pair Nil Nil)) - : (List (** Int Int)) - ⇒ Nil) - -(check-type - (combine (Pair (Cons 1 (Cons 2 Nil)) (Cons 3 (Cons 4 Nil)))) - : (List (** Int Int)) - ⇒ (Cons (Pair 1 3) (Cons (Pair 2 4) Nil))) - -(check-type - (combine (split (Cons (Pair 1 "one") (Cons (Pair 2 "two") (Cons (Pair 3 "three") Nil))))) - : (List (** Int String)) - ⇒ (Cons (Pair 1 "one") (Cons (Pair 2 "two") (Cons (Pair 3 "three") Nil)))) - -;; ----------------------------------------------------------------------------- - -(define (convolve [x* : (List Float)] [y* : (List Float)] → Float) - (sum - (map (λ ([xy : (** Float Float)]) (fl* (fst xy) (snd xy))) - (combine (Pair x* (reverse y*)))))) - -(check-type - (convolve (Cons 1.0 (Cons 2.0 (Cons 3.0 Nil))) (Cons 1.0 (Cons 2.0 (Cons 3.0 Nil)))) - : Float - ⇒ (fl+ (fl+ (fl* 1.0 3.0) (fl* 2.0 2.0)) (fl* 3.0 1.0))) - -;; ----------------------------------------------------------------------------- - -(define (mc [n : Int] [f : (→ A A)] [x : A] → A) - (for/fold ([x x]) - ([_i (in-range n)]) - (f x))) - -(check-type - (mc 3000 (λ ([n : Int]) (+ n 1)) 3110) - : Int - ⇒ 6110) - -(define (square [n : Int] → Int) - (* n n)) - -(check-type - (mc 0 square 2) - : Int - ⇒ 2) - -(check-type - (mc 2 square 2) - : Int - ⇒ 16) - -(check-type - (mc 3 square 2) - : Int - ⇒ 256) - -;; ----------------------------------------------------------------------------- - -(define (successor [mcn : (→ (→ A A) A A)] → (→ (→ A A) A A)) - (λ ([f : (→ A A)] [x : A]) - (f (mcn f x)))) - -(check-type - ((successor (λ ([f : (→ Int Int)] [x : Int]) (mc 0 f x))) square 2) - : Int - ⇒ 4) - -(check-type - ((successor (successor (λ ([f : (→ Int Int)] [x : Int]) (mc 0 f x)))) square 2) - : Int - ⇒ 16) - -(check-type - ((successor (successor (successor (λ ([f : (→ Int Int)] [x : Int]) (mc 0 f x))))) square 2) - : Int - ⇒ 256) - -;; # (mc 3 successor) (mc 0) square 2;; - -;; ============================================================================= -;; === sorting - -;; ----------------------------------------------------------------------------- -;; --- mergesort - -(define (split2 [x* : (List A)] → (** (List A) (List A))) - (match x* with - [Nil -> (Pair Nil Nil)] - [Cons h t -> - (match t with - [Nil -> (Pair (Cons h Nil) Nil)] - [Cons h2 x* -> - (match (split2 x*) with - [Pair x* y* -> - (Pair (Cons h x*) (Cons h2 y*))])])])) - -(define (merge [x*+y* : (** (List Int) (List Int))] → (List Int)) - (match x*+y* with - [Pair xx* yy* -> - (match xx* with - [Nil -> yy*] - [Cons x x* -> - (match yy* with - [Nil -> xx*] - [Cons y y* -> - (if (<= x y) - (Cons x (merge (Pair x* yy*))) - (Cons y (merge (Pair xx* y*))))])])])) - -(define (mergesort [x* : (List Int)] → (List Int)) - (match x* with - [Nil -> Nil] - [Cons h t -> - (match t with - [Nil -> (Cons h Nil)] - [Cons h2 t2 -> - (match (split2 x*) with - [Pair x* y* -> - (merge (Pair (mergesort x*) (mergesort y*)))])])])) - -(check-type (mergesort Nil) : (List Int) ⇒ Nil) - -(check-type - (mergesort (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) - : (List Int) - ⇒ (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) - -(check-type - (mergesort (Cons 3 (Cons 7 (Cons 93 (Cons 0 (Cons 2 Nil)))))) - : (List Int) - ⇒ (Cons 0 (Cons 2 (Cons 3 (Cons 7 (Cons 93 Nil)))))) - -;; ----------------------------------------------------------------------------- -;; --- quicksort - -(define (quicksort [x* : (List Int)] → (List Int)) - (match x* with - [Nil -> x*] - [Cons h t -> - (match t with - [Nil -> x*] - [Cons h2 t2 -> - (append - (quicksort (filter (λ ([y : Int]) (if (<= y h) True False)) t)) - (append - (Cons h Nil) - (quicksort (filter (λ ([y : Int]) (if (> y h) True False)) t))))])])) - -(check-type (quicksort Nil) : (List Int) ⇒ Nil) - -(check-type - (quicksort (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) - : (List Int) - ⇒ (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) - -(check-type - (quicksort (Cons 3 (Cons 7 (Cons 93 (Cons 0 (Cons 2 Nil)))))) - : (List Int) - ⇒ (Cons 0 (Cons 2 (Cons 3 (Cons 7 (Cons 93 Nil)))))) - -;; ============================================================================= -;; === CPS - -;; ----------------------------------------------------------------------------- -;; --- factorial - -(define (fact [n : Int] → Int) - (if (< n 2) - 1 - (* n (fact (- n 1))))) - -(define (range-aux [n : Int] → (List Int)) - (if (= 0 n) - (Cons n Nil) - (Cons n (range-aux (- n 1))))) - -(define (range [n : Int] → (List Int)) - (if (<= n 0) - Nil - (reverse (range-aux (- n 1))))) - -(define (fact-acc [n : Int] → Int) - (foldl (λ ([acc : Int] [n : Int]) (* n acc)) 1 (map (λ ([n : Int]) (+ n 1)) (range n)))) - -(define (fact-cps-aux [n : Int] [k : (→ Int Int)] → Int) - (if (< n 2) - (k 1) - (fact-cps-aux (- n 1) (λ ([m : Int]) (k (* n m)))))) - -(define (fact-cps [n : Int] → Int) - (fact-cps-aux n (λ ([x : Int]) x))) - -(check-type (fact 0) : Int ⇒ 1) -(check-type (fact 1) : Int ⇒ 1) -(check-type (fact 2) : Int ⇒ 2) -(check-type (fact 3) : Int ⇒ 6) -(check-type (fact 4) : Int ⇒ 24) -(check-type (fact 5) : Int ⇒ 120) - -(check-type (fact-acc 0) : Int ⇒ 1) -(check-type (fact-acc 1) : Int ⇒ 1) -(check-type (fact-acc 2) : Int ⇒ 2) -(check-type (fact-acc 3) : Int ⇒ 6) -(check-type (fact-acc 4) : Int ⇒ 24) -(check-type (fact-acc 5) : Int ⇒ 120) - -(check-type (fact-cps 0) : Int ⇒ 1) -(check-type (fact-cps 1) : Int ⇒ 1) -(check-type (fact-cps 2) : Int ⇒ 2) -(check-type (fact-cps 3) : Int ⇒ 6) -(check-type (fact-cps 4) : Int ⇒ 24) -(check-type (fact-cps 5) : Int ⇒ 120) - -;; ----------------------------------------------------------------------------- -;; --- map - -(define (map-cps-aux [f : (→ A B)] [x* : (List A)] [k : (→ (List B) (List B))] → (List B)) - (match x* with - [Nil -> (k Nil)] - [Cons x x* -> - (map-cps-aux f x* (λ ([b* : (List B)]) (k (Cons (f x) b*))))])) - -(define (map-cps [f : (→ A B)] [x* : (List A)] → (List B)) - (map-cps-aux f x* (λ ([x : (List B)]) x))) - -(check-type - (map-cps (λ ([x : Int]) (+ x 2)) (Cons 2 (Cons 4 (Cons 8 Nil)))) - : (List Int) - ⇒ (Cons 4 (Cons 6 (Cons 10 Nil)))) - -(check-type - (map-cps exact->inexact (Cons 2 (Cons 4 (Cons 8 Nil)))) - : (List Float) - ⇒ (Cons 2.0 (Cons 4.0 (Cons 8.0 Nil)))) - diff --git a/tapl/tests/mlish/bg/basics2.mlish b/tapl/tests/mlish/bg/basics2.mlish @@ -1,138 +0,0 @@ -#lang s-exp "../../../typed-lang-builder/mlish.rkt" -(require "../../rackunit-typechecking.rkt") -(require "basics-general.mlish") -(require-typed append filter foldr foldl reverse snd member - #:from "basics-general.mlish") - - -;; ============================================================================= -;; http://www.cs.cornell.edu/courses/cs3110/2011fa/hw/ps1/ps1.html -;; continued - -;; ----------------------------------------------------------------------------- - -(define (map-index [is* : (List (** Int (List String)))] → (List (** String Int))) - (match is* with - [Nil -> Nil] - [Cons hd tl -> - (match hd with - [Pair i s* -> - (append (foldr (λ ([s : String] [acc : (List (** String Int))]) (Cons (Pair s i) acc)) - s* - Nil) - (map-index tl))])])) - -(check-type - (map-index Nil) - : (List (** String Int)) - ⇒ Nil) - -(check-type - (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) Nil)) - : (List (** String Int)) - ⇒ (Cons (Pair "a" 0) (Cons (Pair "b" 0) (Cons (Pair "c" 0) Nil)))) - -(check-type - (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) - (Cons (Pair 1 (Cons "d" (Cons "e" Nil))) - Nil))) - : (List (** String Int)) - ⇒ (Cons (Pair "a" 0) (Cons (Pair "b" 0) (Cons (Pair "c" 0) (Cons (Pair "d" 1) (Cons (Pair "e" 1) Nil)))))) - -(define (reduce-index [si* : (List (** String Int))] → (List (** String (List Int)))) - (snd (foldr - (λ ([si : (** String Int)] [acc : (** (List String) (List (** String (List Int))))]) - (match si with - [Pair s i -> - (match acc with - [Pair seen out -> - (match (member seen s) with - [True -> - (Pair - seen - (foldr - (λ ([si* : (** String (List Int))] [acc : (List (** String (List Int)))]) - (match si* with - [Pair s2 i* -> - (if (equal? s s2) - (match (member i* i) with - [True -> (Cons si* acc)] - [False -> (Cons (Pair s2 (Cons i i*)) acc)]) - (Cons si* acc))])) - out - Nil))] - [False -> - (Pair - (Cons s seen) - (Cons (Pair s (Cons i Nil)) out))])])])) - si* - (Pair Nil Nil)))) - - -(check-type - (reduce-index Nil) - : (List (** String (List Int))) - ⇒ Nil) - -(check-type - (reduce-index - (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) - (Cons (Pair 1 (Cons "d" (Cons "e" Nil))) - Nil)))) - : (List (** String (List Int))) - ⇒ (Cons (Pair "a" (Cons 0 Nil)) - (Cons (Pair "b" (Cons 0 Nil)) - (Cons (Pair "c" (Cons 0 Nil)) - (Cons (Pair "d" (Cons 1 Nil)) - (Cons (Pair "e" (Cons 1 Nil)) - Nil)))))) - -(check-type - (reduce-index - (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) - (Cons (Pair 1 (Cons "a" (Cons "b" Nil))) - Nil)))) - : (List (** String (List Int))) - ⇒ (Cons (Pair "c" (Cons 0 Nil)) - (Cons (Pair "a" (Cons 0 (Cons 1 Nil))) - (Cons (Pair "b" (Cons 0 (Cons 1 Nil))) - Nil)))) - -;; For every string, get all integers that refer to the string -(define (make-index [is* : (List (** Int (List String)))] - → (List (** String (List Int)))) - (reduce-index (map-index is*))) - -(check-type - (make-index Nil) - : (List (** String (List Int))) - ⇒ Nil) - -(check-type - (make-index (Cons (Pair 1 (Cons "ocaml" (Cons "is" (Cons "fun" (Cons "because" (Cons "fun" (Cons "is" (Cons "a" (Cons "keyword" Nil))))))))) - (Cons (Pair 2 (Cons "page" (Cons "2" (Cons "intentionally" (Cons "left" (Cons "blank" Nil)))))) - (Cons (Pair 3 (Cons "the" (Cons "quick" (Cons "brown" (Cons "fox" (Cons "jumped" (Cons "over" (Cons "the" (Cons "lazy" (Cons "dog" Nil)))))))))) - (Cons (Pair 4 (Cons "is" (Cons "this" (Cons "the" (Cons "end" Nil))))) Nil))))) - : (List (** String (List Int))) - ⇒ (Cons (Pair "ocaml" (Cons 1 Nil)) - (Cons (Pair "because" (Cons 1 Nil)) - (Cons (Pair "fun" (Cons 1 Nil)) - (Cons (Pair "a" (Cons 1 Nil)) - (Cons (Pair "keyword" (Cons 1 Nil)) - (Cons (Pair "page" (Cons 2 Nil)) - (Cons (Pair "2" (Cons 2 Nil)) - (Cons (Pair "intentionally" (Cons 2 Nil)) - (Cons (Pair "left" (Cons 2 Nil)) - (Cons (Pair "blank" (Cons 2 Nil)) - (Cons (Pair "quick" (Cons 3 Nil)) - (Cons (Pair "brown" (Cons 3 Nil)) - (Cons (Pair "fox" (Cons 3 Nil)) - (Cons (Pair "jumped" (Cons 3 Nil)) - (Cons (Pair "over" (Cons 3 Nil)) - (Cons (Pair "lazy" (Cons 3 Nil)) - (Cons (Pair "dog" (Cons 3 Nil)) - (Cons (Pair "is" (Cons 1 (Cons 4 Nil))) - (Cons (Pair "this" (Cons 4 Nil)) - (Cons (Pair "the" (Cons 3 (Cons 4 Nil))) - (Cons (Pair "end" (Cons 4 Nil)) Nil)))))))))))))))))))))) - diff --git a/tapl/tests/mlish/bg/huffman.mlish b/tapl/tests/mlish/bg/huffman.mlish @@ -1,278 +0,0 @@ -#lang s-exp "../../../typed-lang-builder/mlish.rkt" -(require "../../rackunit-typechecking.rkt") - -;; Huffman trees from SICP - -;; ============================================================================= -;; === Sets of Symbols - -(define-type-alias Symbol String) - -;; Set of strings -(define-type Symbol* - [Empty] - [Singleton String] - [Join String Symbol* Symbol*]) - -(define (empty → Symbol*) - Empty) - -(define (singleton [s : String] → Symbol*) - (Singleton s)) - -(define (insert [s* : Symbol*] [s1 : String] → Symbol*) - (match s* with - [Empty -> (singleton s1)] - [Singleton s2 -> - (if (string<=? s1 s2) - (if (string=? s1 s2) - s* - (Join s2 (singleton s1) (empty))) - (Join s1 (singleton s2) (empty)))] - [Join s2 l* r* -> - (if (string<=? s1 s2) - (if (string=? s1 s2) - s* - (Join s2 (insert l* s1) r*)) - (Join s2 l* (insert r* s1)))])) - -(define (union [s1 : Symbol*] [s2 : Symbol*] → Symbol*) - (match s1 with - [Empty -> s2] - [Singleton s -> (insert s2 s)] - [Join s l* r* -> (union l* (union r* (insert s2 s)))])) - -(define (contains [s* : Symbol*] [s : Symbol] → Bool) - (match s* with - [Empty -> #f] - [Singleton s2 -> (string=? s s2)] - [Join s2 l* r* -> - (if (string<=? s s2) - (if (string=? s s2) - #t - (contains l* s)) - (contains r* s))])) - -;; ----------------------------------------------------------------------------- - -(check-type - (insert (empty) "hello") - : Symbol* - ⇒ (singleton "hello")) - -(check-type - (insert (insert (empty) "a") "b") - : Symbol* - ⇒ (Join "b" (singleton "a") (empty))) - -(check-type - (insert (insert (empty) "b") "a") - : Symbol* - ⇒ (Join "b" (singleton "a") (empty))) - -(check-type - (insert (insert (insert (empty) "a") "b") "c") - : Symbol* - ⇒ (Join "b" (singleton "a") (singleton "c"))) - -(check-type - (insert (insert (insert (empty) "c") "b") "a") - : Symbol* - ⇒ (Join "c" (Join "b" (singleton "a") (empty)) (empty))) - -(check-type - (union - (insert (insert (insert (empty) "c") "b") "a") - (insert (insert (insert (empty) "a") "b") "c")) - : Symbol* - ⇒ (Join "b" (singleton "a") (singleton "c"))) - -;; ----------------------------------------------------------------------------- - -(define-type (List A) - [⊥] - [∷ A (List A)]) - -(define-type-alias SymbolList (List Symbol)) - -(define (list [x : A] → (List A)) - (∷ x ⊥)) - -(define (append [x* : (List A)] [y* : (List A)] → (List A)) - (match x* with - [⊥ -> y*] - [∷ x x* -> - (∷ x (append x* y*))])) - -(define (length [x* : (List A)] → Int) - (match x* with - [⊥ -> 0] - [∷ x x* -> (+ 1 (length x*))])) - -;; ----------------------------------------------------------------------------- - -(define-type Bit O I) -(define-type-alias Bit* (List Bit)) - -;; ----------------------------------------------------------------------------- - -(define-type HTree - [Leaf String Int] ;; Symbol, Weight - [Node HTree HTree Symbol* Int] ;; Left, Right, Symbols, Weight -) - -(define (symbols [h : HTree] → Symbol*) - (match h with - [Leaf s w -> (singleton s)] - [Node lh rh s* w -> s*])) - -(define (weight [h : HTree] → Int) - (match h with - [Leaf s w -> w] - [Node l r s w -> w])) - -(define (make-code-tree [left : HTree] [right : HTree] → HTree) - (Node left right - (union (symbols left) (symbols right)) - (+ (weight left) (weight right)))) - -(define (decode-aux [bits : Bit*] [root : HTree] [current-branch : HTree] → SymbolList) - (match bits with - [⊥ -> - ⊥] - [∷ b bit* -> - (match (choose-branch b current-branch) with - [Leaf s w -> - (∷ s (decode-aux bit* root root))] - [Node l r s* w -> - (decode-aux bit* root (Node l r s* w))])])) - -(define (decode [bits : Bit*] [tree : HTree] → SymbolList) - (decode-aux bits tree tree)) - -(define (choose-branch [bit : Bit] [branch : HTree] → HTree) - (match branch with - [Leaf s w -> - ;; Error - (Leaf "ERROR" 0)] - [Node l* r* s* w -> - (match bit with - [O -> l*] - [I -> r*])])) - -(define-type-alias HTreeSet (List HTree)) - -(define (adjoin-set [x : HTree] [set : HTreeSet] → HTreeSet) - (match set with - [⊥ -> (list x)] - [∷ y y* -> - (if (< (weight x) (weight y)) - (∷ x set) - (∷ y (adjoin-set x y*)))])) - -(define (make-leaf-set [pair* : (List (× Symbol Int))] → HTreeSet) - (match pair* with - [⊥ -> ⊥] - [∷ pair pair* -> - (match pair with - [s i -> - (adjoin-set (Leaf s i) (make-leaf-set pair*))])])) - -(check-type - (make-leaf-set (∷ (tup "A" 4) - (∷ (tup "B" 2) - (∷ (tup "C" 1) - (∷ (tup "D" 1) - ⊥))))) - : HTreeSet - ⇒ (∷ (Leaf "D" 1) - (∷ (Leaf "C" 1) - (∷ (Leaf "B" 2) - (∷ (Leaf "A" 4) - ⊥))))) - -(define sample-tree - (make-code-tree - (Leaf "A" 4) - (make-code-tree - (Leaf "B" 2) - (make-code-tree - (Leaf "D" 1) - (Leaf "C" 1))))) - -(define sample-message - (∷ O (∷ I (∷ I (∷ O (∷ O (∷ I (∷ O (∷ I (∷ O (∷ I (∷ I (∷ I (∷ I (∷ O ⊥))))))))))))))) - -(check-type - (decode sample-message sample-tree) - : SymbolList - ⇒ (∷ "A" (∷ "D" (∷ "A" (∷ "B" (∷ "B" (∷ "C" (∷ "B" ⊥)))))))) - -(define (encode [message : SymbolList] [tree : HTree] → Bit*) - (match message with - [⊥ -> ⊥] - [∷ m m* -> - (append (encode-symbol m tree) (encode m* tree))])) - -(define (contains-symbol [s : Symbol] [tree : HTree] → Bool) - (contains (symbols tree) s)) - -;; Undefined if symbol is not in tree. Be careful! -(define (encode-symbol [s : Symbol] [tree : HTree] → Bit*) - (match tree with - [Leaf s w -> ⊥] - [Node l* r* s* w -> - (if (contains-symbol s l*) - (∷ O (encode-symbol s l*)) - (∷ I (encode-symbol s r*)))])) - -(check-type - (encode (decode sample-message sample-tree) sample-tree) - : Bit* - ⇒ sample-message) - -(define-type-alias Frequency Int) -(define (generate-huffman-tree [pair* : (List (× Symbol Frequency))] → HTree) - (successive-merge (make-leaf-set pair*))) - -(define (successive-merge [tree* : HTreeSet] → HTree) - (match tree* with - [⊥ -> (Leaf "ERROR" 0)] - [∷ t t* -> - (match t* with - [⊥ -> t] - [∷ t2 t* -> - (successive-merge (adjoin-set (make-code-tree t t2) t*))])])) - -(define rock-pair* - (∷ (tup "A" 2) - (∷ (tup "BOOM" 2) - (∷ (tup "GET" 2) - (∷ (tup "JOB" 2) - (∷ (tup "NA" 16) - (∷ (tup "SHA" 3) - (∷ (tup "YIP" 9) - (∷ (tup "WAH" 1) - ⊥))))))))) - -(define rock-tree (generate-huffman-tree rock-pair*)) - -(define rock-message - (∷ "GET" (∷ "A" (∷ "JOB" - (∷ "SHA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" - (∷ "GET" (∷ "A" (∷ "JOB" - (∷ "SHA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" - (∷ "WAH" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" - (∷ "SHA" (∷ "BOOM" ⊥))))))))))))))))))))))))))))))))))))) - -(define rock-bit* (encode rock-message rock-tree)) - -(check-type - (decode rock-bit* rock-tree) - : SymbolList - ⇒ rock-message) - -(check-type - (length rock-bit*) - : Int - ⇒ 84) diff --git a/tapl/tests/mlish/bg/lambda.mlish b/tapl/tests/mlish/bg/lambda.mlish @@ -1,95 +0,0 @@ -#lang s-exp "../../../typed-lang-builder/mlish.rkt" -(require "../../rackunit-typechecking.rkt") - -;; Lambda Calculus interpreter - - -;; Problems: -;; - Cannot use variable in head position of match (gotta exhaust constructors) - -;; ----------------------------------------------------------------------------- - -(define-type Λ - (Var Int) - (Lambda Int Λ) - (App Λ Λ)) - -(define (fresh [e : Λ] → Int) - (match e with - [Var i -> (+ i 1)] - [Lambda i e -> (+ i (fresh e))] - [App e1 e2 -> (+ 1 (+ (fresh e1) (fresh e2)))])) - -(define (subst [e : Λ] [i : Int] [v : Λ] → Λ) - (match e with - [Var j -> - (if (= i j) - v - e)] - [Lambda j e2 -> - (if (= i j) - e - (Lambda j (subst e2 i v)))] - [App e1 e2 -> - (App (subst e1 i v) (subst e2 i v))])) - -(define (simpl-aux [e : Λ] [i : Int] → (× Int Λ)) - (match e with - [Var j -> (tup i (Var j))] - [Lambda j e -> - (match (simpl-aux (subst e j (Var i)) (+ i 1)) with - [k e2 -> - (tup k (Lambda i e2))])] - [App e1 e2 -> - (match (simpl-aux e1 i) with - [j e1 -> - (match (simpl-aux e2 j) with - [k e2 -> - (tup k (App e1 e2))])])])) - -(define (simpl [e : Λ] → Λ) - (match (simpl-aux e 0) with - [i e2 -> e2])) - -(define (eval [e : Λ] → Λ) - (match e with - [Var i -> (Var i)] - [Lambda i e1 -> e] - [App e1 e2 -> - (match (eval e1) with - [Var i -> (Var -1)] - [App e1 e2 -> (Var -2)] - [Lambda i e -> - (match (tup 0 (eval e2)) with - [zero v2 -> - (eval (subst e i (subst v2 i (Var (+ (fresh e) (fresh v2))))))])])])) - -;; ----------------------------------------------------------------------------- - -(define I (Lambda 0 (Var 0))) -(define K (Lambda 0 (Lambda 1 (Var 0)))) -(define S (Lambda 0 (Lambda 1 (Lambda 2 (App (App (Var 0) (Var 2)) (App (Var 1) (Var 2))))))) -(define false (App S K)) - -;; ----------------------------------------------------------------------------- - -(check-type - (eval I) - : Λ - ⇒ I) - -(check-type - (eval (App I I)) - : Λ - ⇒ I) - -(check-type - (eval (App (App K (Var 2)) (Var 3))) - : Λ - ⇒ (Var 2)) - -(check-type - (eval (App (App false (Var 2)) (Var 3))) - : Λ - ⇒ (Var 3)) - diff --git a/tapl/tests/mlish/bg/monad.mlish b/tapl/tests/mlish/bg/monad.mlish @@ -1,122 +0,0 @@ -#lang s-exp "../../../typed-lang-builder/mlish.rkt" -(require "../../rackunit-typechecking.rkt") - -(define-type (Option A) - [None] - [Some A]) - -;; ----------------------------------------------------------------------------- - -(define-type (List a) - [Nil] - [∷ a (List a)]) - -(define (foldl [f : (→ A B A)] [acc : A] [x* : (List B)] → A) - (match x* with - [Nil -> acc] - [∷ h t -> (foldl f (f acc h) t)])) - -(define (reverse [x* : (List A)] → (List A)) - (foldl (λ ([acc : (List A)] [x : A]) (∷ x acc)) Nil x*)) - -;; ============================================================================= -;; === BatchedQueue - -(define-type (BatchedQueue A) - [BQ (List A) (List A)]) - -(define (bq-check [f : (List A)] [r : (List A)] → (BatchedQueue A)) - (match f with - [Nil -> (BQ (reverse r) Nil)] - [∷ h t -> (BQ f r)])) - -(define (bq-empty → (BatchedQueue A)) - (BQ Nil Nil)) - -(define (bq-isEmpty [bq : (BatchedQueue A)] → Bool) - (match bq with - [BQ f r -> - (match f with - [Nil -> #t] - [∷ h t -> #f])])) - -(define (bq-snoc [bq : (BatchedQueue A)] [x : A] → (BatchedQueue A)) - (match bq with - [BQ f r -> (bq-check f (∷ x r))])) - -(define (bq-head [bq : (BatchedQueue A)] → (Option A)) - (match bq with - [BQ f r -> - (match f with - [Nil -> None] - [∷ h t -> (Some h)])])) - -(define (bq-tail [bq : (BatchedQueue A)] → (Option (BatchedQueue A))) - (match bq with - [BQ f* r* -> - (match f* with - [Nil -> None] - [∷ x f* -> - (Some (bq-check f* r*))])])) - -(define (list->bq [x* : (List A)] → (BatchedQueue A)) - (foldl - (λ ([q : (BatchedQueue A)] [x : A]) (bq-snoc q x)) - (bq-empty) x*)) - -;; ----------------------------------------------------------------------------- - -(define digit* - (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))))))) - -(check-type digit* : (List Int)) - -(define sample-bq - (list->bq digit*)) - -(check-type sample-bq : (BatchedQueue Int)) - -(check-type (Some sample-bq) : (Option (BatchedQueue Int))) - -(define (>> [f : (→ A (Option B))] [x : (Option A)] → (Option B)) - (match x with - [None -> None] - [Some y -> (f y)])) - -(check-type >> : (→/test (→ X (Option Y)) (Option X) (Option Y))) - -(check-type (bq-tail sample-bq) : (Option (BatchedQueue Int))) - -;; can't pass polymorphic fn? need to inst first -(check-type (>> (inst bq-tail Int) (Some sample-bq)) - : (Option (BatchedQueue Int))) - -;(ann (>> bq-tail (Some sample-bq)) : (Option (BatchedQueue Int))) - -(define intbq-tail (inst bq-tail Int)) - -(check-type intbq-tail : - (→/test (BatchedQueue Int) (Option (BatchedQueue Int)))) - -(check-type (>> intbq-tail (Some sample-bq)) - : (Option (BatchedQueue Int))) - -(check-type (inst bq-head Int) : (→/test (BatchedQueue Int) (Option Int))) - -(define bq-tails-result - (>> intbq-tail (>> intbq-tail (>> intbq-tail (Some sample-bq))))) - -(check-type bq-tails-result : (Option (BatchedQueue Int)) - ⇒ (Some (BQ (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))) Nil))) - -(check-type (>> (inst bq-head Int) bq-tails-result) : (Option Int) -> (Some 4)) - -;; check match2 nested datatype bug -(check-type - (match bq-tails-result with - [None -> None] - [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4)) -(check-type - (match2 bq-tails-result with - [None -> None] - [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4)) diff --git a/tapl/tests/mlish/bg/okasaki.mlish b/tapl/tests/mlish/bg/okasaki.mlish @@ -1,1654 +0,0 @@ -#lang s-exp "../../../typed-lang-builder/mlish.rkt" -(require "../../rackunit-typechecking.rkt") - -;; TODO -;; - cannot inst polymorphic function `bq-empty` -;; - cannot inst `(BQ (Nil {A}) (Nil {A}))` -;; - cannot use bq-snoc directly in a foldl (need wrapper λ) - -;; ----------------------------------------------------------------------------- - -(define-type (Option A) - [None] - [Some A]) - -;; ----------------------------------------------------------------------------- - -(define (div (n1 : Int) (n2 : Int) → Int) - (if (< n1 n2) - 0 - (+ 1 (div (- n1 n2) n2)))) - -(define (mod (n1 : Int) (n2 : Int) → Int) - (if (< n1 n2) - n1 - (mod (- n1 n2) n2))) - -;; ----------------------------------------------------------------------------- - -(define-type (List a) - [Nil] - [∷ a (List a)]) - -(define (foldl [f : (→ A B A)] [acc : A] [x* : (List B)] → A) - (match x* with - [Nil -> acc] - [∷ h t -> (foldl f (f acc h) t)])) - -(define (reverse [x* : (List A)] → (List A)) - (foldl (λ ([acc : (List A)] [x : A]) (∷ x acc)) Nil x*)) - -(define (append [x* : (List A)] [y* : (List A)] → (List A)) - (match x* with - [Nil -> y*] - [∷ x x* -> - (∷ x (append x* y*))])) - -(define (take [i : Int] [x* : (List A)] → (List A)) - (if (<= i 0) - Nil - (match x* with - [Nil -> Nil] - [∷ h t -> (∷ h (take (- i 1) t))]))) - -(define (drop [i : Int] [x* : (List A)] → (List A)) - (if (<= i 0) - x* - (match x* with - [Nil -> Nil] - [∷ h t -> (drop (- i 1) t)]))) - -;; ============================================================================= -;; === BatchedQueue - -(define-type (BatchedQueue A) - [BQ (List A) (List A)]) - -(define (bq-check [f : (List A)] [r : (List A)] → (BatchedQueue A)) - (match f with - [Nil -> (BQ (reverse r) Nil)] - [∷ h t -> (BQ f r)])) - -(define (bq-empty → (BatchedQueue A)) - (BQ Nil Nil)) - -(define (bq-isEmpty [bq : (BatchedQueue A)] → Bool) - (match bq with - [BQ f r -> - (match f with - [Nil -> #t] - [∷ h t -> #f])])) - -(define (bq-snoc [bq : (BatchedQueue A)] [x : A] → (BatchedQueue A)) - (match bq with - [BQ f r -> (bq-check f (∷ x r))])) - -(define (bq-head [bq : (BatchedQueue A)] → (Option A)) - (match bq with - [BQ f r -> - (match f with - [Nil -> None] - [∷ h t -> (Some h)])])) - -(define (bq-tail [bq : (BatchedQueue A)] → (Option (BatchedQueue A))) - (match bq with - [BQ f* r* -> - (match f* with - [Nil -> None] - [∷ x f* -> - (Some (bq-check f* r*))])])) - -(define (list->bq [x* : (List A)] → (BatchedQueue A)) - (foldl - ;bq-snoc ;; TODO - (λ ([q : (BatchedQueue A)] [x : A]) (bq-snoc q x)) - (bq-empty) x*)) - -;; ----------------------------------------------------------------------------- - -(define digit* - (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))))))) - -(define abc - (∷ "A" (∷ "B" (∷ "C" Nil)))) - -(define def - (∷ "D" (∷ "E" (∷ "F" Nil)))) - -(define sample-bq (list->bq digit*)) - -(check-type - (bq-isEmpty (BQ (Nil {Bool}) (Nil {Bool}))) - ;(bq-isEmpty (bq-empty {Bool})) - ;(bq-isEmpty (BQ (Nil {Bool}) (Nil {Bool}))) ;; TODO - : Bool - ⇒ #t) - -(check-type - (bq-isEmpty sample-bq) - : Bool - ⇒ #f) - -(check-type - (bq-head sample-bq) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (bq-head (bq-snoc sample-bq 10)) - : (Option Int) - ⇒ (Some 1)) - -(define (>> [f : (→ A (Option A))] [x : (Option A)] → (Option A)) - (match x with - [None -> None] - [Some y -> (f y)])) - -(check-type - (match (bq-tail sample-bq) with - [None -> None] - [Some bq -> (bq-head bq)]) - : (Option Int) - ⇒ (Some 2)) - -;; TODO -;(check-type -; (>> bq-head (>> bq-tail (>> bq-tail (>> bq-tail (Some sample-bq))))) -; : (Option Int) -; ⇒ (Some 4)) - -;; ============================================================================= -;; === Bankers Queue - -(define-type (BankersQueue A) - (Bank Int (List A) Int (List A))) - -(define (bank-check [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (BankersQueue A)) - (if (<= lenr lenf) - (Bank lenf f lenr r) - (Bank (+ lenf lenr) (append f (reverse r)) 0 Nil))) - -(define (bank-empty → (BankersQueue A)) - (Bank 0 Nil 0 Nil)) - -(define (bank-isEmpty [bq : (BankersQueue A)] → Bool) - (match bq with - [Bank lenf f lenr r -> (= 0 lenf)])) - -(define (bank-snoc [bq : (BankersQueue A)] [x : A] → (BankersQueue A)) - (match bq with - [Bank lenf f lenr r -> (bank-check lenf f (+ 1 lenr) (∷ x r))])) - -(define (bank-head [bq : (BankersQueue A)] → (Option A)) - (match bq with - [Bank lenf f lenr r -> - (match f with - [Nil -> None] - [∷ h t -> (Some h)])])) - -(define (bank-tail [bq : (BankersQueue A)] → (Option (BankersQueue A))) - (match bq with - [Bank lenf f lenr r -> - (match f with - [Nil -> None] - [∷ h t -> (Some (bank-check (- lenf 1) t lenr r))])])) - -;; ----------------------------------------------------------------------------- - -(define sample-bank - (foldl (λ ([acc : (BankersQueue Int)] [x : Int]) (bank-snoc acc x)) (bank-empty) digit*)) - -(check-type - (bank-isEmpty (Bank 0 (Nil {Int}) 0 (Nil {Int}))) - : Bool - ⇒ #t) - -(check-type - (bank-isEmpty sample-bank) - : Bool - ⇒ #f) - -(check-type - (bank-head sample-bank) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (bank-head (bank-snoc sample-bank 10)) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (match (bank-tail sample-bank) with - [None -> None] - [Some bank -> (bank-head bank)]) - : (Option Int) - ⇒ (Some 2)) - -;; ============================================================================= -;; === Physicists Queue - -(define-type (PhysicistsQueue A) - (PQ (List A) Int (List A) Int (List A))) - -(define (pq-check [w : (List A)] [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (PhysicistsQueue A)) - (if (<= lenr lenf) - (pq-checkw w lenf f lenr r) - (pq-checkw f (+ lenf lenr) (append f (reverse r)) 0 Nil))) - -(define (pq-checkw [w : (List A)] [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (PhysicistsQueue A)) - (match w with - [Nil -> (PQ f lenf f lenr r)] - [∷ h t -> (PQ w lenf f lenr r)])) - -(define (pq-empty → (PhysicistsQueue A)) - (PQ Nil 0 Nil 0 Nil)) - -(define (pq-isEmpty [pq : (PhysicistsQueue A)] → Bool) - (match pq with - [PQ w lenf f lenr r -> - (= lenf 0)])) - -(define (pq-snoc [pq : (PhysicistsQueue A)] [x : A] → (PhysicistsQueue A)) - (match pq with - [PQ w lenf f lenr r -> (pq-check w lenf f (+ 1 lenr) (∷ x r))])) - -(define (pq-head [pq : (PhysicistsQueue A)] → (Option A)) - (match pq with - [PQ w lenf f lenr r -> - (match w with - [Nil -> None] - [∷ w w* -> (Some w)])])) - -(define (pq-tail [pq : (PhysicistsQueue A)] → (Option (PhysicistsQueue A))) - (match pq with - [PQ w lenf f lenr r -> - (match w with - [Nil -> None] - [∷ x w* -> - (match f with - [Nil -> None] ;; Never happens - [∷ f f* -> (Some (pq-check w* (- lenf 1) f* lenr r))])])])) - -;; ----------------------------------------------------------------------------- - -(define sample-pq - (foldl (λ ([acc : (PhysicistsQueue Int)] [x : Int]) (pq-snoc acc x)) (pq-empty) digit*)) - -(check-type - (pq-isEmpty (PQ (Nil {Int}) 0 (Nil {Int}) 0 (Nil {Int}))) - : Bool - ⇒ #t) - -(check-type - (pq-isEmpty sample-pq) - : Bool - ⇒ #f) - -(check-type - (pq-head sample-pq) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (pq-head (pq-snoc sample-pq 10)) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (match (pq-tail sample-pq) with - [None -> None] - [Some pq -> (pq-head pq)]) - : (Option Int) - ⇒ (Some 2)) - -;; ============================================================================= -;; === Hood-Melville Queue - -(define-type (RotationState A) - [Idle] - [Reversing Int (List A) (List A) (List A) (List A)] - [Appending Int (List A) (List A)] - [Done (List A)]) - -(define-type (HoodMelvilleQueue A) - [HM Int (List A) (RotationState A) Int (List A)]) - -(define (hm-exec [rs : (RotationState A)] → (RotationState A)) - (match rs with - [Idle -> rs] - [Done x -> rs] - [Appending ok f* r* -> - (if (= ok 0) - (Done r*) - (match f* with - [Nil -> rs] - [∷ x f* -> - (Appending (- ok 1) f* (∷ x r*))]))] - [Reversing ok f1* f2* r1* r2* -> - (match f1* with - [Nil -> - (match r1* with - [Nil -> rs] - [∷ y r1* -> - (match r1* with - [Nil -> (Appending ok f2* (∷ y r2*))] - [∷ a b -> rs])])] - [∷ x f1* -> - (match r1* with - [Nil -> rs] - [∷ y r1* -> - (Reversing (+ ok 1) f1* (∷ x f2*) r1* (∷ y r2*))])])])) - -(define (hm-invalidate [rs : (RotationState A)] → (RotationState A)) - (match rs with - [Reversing ok f1* f2* r1* r2* -> - (Reversing (- ok 1) f1* f2* r1* r2*)] - [Appending ok f* r* -> - (if (= 0 ok) - (match r* with - [Nil -> rs] - [∷ x r* -> (Done r*)]) - (Appending (- ok 1) f* r*))] - [Done x -> rs] - [Idle -> rs])) - -(define (hm-exec2 [lenf : Int] [f* : (List A)] [state : (RotationState A)] [lenr : Int] [r : (List A)] → (HoodMelvilleQueue A)) - ((λ ([newstate : (RotationState A)]) - (match newstate with - [Done newf -> (HM lenf newf Idle lenr r)] - [Idle -> (HM lenf f* newstate lenr r)] - [Appending a b c -> (HM lenf f* newstate lenr r)] - [Reversing a b c d e -> (HM lenf f* newstate lenr r)])) - (hm-exec (hm-exec state)))) - -(define (hm-check [lenf : Int] [f* : (List A)] [state : (RotationState A)] [lenr : Int] [r* : (List A)] → (HoodMelvilleQueue A)) - (if (<= lenr lenf) - (hm-exec2 lenf f* state lenr r*) - (hm-exec2 (+ lenf lenr) f* (Reversing 0 f* Nil r* Nil) 0 Nil))) - -(define (hm-empty → (HoodMelvilleQueue A)) - (HM 0 Nil Idle 0 Nil)) - -(define (hm-isEmpty [hm : (HoodMelvilleQueue A)] → Bool) - (match hm with - [HM lenf b c d e -> - (= lenf 0)])) - -(define (hm-snoc [hm : (HoodMelvilleQueue A)] [x : A] → (HoodMelvilleQueue A)) - (match hm with - [HM lenf f state lenr r -> (hm-check lenf f state (+ lenr 1) (∷ x r))])) - -(define (hm-head [hm : (HoodMelvilleQueue A)] → (Option A)) - (match hm with - [HM a f b c d -> - (match f with - [Nil -> None] - [∷ x f* -> (Some x)])])) - -(define (hm-tail [hm : (HoodMelvilleQueue A)] → (Option (HoodMelvilleQueue A))) - (match hm with - [HM lenf f state lenr r -> - (match f with - [Nil -> None] - [∷ x f* -> (Some (hm-check (- lenf 1) f* (hm-invalidate state) lenr r))])])) - -;; ----------------------------------------------------------------------------- - -(define sample-hm - (foldl (λ ([acc : (HoodMelvilleQueue Int)] [x : Int]) (hm-snoc acc x)) (hm-empty) digit*)) - -(check-type - (hm-isEmpty (HM 0 (Nil {Int}) Idle 0 (Nil {Int}))) - : Bool - ⇒ #t) - -(check-type - (hm-isEmpty sample-hm) - : Bool - ⇒ #f) - -(check-type - (hm-head sample-hm) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (hm-head (hm-snoc sample-hm 10)) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (match (hm-tail sample-hm) with - [None -> None] - [Some hm -> (hm-head hm)]) - : (Option Int) - ⇒ (Some 2)) - -;; ============================================================================= -;; === Bootstrapped Queue - -(define-type (BootstrappedQueue a) - [E] - [Q Int (List a) (BootstrappedQueue (List a)) Int (List a)]) - -(define (bs-checkQ [lenfm : Int] [f : (List A)] [m : (BootstrappedQueue (List A))] [lenr : Int] [r : (List A)] → (BootstrappedQueue A)) - (if (<= lenr lenfm) - (bs-checkF lenfm f m lenr r) - (bs-checkF (+ lenfm lenr) f (bs-snoc m (reverse r)) 0 Nil))) - -(define (bs-checkF [lenfm : Int] [f : (List A)] [m : (BootstrappedQueue (List A))] [lenr : Int] [r : (List A)] → (BootstrappedQueue A)) - (match f with - [Nil -> - (match m with - [E -> E] - [Q _a _b _c _d _e -> - (match (bs-head m) with - [None -> E] - [Some hd -> - (match (bs-tail m) with - [None -> E] - [Some tl -> - (Q lenfm hd tl lenr r)])])])] - [∷ _f _f* -> - (Q lenfm f m lenr r)])) - -(define (bs-empty → (BootstrappedQueue A)) - (Q 0 Nil E 0 Nil)) - -(define (bs-isEmpty [m : (BootstrappedQueue A)] → Bool) - (match m with - [E -> #t] - [Q a b c d e -> #f])) - -(define (bs-snoc [m : (BootstrappedQueue A)] [x : A] → (BootstrappedQueue A)) - (match m with - [E -> (Q 1 (∷ x Nil) E 0 Nil)] - [Q lenfm f m lenr r -> (bs-checkQ lenfm f m (+ 1 lenr) (∷ x r))])) - -(define (bs-head [m : (BootstrappedQueue A)] → (Option A)) - (match m with - [E -> None] - [Q lenfm f m lenr r -> - (match f with - [Nil -> None] - [∷ x f* -> (Some x)])])) - -(define (bs-tail [m : (BootstrappedQueue A)] → (Option (BootstrappedQueue A))) - (match m with - [E -> None] - [Q lenfm f m lenr r -> - (match f with - [Nil -> None] - [∷ _x f* -> (Some (bs-checkQ (- lenfm 1) f* m lenr r))])])) - -;; ----------------------------------------------------------------------------- - -(define sample-bs - (foldl (λ ([acc : (BootstrappedQueue Int)] [x : Int]) (bs-snoc acc x)) (bs-empty) digit*)) - -(check-type - (bs-isEmpty (E {Int})) - : Bool - ⇒ #t) - -(check-type - (bs-isEmpty sample-bs) - : Bool - ⇒ #f) - -(check-type - (bs-head sample-bs) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (bs-head (bs-snoc sample-bs 10)) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (match (bs-tail sample-bs) with - [None -> None] - [Some bs -> (bs-head bs)]) - : (Option Int) - ⇒ (Some 2)) - -;; ============================================================================= -;; === Implicit Queue - -(define-type (Digit A) - [Zero] - [One A] - [Two A A]) - -(define-type (ImplicitQueue A) - [Shallow (Digit A)] - [Deep (Digit A) (ImplicitQueue (× A A)) (Digit A)]) - -(define (iq-empty → (ImplicitQueue A)) - (Shallow Zero)) - -(define (iq-isEmpty [iq : (ImplicitQueue A)] → Bool) - (match iq with - [Shallow d -> - (match d with - [Zero -> #t] - [One x -> #f] - [Two x y -> #f])] - [Deep a b c -> #f])) - -(define (iq-snoc [iq : (ImplicitQueue A)] [y : A] → (ImplicitQueue A)) - (match iq with - [Shallow d -> - (match d with - [Zero -> (Shallow (One y))] - [One x -> (Deep (Two x y) (Shallow Zero) Zero)] - [Two x y -> ;; Error - (Shallow Zero)])] - [Deep f m d -> - (match d with - [Zero -> (Deep f m (One y))] - [One x -> (Deep f (iq-snoc m (tup x y)) Zero)] - [Two x y -> (Shallow Zero)])])) ;; Error - -(define (iq-head [iq : (ImplicitQueue A)] → (Option A)) - (match iq with - [Shallow d -> - (match d with - [Zero -> None] - [One x -> (Some x)] - [Two x y -> (Some x)])] ;; Error - [Deep d m r -> - (match d with - [Zero -> None] ;; Error - [One x -> (Some x)] - [Two x y -> (Some x)])])) - -(define (iq-tail [iq : (ImplicitQueue A)] → (Option (ImplicitQueue A))) - (match iq with - [Shallow d -> - (match d with - [Zero -> None] - [One x -> (Some (Shallow Zero))] - [Two x y -> None])] ;; Error - [Deep d m r -> - (match d with - [Zero -> None] ;; Error - [One x -> - (match (iq-head m) with - [None -> (Some (Shallow r))] - [Some yz -> - (match yz with - [y z -> - (match (iq-tail m) with - [None -> None] - [Some tl -> - (Some (Deep (Two y z) tl r))])])])] - [Two x y -> (Some (Deep (One y) m r))])])) - -;; ----------------------------------------------------------------------------- - -(define sample-iq - (foldl (λ ([acc : (ImplicitQueue Int)] [x : Int]) (iq-snoc acc x)) (iq-empty) digit*)) - -(check-type - (iq-isEmpty (Shallow (Zero {Int}))) - : Bool - ⇒ #t) - -(check-type - (iq-isEmpty sample-iq) - : Bool - ⇒ #f) - -(check-type - (iq-head sample-iq) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (iq-head (iq-snoc sample-iq 10)) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (match (iq-tail sample-iq) with - [None -> None] - [Some iq -> (iq-head iq)]) - : (Option Int) - ⇒ (Some 2)) - -;; ============================================================================= -;; === Bankers Deque - -(define-type (BankersDeque A) - [BD Int (List A) Int (List A)]) - -(define c 3) - -(define (bd-check [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (BankersDeque A)) - (if (> lenf (+ c (+ lenr 1))) - (let* ([i (div (+ lenf lenr) 2)] - [j (- (+ lenf lenr) i)] - [r2 (take j r)] - [f2 (append f (reverse (drop j r)))]) - (BD i f2 j r2)) - (if (> lenr (+ 1 (* c lenf))) - (let* ([j (div (+ lenf lenr) 2)] - [i (- (+ lenr lenf) j)] - [r2 (take j r)] - [f2 (append f (reverse (drop j r)))]) - (BD i f2 j r2)) - (BD lenf f lenr r)))) - -(define (bd-empty → (BankersDeque A)) - (BD 0 Nil 0 Nil)) - -(define (bd-isEmpty [bd : (BankersDeque A)] → Bool) - (match bd with - [BD lenf f lenr r -> (= 0 (+ lenf lenr))])) - -(define (bd-cons [x : A] [bd : (BankersDeque A)] → (BankersDeque A)) - (match bd with - [BD lenf f lenr r -> (bd-check (+ lenf 1) (∷ x f) lenr r)])) - -(define (bd-head [bd : (BankersDeque A)] → (Option A)) - (match bd with - [BD lenf f lenr r -> - (match f with - [Nil -> None] - [∷ x f2 -> (Some x)])])) - -(define (bd-tail [bd : (BankersDeque A)] → (Option (BankersDeque A))) - (match bd with - [BD lenf f lenr r -> - (match f with - [Nil -> None] - [∷ x f2 -> (Some (bd-check (- lenf 1) f2 lenr r))])])) - -(define (bd-snoc [bd : (BankersDeque A)] [x : A] → (BankersDeque A)) - (match bd with - [BD lenf f lenr r -> (bd-check lenf f (+ lenr 1) (∷ x r))])) - -(define (bd-last [bd : (BankersDeque A)] → (Option A)) - (match bd with - [BD lenf f lenr r -> - (match r with - [Nil -> None] - [∷ x r2 -> (Some x)])])) - -(define (bd-init [bd : (BankersDeque A)] → (Option (BankersDeque A))) - (match bd with - [BD lenf f lenr r -> - (match r with - [Nil -> None] - [∷ x r -> (Some (bd-check lenf f (- lenr 1) r))])])) - -;; ----------------------------------------------------------------------------- - -(define sample-bd - (foldl (λ ([acc : (BankersDeque Int)] [x : Int]) (bd-snoc acc x)) (bd-empty) digit*)) - -(check-type - (bd-isEmpty (BD 0 (Nil {Int}) 0 (Nil {Int}))) - : Bool - ⇒ #t) - -(check-type - (bd-isEmpty sample-bd) - : Bool - ⇒ #f) - -(check-type - (bd-head sample-bd) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (bd-last sample-bd) - : (Option Int) - ⇒ (Some 9)) - -(check-type - (bd-head (bd-snoc sample-bd 10)) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (bd-head (bd-cons 10 sample-bd)) - : (Option Int) - ⇒ (Some 10)) - -(check-type - (match (bd-tail sample-bd) with - [None -> None] - [Some bd -> (bd-head bd)]) - : (Option Int) - ⇒ (Some 2)) - -(check-type - (match (bd-init sample-bd) with - [None -> None] - [Some bd -> (bd-last bd)]) - : (Option Int) - ⇒ (Some 8)) - -;; ============================================================================= -;; === Simple Catenable Deque - -(define-type (SimpleCatDeque a) - [SShallow (BankersDeque a)] - [SDeep (BankersDeque a) (SimpleCatDeque (BankersDeque a)) (BankersDeque a)]) - -(define (bd-tooSmall [d : (BankersDeque A)] → Bool) - (if (bd-isEmpty d) - #t - (match (bd-tail d) with - [None -> #t] - [Some d -> (bd-isEmpty d)]))) - -(define (bd-dappendL [d1 : (BankersDeque A)] [d2 : (BankersDeque A)] → (BankersDeque A)) - (match (bd-head d1) with - [None -> d2] - [Some h -> (bd-cons h d2)])) - -(define (bd-dappendR [d1 : (BankersDeque A)] [d2 : (BankersDeque A)] → (BankersDeque A)) - (match (bd-head d2) with - [None -> d1] - [Some h -> (bd-snoc d1 h)])) - -(define (scd-empty → (SimpleCatDeque A)) - (SShallow (bd-empty))) - -(define (scd-isEmpty [scd : (SimpleCatDeque A)] → Bool) - (match scd with - [SShallow d -> (bd-isEmpty d)] - [SDeep a b c -> #f])) - -(define (scd-cons [x : A] [scd : (SimpleCatDeque A)] → (SimpleCatDeque A)) - (match scd with - [SShallow d -> (SShallow (bd-cons x d))] - [SDeep f m r -> (SDeep (bd-cons x f) m r)])) - -(define (scd-snoc [scd : (SimpleCatDeque A)] [x : A] → (SimpleCatDeque A)) - (match scd with - [SShallow d -> (SShallow (bd-snoc d x))] - [SDeep f m r -> (SDeep f m (bd-snoc f x))])) - -(define (scd-head [scd : (SimpleCatDeque A)] → (Option A)) - (match scd with - [SShallow d -> (bd-head d)] - [SDeep f m r -> (bd-head f)])) - -(define (scd-last [scd : (SimpleCatDeque A)] → (Option A)) - (match scd with - [SShallow d -> (bd-last d)] - [SDeep f m r -> (bd-last r)])) - -(define (scd-tail [scd : (SimpleCatDeque A)] → (Option (SimpleCatDeque A))) - (match scd with - [SShallow d -> - (match (bd-tail d) with - [None -> None] - [Some t -> (Some (SShallow t))])] - [SDeep f m r -> - (match (bd-tail f) with - [None -> None] - [Some f2 -> - (if (not (bd-tooSmall f2)) - (Some (SDeep f2 m r)) - (if (scd-isEmpty m) - (Some (SShallow (bd-dappendL f2 r))) - (match (scd-head m) with - [None -> None] - [Some hm -> - (match (scd-tail m) with - [None -> None] - [Some tm -> - (Some (SDeep (bd-dappendL f2 hm) tm r))])])))])])) - -(define (scd-init [scd : (SimpleCatDeque A)] → (Option (SimpleCatDeque A))) - (match scd with - [SShallow d -> - (match (bd-init d) with - [None -> None] - [Some t -> (Some (SShallow t))])] - [SDeep f m r -> - (match (bd-init r) with - [None -> None] - [Some r2 -> - (if (not (bd-tooSmall r2)) - (Some (SDeep f m r2)) - (if (scd-isEmpty m) - (Some (SShallow (bd-dappendR r r2))) - (match (scd-last m) with - [None -> None] - [Some lm -> - (match (scd-init m) with - [None -> None] - [Some im -> - (Some (SDeep f im (bd-dappendR lm r2)))])])))])])) - -(define (scd-++ [scd1 : (SimpleCatDeque A)] [scd2 : (SimpleCatDeque A)] → (SimpleCatDeque A)) - (match scd1 with - [SShallow d1 -> - (match scd2 with - [SShallow d2 -> - (if (bd-tooSmall d1) - (SShallow (bd-dappendL d1 d2)) - (if (bd-tooSmall d2) - (SShallow (bd-dappendR d1 d2)) - (SDeep d1 (scd-empty) d2)))] - [SDeep f m r -> - (if (bd-tooSmall d1) - (SDeep (bd-dappendL d1 f) m r) - (SDeep d1 (scd-cons f m) r))])] - [SDeep f1 m1 r1 -> - (match scd2 with - [SShallow d2 -> - (if (bd-tooSmall d2) - (SDeep f1 m1 (bd-dappendR r1 d2)) - (SDeep f1 (scd-snoc m1 r1) d2))] - [SDeep f2 m2 r2 -> - (SDeep f1 (scd-++ (scd-snoc m1 f1) (scd-cons r1 m2)) r2)])])) - -(define (scd->list [scd : (SimpleCatDeque A)] → (List A)) - (match (scd-head scd) with - [None -> Nil] - [Some hd -> - (match (scd-tail scd) with - [None -> (∷ hd Nil)] - [Some tl -> (∷ hd (scd->list tl))])])) - -;; ----------------------------------------------------------------------------- - -(define sample-scd - (foldl (λ ([acc : (SimpleCatDeque Int)] [x : Int]) (scd-snoc acc x)) (scd-empty) digit*)) - -(define (empty-sample → (SimpleCatDeque Int)) - (scd-empty)) - -(check-type - (scd-isEmpty (SShallow (BD 0 (Nil {Int}) 0 (Nil {Int})))) - : Bool - ⇒ #t) - -(check-type - (scd-isEmpty sample-scd) - : Bool - ⇒ #f) - -(check-type - (scd-head sample-scd) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (scd-head (empty-sample)) - : (Option Int) - ⇒ None) - -(check-type - (scd-last sample-scd) - : (Option Int) - ⇒ (Some 9)) - -(check-type - (scd-last (empty-sample)) - : (Option Int) - ⇒ None) - -(check-type - (scd-head (scd-snoc sample-scd 10)) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (scd-head (scd-cons 10 sample-scd)) - : (Option Int) - ⇒ (Some 10)) - -(check-type - (match (scd-tail sample-scd) with - [None -> None] - [Some scd -> (scd-head scd)]) - : (Option Int) - ⇒ (Some 2)) - -(check-type - (scd-tail (empty-sample)) - : (Option (SimpleCatDeque Int)) - ⇒ None) - -(check-type - (match (scd-init sample-scd) with - [None -> None] - [Some scd -> (scd-last scd)]) - : (Option Int) - ⇒ (Some 8)) - -(check-type - (scd-init (empty-sample)) - : (Option (SimpleCatDeque Int)) - ⇒ None) - -(check-type - (match (scd-head (scd-++ (scd-cons 1 (scd-empty)) (empty-sample))) with - [None -> None] - [Some i -> (Some i)]) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (match (scd-head (scd-++ (empty-sample) (scd-cons 2 (scd-empty)))) with - [None -> None] - [Some scd -> (Some scd)]) - : (Option Int) - ⇒ (Some 2)) - -(check-type - (match (scd-tail (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty)))) with - [None -> None] - [Some scd -> (scd-head scd)]) - : (Option Int) - ⇒ (Some 2)) - -(define (scd-ref [n : Int] [scd : (SimpleCatDeque A)] → (Option A)) - (if (< n 1) - (scd-head scd) - (match (scd-tail scd) with - [None -> None] - [Some tl -> (scd-ref (- n 1) tl)]))) - -(check-type - (scd-ref 2 - (scd-++ - (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) - (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty))))) - : (Option Int) - ⇒ (Some 3)) - -(check-type - (scd-ref 0 - (scd-++ - (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) - (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty))))) - : (Option Int) - ⇒ (Some 1)) - -(check-type - (scd->list - (scd-++ - (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) - (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty))))) - : (List Int) - ⇒ (∷ 1 (∷ 2 (∷ 3 (∷ 4 Nil))))) - -(check-type - (scd-ref 1 - (scd-++ - (scd-++ - (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) - (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty)))) - (scd-++ - (scd-++ (scd-cons 5 (scd-empty)) (scd-cons 6 (scd-empty))) - (scd-++ (scd-cons 7 (scd-empty)) (scd-cons 8 (scd-empty)))))) - : (Option Int) - ⇒ (Some 2)) - -(check-type - (scd-ref 3 - (scd-++ - (scd-++ - (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) - (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty)))) - (scd-++ - (scd-++ (scd-cons 5 (scd-empty)) (scd-cons 6 (scd-empty))) - (scd-++ (scd-cons 7 (scd-empty)) (scd-cons 8 (scd-empty)))))) - : (Option Int) - ⇒ (Some 4)) - -;; TODO this is a bug, but at least we have the right types in MLish -;(check-type -; (scd->list -; (scd-++ -; (scd-++ -; (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) -; (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty)))) -; (scd-++ -; (scd-++ (scd-cons 5 (scd-empty)) (scd-cons 6 (scd-empty))) -; (scd-++ (scd-cons 7 (scd-empty)) (scd-cons 8 (scd-empty)))))) -; : (List Int) -; ⇒ (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 Nil))))))))) - -;; ============================================================================= -;; === Binary Random Access List - -(define-type (Tree A) - (Leaf A) - (Node Int (Tree A) (Tree A))) - -(define-type (BLDigit A) - (BLZero) - (BLOne (Tree A))) - -(define-type (BinaryList A) - (BL (List (BLDigit A)))) - -(define (size (t : (Tree A)) → Int) - (match t with - (Leaf x -> 1) - (Node w t1 t2 -> w))) - -(define (link (t1 : (Tree A)) (t2 : (Tree A)) → (Tree A)) - (Node (+ (size t1) (size t2)) t1 t2)) - -(define (consTree (t : (Tree A)) (x* : (List (BLDigit A))) → (List (BLDigit A))) - (match x* with - (Nil -> (∷ (BLOne t) Nil)) - (∷ h ts -> - (match h with - (BLZero -> (∷ (BLOne t) ts)) - (BLOne t2 -> (∷ BLZero (consTree (link t t2) ts))))))) - - -;; TODO τ_e bad syntax when using `match2` -(define (unconsTree (d* : (List (BLDigit A))) → (Option (× (Tree A) (List (BLDigit A))))) - (match d* with - (Nil -> None) - (∷ d*-hd d*-tl -> - (match d*-hd with - (BLOne t -> - (match d*-tl with - (Nil -> (Some (tup t Nil))) - (∷ a b -> (Some (tup t (∷ BLZero d*-tl)))))) - (BLZero -> - (match (unconsTree d*-tl) with - (None -> None) - (Some udt -> - (match udt with - (a ts -> - (match a with - (Leaf x -> None) - (Node x t1 t2 -> - (Some (tup t1 (∷ (BLOne t2) ts)))))))))))))) - -(define (bl-empty → (BinaryList A)) - (BL Nil)) - -(define (bl-isEmpty (b : (BinaryList A)) → Bool) - (match b with - (BL x* -> - (match x* with - (Nil -> #t) - (∷ a b -> #f))))) - -(define (bl-cons (x : A) (b : (BinaryList A)) → (BinaryList A)) - (match b with - (BL ts -> (BL (consTree (Leaf x) ts))))) - -(define (bl-head (b : (BinaryList A)) → (Option A)) - (match b with - (BL ts -> - (match (unconsTree ts) with - (None -> None) - (Some xy -> - (match xy with - (x y -> - (match x with - (Leaf x -> (Some x)) - (Node a b c -> None))))))))) - -(define (bl-tail (b : (BinaryList A)) → (Option (BinaryList A))) - (match b with - (BL ts -> - (match (unconsTree ts) with - (None -> None) - (Some xy -> - (match xy with - (x ts2 -> (Some (BL ts2))))))))) - -(define (bl-lookup (i : Int) (b : (BinaryList A)) → (Option A)) - (match b with - [BL ts -> - (look i ts)])) - -(define (look [i : Int] [ts : (List (BLDigit A))] → (Option A)) - (match ts with - [Nil -> None] - [∷ h ts -> - (match h with - [BLZero -> - (look i ts)] - [BLOne t -> - (let ((size-t (size t))) - (if (< i size-t) - (lookTree i t) - (look (- i size-t) ts)))])])) - -(define (lookTree (i : Int) (t : (Tree A)) → (Option A)) - (match t with - [Leaf x -> - (if (= 0 i) - (Some x) - None)] - [Node w t1 t2 -> - (let ((w/2 (div w 2))) - (if (< i w/2) - (lookTree i t1) - (lookTree (- i w/2) t2)))])) - -(define (bl-update (i : Int) (y : A) (b : (BinaryList A)) → (Option (BinaryList A))) - (match b with - [BL ts -> - (match (upd i y ts) with - (None -> None) - (Some x -> (Some (BL x))))])) - -(define (upd (i : Int) (y : A) (b : (List (BLDigit A))) → (Option (List (BLDigit A)))) - (match b with - [Nil -> None] - [∷ h ts -> - (match h with - [BLZero -> - (match (upd i y ts) with - (None -> None) - (Some x -> (Some (∷ BLZero x))))] - [BLOne t -> - (let ((size-t (size t))) - (if (< i size-t) - (match (updTree i y t) with - (None -> None) - (Some x -> (Some (∷ (BLOne x) ts)))) - (match (upd (- i size-t) y ts) with - (None -> None) - (Some x -> (Some (∷ (BLOne t) x))))))])])) - -(define (updTree (i : Int) (y : A) (t : (Tree A)) → (Option (Tree A))) - (match t with - (Leaf x -> - (if (= 0 i) - (Some (Leaf y)) - None)) - (Node w t1 t2 -> - (let ((w/2 (div w 2))) - (if (< i w/2) - (match (updTree i y t1) with - (None -> None) - (Some x -> (Some (Node w x t2)))) - (match (updTree (- i w/2) y t2) with - (None -> None) - (Some x -> (Some (Node w t1 x))))))))) - -(define (list->bl-list (x* : (List A)) → (BinaryList A)) - (match x* with - (Nil -> (bl-empty)) - (∷ x x* -> (bl-cons x (list->bl-list x*))))) - -;; ============================================================================= - -(define bl-digit* - (list->bl-list (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil))))))))))) - -(define (bl-nil → (BinaryList Int)) - (list->bl-list Nil)) - -(check-type - (bl-isEmpty (bl-nil)) - : Bool - ⇒ #t) - -(check-type - (bl-isEmpty bl-digit*) - : Bool - ⇒ #f) - -(check-type - (match (bl-head bl-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 1) - -(check-type - (match (bl-tail bl-digit*) with - (None -> 0) - (Some x -> - (match (bl-head x) with - (None -> 0) - (Some y -> y)))) - : Int - ⇒ 2) - -(check-type - (match (bl-lookup 7 bl-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 8) - -(check-type - (match (bl-lookup 8 bl-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 9) - -(check-type - (bl-lookup -111 bl-digit*) - : (Option Int) - ⇒ None) - -(check-type - (match (bl-update 3 99 bl-digit*) with - (None -> None) - (Some x -> (bl-lookup 3 x))) - : (Option Int) - ⇒ (Some 99)) - -(check-type - (match (bl-update 0 222 bl-digit*) with - (None -> None) - (Some x -> (bl-head x))) - : (Option Int) - ⇒ (Some 222)) - -(check-type - (bl-update 83 1 bl-digit*) - : (Option (BinaryList Int)) - ⇒ None) - -;; ============================================================================= -;; === Skew Binary Random Access Lists - -(define-type (ATree A) - (ALeaf A) - (ANode A (ATree A) (ATree A))) - -(define-type (SkewList A) - (SL (List (× Int (ATree A))))) - -(define (sb-empty → (SkewList A)) - (SL Nil)) - -(define (sb-isEmpty (sl : (SkewList A)) → Bool) - (match sl with - (SL xs -> - (match xs with - (Nil -> #t) - (∷ a b -> #f))))) - -(define (sb-cons (x : A) (sl : (SkewList A)) → (SkewList A)) - (match sl with - (SL ts -> - (let ((base-case (SL (∷ (tup 1 (ALeaf x)) ts)))) - (match ts with - (Nil -> base-case) - (∷ w1t1 ts -> - (match ts with - (Nil -> base-case) - (∷ w2t2 ts -> - (match w1t1 with - (w1 t1 -> - (match w2t2 with - (w2 t2 -> - (if (= w1 w2) - (SL (∷ (tup (+ 1 (+ w1 w2)) (ANode x t1 t2)) ts)) - base-case))))))))))))) - -(define (sb-head (sl : (SkewList A)) → (Option A)) - (match sl with - (SL ts -> - (match ts with - (Nil -> None) - (∷ w1t1 ts -> - (match w1t1 with - (w1 t1 -> - (match t1 with - (ALeaf x -> - (if (= w1 1) - (Some x) - None)) ;; Invariant error - (ANode x t1 t2 -> - (Some x)))))))))) - -(define (sb-tail (sl : (SkewList A)) → (Option (SkewList A))) - (match sl with - (SL ts -> - (match ts with - (Nil -> None) - (∷ w1t1 ts -> - (match w1t1 with - (w1 t1 -> - (match t1 with - (ALeaf x -> - (if (= 1 w1) - (Some (SL ts)) - None)) ;; Invariant - (ANode x t1 t2 -> - (let ((w1/2 (div w1 2))) - (Some (SL (∷ (tup w1/2 t1) (∷ (tup w1/2 t2) ts)))))))))))))) - -(define (sb-lookup (i : Int) (sl : (SkewList A)) → (Option A)) - (match sl with - (SL ts -> - (sb-look i ts)))) - -(define (sb-look (i : Int) (ts : (List (× Int (ATree A)))) → (Option A)) - (match ts with - (Nil -> None) ;; Bad subscript - (∷ wt ts -> - (match wt with - (w t -> - (if (< i w) - (sb-lookTree w i t) - (sb-look (- i w) ts))))))) - -(define (sb-lookTree (w : Int) (i : Int) (t : (ATree A)) → (Option A)) - (match t with - (ALeaf x -> - (if (and (= w 1) (= i 0)) - (Some x) - None)) - (ANode x t1 t2 -> - (if (= 0 i) - (Some x) - (let ((w/2 (div w 2))) - (if (<= i w/2) - (sb-lookTree w/2 (- i 1) t1) - (sb-lookTree w/2 (- (- i 1) w/2) t2))))))) - -(define (sb-update (i : Int) (y : A) (sl : (SkewList A)) → (Option (SkewList A))) - (match sl with - (SL ts -> - (match (sb-upd i y ts) with - (None -> None) - (Some ts -> (Some (SL ts))))))) - -(define (sb-upd (i : Int) (y : A) (ts : (List (× Int (ATree A)))) → (Option (List (× Int (ATree A))))) - (match ts with - (Nil -> None) - (∷ wt ts -> - (match wt with - (w t -> - (if (< i w) - (match (sb-updTree w i y t) with - (None -> None) - (Some x -> (Some (∷ (tup w x) ts)))) - (match (sb-upd (- i w) y ts) with - (None -> None) - (Some x -> (Some (∷ (tup w t) x)))))))))) - -(define (sb-updTree (w : Int) (i : Int) (y : A) (t : (ATree A)) → (Option (ATree A))) - (match t with - (ALeaf x -> - (if (and (= 1 w) (= 0 i)) - (Some (ALeaf y)) - None)) ;; Invariant error - (ANode x t1 t2 -> - (if (= 0 i) - (Some (ANode y t1 t2)) - (let ((w/2 (div w 2))) - (if (<= i w/2) - (match (sb-updTree w/2 (- i 1) y t1) with - (None -> None) - (Some z -> (Some (ANode x z t2)))) - (match (sb-updTree w/2 (- (- i 1) w/2) y t2) with - (None -> None) - (Some z -> (Some (ANode x t1 z)))))))))) - -(define (list->sb-list (x* : (List A)) → (SkewList A)) - (match x* with - (Nil -> (sb-empty)) - (∷ h t -> (sb-cons h (list->sb-list t))))) - -;; ============================================================================= - -(define sb-digit* - (list->sb-list (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil))))))))))) - -(define (sb-nil → (SkewList Int)) - (list->sb-list Nil)) - -(check-type - (sb-isEmpty (sb-nil)) - : Bool - ⇒ #t) - -(check-type - (sb-isEmpty sb-digit*) - : Bool - ⇒ #f) - -(check-type - (match (sb-head sb-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 1) - -(check-type - (match (sb-tail sb-digit*) with - (None -> 0) - (Some x -> - (match (sb-head x) with - (None -> 0) - (Some y -> y)))) - : Int - ⇒ 2) - -(check-type - (match (sb-lookup 7 sb-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 8) - -(check-type - (match (sb-lookup 8 sb-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 9) - -(check-type - (sb-lookup -111 sb-digit*) - : (Option Int) - ⇒ None) - -(check-type - (match (sb-update 3 99 sb-digit*) with - (None -> None) - (Some x -> (sb-lookup 3 x))) - : (Option Int) - ⇒ (Some 99)) - -(check-type - (match (sb-update 0 222 sb-digit*) with - (None -> None) - (Some x -> (sb-head x))) - : (Option Int) - ⇒ (Some 222)) - -(check-type - (sb-update 83 1 sb-digit*) - : (Option (SkewList Int)) - ⇒ None) - -;; ============================================================================= -;; === Alt Binary Random Access List - -(define-type (BinaryRAList A) - (ABLNil) - (ABLZero (BinaryRAList (× A A))) - (ABLOne A (BinaryRAList (× A A)))) - -(define (abl-uncons (bl : (BinaryRAList A)) → (Option (× A (BinaryRAList A)))) - (match bl with - (ABLNil -> None) - (ABLOne x ps -> - (Some (match ps with - (ABLNil -> (tup x ABLNil)) - (ABLOne y ps2 -> (tup x (ABLZero ps))) - (ABLZero ps2 -> (tup x (ABLZero ps)))))) - (ABLZero ps -> - (match (abl-uncons ps) with - (None -> None) - (Some xyps2 -> - (match xyps2 with - (xy ps2 -> - (match xy with - (x y -> (Some (tup x (ABLOne y ps2)))))))))))) - -(define (abl-fupdate (f : (→ A A)) (i : Int) (bl : (BinaryRAList A)) → (Option (BinaryRAList A))) - (match bl with - (ABLNil -> None) - (ABLOne x ps -> - (if (= 0 i) - (Some (ABLOne (f x) ps)) - (match (abl-fupdate f (- i 1) (ABLZero ps)) with - (None -> None) - (Some z -> (Some (abl-cons x z)))))) - (ABLZero ps -> - (let ((f2 (if (= 0 (mod i 2)) - (λ ([xy : (× A A)]) - (match xy with (x y -> (tup (f x) y)))) - (λ ([xy : (× A A)]) - (match xy with (x y -> (tup x (f y)))))))) - (match (abl-fupdate f2 (div i 2) ps) with - (None -> None) - (Some z -> (Some (ABLZero z)))))))) - -(define (aabl-empty → (BinaryRAList A)) - ABLNil) - -(define (abl-isEmpty (bl : (BinaryRAList A)) → Bool) - (match bl with - (ABLNil -> #t) - (ABLOne a b -> #f) - (ABLZero a -> #f))) - -(define (abl-cons (x : A) (bl : (BinaryRAList A)) → (BinaryRAList A)) - (match bl with - (ABLNil -> (ABLOne x ABLNil)) - (ABLZero ps -> (ABLOne x ps)) - (ABLOne y ps -> (ABLZero (abl-cons (tup x y) ps))))) - -(define (abl-head (bl : (BinaryRAList A)) → (Option A)) - (match (abl-uncons bl) with - (None -> None) - (Some xy -> - (match xy with - (x y -> (Some x)))))) - -(define (abl-tail (bl : (BinaryRAList A)) → (Option (BinaryRAList A))) - (match (abl-uncons bl) with - (None -> None) - (Some xy -> - (match xy with - (x y -> (Some y)))))) - -(define (abl-lookup (i : Int) (bl : (BinaryRAList A)) → (Option A)) - (if (< i 0) - None - (abl-lookup/natural i bl))) - -(define (abl-lookup/natural (i : Int) (bl : (BinaryRAList A)) → (Option A)) - (match bl with - (ABLNil -> None) - (ABLOne x ps -> - (if (= 0 i) - (Some x) - (abl-lookup/natural (- i 1) (ABLZero ps)))) - (ABLZero ps -> - (match (abl-lookup/natural (div i 2) ps) with - (None -> None) - (Some xy -> - (match xy with - (x y -> - (if (= 0 (mod i 2)) - (Some x) - (Some y))))))))) - -(define (abl-update (i : Int) (y : A) (bl : (BinaryRAList A)) → (Option (BinaryRAList A))) - (abl-fupdate (λ ([x : A]) y) i bl)) - -(define (list->abl-list (xs : (List A)) → (BinaryRAList A)) - (match xs with - (Nil -> (aabl-empty)) - (∷ a b -> (abl-cons a (list->abl-list b))))) - -;; ============================================================================= - -(define abl-digit* - (list->abl-list (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil))))))))))) - -(define (abl-nil → (BinaryRAList Int)) - (list->abl-list Nil)) - -(check-type - (abl-isEmpty (abl-nil)) - : Bool - ⇒ #t) - -(check-type - (abl-isEmpty abl-digit*) - : Bool - ⇒ #f) - -(check-type - (match (abl-head abl-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 1) - -(check-type - (match (abl-tail abl-digit*) with - (None -> 0) - (Some x -> - (match (abl-head x) with - (None -> 0) - (Some y -> y)))) - : Int - ⇒ 2) - -(check-type - (match (abl-lookup 7 abl-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 8) - -(check-type - (match (abl-lookup 8 abl-digit*) with - (None -> 0) - (Some x -> x)) - : Int - ⇒ 9) - -(check-type - (abl-lookup -111 abl-digit*) - : (Option Int) - ⇒ None) - -(check-type - (match (abl-update 3 99 abl-digit*) with - (None -> None) - (Some x -> (abl-lookup 3 x))) - : (Option Int) - ⇒ (Some 99)) - -(check-type - (match (abl-update 0 222 abl-digit*) with - (None -> None) - (Some x -> (abl-head x))) - : (Option Int) - ⇒ (Some 222)) - -(check-type - (abl-update 83 1 abl-digit*) - : (Option (BinaryRAList Int)) - ⇒ None) - diff --git a/tapl/tests/mlish/chameneos.mlish b/tapl/tests/mlish/chameneos.mlish @@ -1,129 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define-type Color Red Yellow Blue) - -(define-type (Option X) None (Some X)) - -(define-type-alias Meet - (× (Channel (Option (× Color String))) - (× Color String))) - -(define-type-alias Result (× Int Int)) - -(define-type-alias MeetChan (Channel Meet)) -(define-type-alias ResultChan (Channel Result)) - -(typecheck-fail (channel-put (make-channel {Bool}) 1) - #:with-msg "channel-put: type mismatch: expected Bool, given Int\n *expression: 1") - -(define (change [c1 : Color] [c2 : Color] -> Color) - (match c1 with - [Red -> - (match c2 with - [Blue -> Yellow] - [Yellow -> Blue] - [Red -> c1])] - [Yellow -> - (match c2 with - [Blue -> Red] - [Red -> Blue] - [Yellow -> c1])] - [Blue -> - (match c2 with - [Yellow -> Red] - [Red -> Yellow] - [Blue -> c1])])) - -(check-type (change Red Blue) : Color -> Yellow) -(check-type (change Yellow Red) : Color -> Blue) -(check-type (change Blue Blue) : Color -> Blue) - -(define NONE (None {(× Color String)})) - -(define (get+put [ch-meet : MeetChan] -> Unit) - (match (channel-get ch-meet) with - [ch v -> - (begin (channel-put ch NONE) - (get+put ch-meet))])) - -(define (swap [ch-meet : MeetChan] [n : Int] -> Unit) - (if (zero? n) - (get+put ch-meet) - (match (channel-get ch-meet) with - [ch1 v1 -> - (match (channel-get ch-meet) with - [ch2 v2 -> - (begin (channel-put ch1 (Some v2)) - (channel-put ch2 (Some v1)) - (swap ch-meet (sub1 n)))])]))) - - -(define (place [ch-meet : MeetChan] [n : Int] -> Thread) - (thread (λ () (swap ch-meet n)))) - -(define (rand-name -> String) - (string (integer->char (random 256)))) - -(define (sleeper [ch-meet : MeetChan] [ch-res : ResultChan] - [ch : (Channel (Option (× Color String)))] - [name : String] [c : Color] [met : Int] [same : Int] - -> Unit) - (begin - (channel-put ch-meet (tup ch (tup c name))) - (match (channel-get ch) with - [Some c+s -> - (match c+s with - [other-col other-name -> - (begin - (sleep 0) - (sleeper - ch-meet ch-res ch - name (change c other-col) - (add1 met) (+ same (if (string=? name other-name) 1 0))))])] - [None -> (channel-put ch-res (tup met same))]))) - -(define (creature [c : Color] [ch-meet : MeetChan] [ch-res : ResultChan] - -> Thread) - (thread - (λ () - (let ([ch (make-channel {(Option (× Color String))})] - [name (rand-name)]) - (sleeper ch-meet ch-res ch name c 0 0))))) - -(define (map [f : (→ X Y)] [lst : (List X)] -> (List Y)) - (if (isnil lst) - nil - (cons (f (head lst)) (map f (tail lst))))) - -(define (go [n : Int] [inits : (List Color)] -> (List Result)) - (let* ([ch-res (make-channel {Result})] - [ch-meet (make-channel {Meet})] - [start (place ch-meet n)] - [ths (map (λ ([c : Color]) (creature c ch-meet ch-res)) inits)]) - (map (λ ([c : Color]) (channel-get ch-res)) inits))) - -(define res1 (go 100 (list Blue Red Yellow))) - -(define (check-res1 [r : Result] -> Bool) - (match r with - [met same -> (or (= met 66) (= met 67))])) - -(check-type (length res1) : Int -> 3) - -(check-type (check-res1 (list-ref res1 0)) : Bool -> #t) -(check-type (check-res1 (list-ref res1 1)) : Bool -> #t) -(check-type (check-res1 (list-ref res1 2)) : Bool -> #t) - ;; -> (list (list 67 0) - ;; (list 66 0) - ;; (list 67 0))) - -(check-type (map (λ ([x : Result]) (proj x 0)) - (go 1000 (list Blue Red Yellow Red Yellow Blue))) - : (List Int) -> (list 333 333 333 333 334 334)) - ;; -> (list (list 333 0) - ;; (list 333 0) - ;; (list 333 0) - ;; (list 333 0) - ;; (list 334 0) - ;; (list 334 0))) diff --git a/tapl/tests/mlish/fannkuch.mlish b/tapl/tests/mlish/fannkuch.mlish @@ -1,54 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define (fannkuch [n : Int] -> Int) - (let ([pi (list->vector - (for/list ([i (in-range n)]) i))] - [tmp (make-vector n)] - [count (make-vector n)]) - (let loop : Int ([flips 0] [perms 0] [r n]) - #;(when (< perms 30) - (for ([x (in-vector pi)]) - (display (add1 x))) - (newline)) - (for ([i (in-range r)]) - (vector-set! count i (add1 i))) - (let ((flips2 (max (count-flips pi tmp) flips))) - (let loop2 : Int ([r 1]) - (if (= r n) - flips2 - (let ((perm0 (vector-ref pi 0))) - (for ([i (in-range r)]) - (vector-set! pi i (vector-ref pi (add1 i)))) - (vector-set! pi r perm0) - (vector-set! count r (sub1 (vector-ref count r))) - (cond - [(<= (vector-ref count r) 0) - (loop2 (add1 r))] - [else (loop flips2 (add1 perms) r)])))))))) - -(define (count-flips [pi : (Vector Int)] [rho : (Vector Int)] -> Int) - (vector-copy! rho 0 pi) - (let loop : Int ([i 0]) - (if (= (vector-ref rho 0) 0) - i - (begin - (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0))) - (loop (add1 i)))))) - -(define (vector-reverse-slice! [v : (Vector X)] [i : Int] [j : Int] -> Unit) - (let loop : Unit ([i i] [j (sub1 j)]) - (when (> j i) - (vector-swap! v i j) - (loop (add1 i) (sub1 j))))) - -(define (vector-swap! [v : (Vector X)] [i : Int] [j : Int] -> Unit) - (let ((t (vector-ref v i))) - (vector-set! v i (vector-ref v j)) - (vector-set! v j t))) - -(check-type (fannkuch 5) : Int -> 7) -(check-type (fannkuch 6) : Int -> 10) -(check-type (fannkuch 7) : Int -> 16) -(check-type (fannkuch 8) : Int -> 22) -(check-type (fannkuch 9) : Int -> 30) diff --git a/tapl/tests/mlish/fasta.mlish b/tapl/tests/mlish/fasta.mlish @@ -1,191 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define +alu+ - (string-append "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG" - "GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA" - "CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT" - "ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA" - "GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG" - "AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC" - "AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA")) - -(check-type +alu+ : String) - -(define IUB - (hash #\a 0.27 #\c 0.12 #\g 0.12 #\t 0.27 #\B 0.02 - #\D 0.02 #\H 0.02 #\K 0.02 #\M 0.02 #\N 0.02 - #\R 0.02 #\S 0.02 #\V 0.02 #\W 0.02 #\Y 0.02)) - -(check-type IUB : (Hash Char Float)) - -(define HOMOSAPIEN - (hash #\a 0.3029549426680 #\c 0.1979883004921 - #\g 0.1975473066391 #\t 0.3015094502008)) - -(check-type HOMOSAPIEN : (Hash Char Float)) - -(define line-length 60) - -(check-type line-length : Int) - -(define (repeat-fasta [header : String] [N : Int] [sequence : String] -> String) - (let* ([out (open-output-string)] - [len (string-length sequence)] - [buf (make-string (+ len line-length))]) - (string-copy! buf 0 sequence) - (string-copy! buf len sequence 0 line-length) - (write-string header out) - (let loop : String ([n N] [start 0]) - (if (> n 0) - (let ([end (+ start (min n line-length))]) - (write-string buf out start end) - (write-string "\n" out) - (loop (- n line-length) (if (> end len) (- end len) end))) - (get-output-string out))))) - -(define IA 3877) -(define IC 29573) -(define IM 139968) -(define IM.0 (fx->fl IM)) - -(define V - (for/vector ([id (in-range IM)]) - (modulo (+ IC (* id IA)) IM))) - -(check-type V : (Vector Int)) - -(define (random-next [cur : Int] -> Int) (vector-ref V cur)) - -(check-type (tup 0 0.0) : (× Int Float)) - -(check-type (in-hash IUB) : (Sequence (× Char Float))) - -(define (make-lookup-table [frequency-table : (Hash Char Float)] -> String) - (let ([v (make-string IM)]) - (for/fold ([cs (tup 0 0.0)]) - ([k+v (in-hash frequency-table)]) - (match cs with - [c c. -> - (match k+v with - [key val -> - (let* ([c1. (fl+ c. (fl* IM.0 val))] - [c1 (inexact->exact (flceiling c1.))] - #;[b (char->integer key)]) - (for ([i (in-range c c1)]) (string-set! v i key)) - (tup c1 c1.))])])) - v)) - -(define (n-randoms [buf : String][out : String-Port][lookup : String] - [to : Int][R : Int] -> Int) - (let loop : Int ([n 0] [R R]) - (if (< n to) - (let ([R (random-next R)]) - (string-set! buf n (string-ref lookup R)) - (loop (add1 n) R)) - (begin (write-string buf out 0 (add1 to)) R)))) - -(define LF #\newline) - -(define (make-line! [buf : String] [lookup : String] - [start : Int] [R : Int] -> Int) - (let ([end (+ start line-length)]) - (string-set! buf end LF) - (let loop : Int ([n start] [R R]) - (if (< n end) - (let ([R (random-next R)]) - (string-set! buf n (string-ref lookup R)) - (loop (add1 n) R)) - R)))) - -(define (random-fasta [header : String] [N : Int] - [table : (Hash Char Float)] [R : Int] - -> (× Int String)) - (let* ([buf (make-string (add1 line-length))] - [out (open-output-string)] - [lookup-str (make-lookup-table table)] - [full-lines+last (quotient+remainder N line-length)] - [C - (let* ([len+1 (add1 line-length)] - [buflen (* len+1 IM)] - [buf2 (make-string buflen)]) - (let loop : String ([R R] [i 0]) - (if (< i buflen) - (loop (make-line! buf2 lookup-str i R) (+ i len+1)) - buf2)))]) - (string-set! buf line-length LF) - (write-string header out) - (tup - (match full-lines+last with - [full-lines last -> - (let loop : Int ([i full-lines] [R R]) - (if (> i IM) - (begin (write-string C out) (loop (- i IM) R)) - (let loop : Int ([i i] [R R]) - (cond - [(> i 0) - (loop - (sub1 i) - (n-randoms buf out lookup-str line-length R))] - [(> last 0) - (string-set! buf last LF) - (n-randoms buf out lookup-str last R)] - [else R]))))]) - (get-output-string out)))) - -(define n 10) - -(check-type (repeat-fasta ">ONE Homo sapiens alu\n" (* n 2) +alu+) : String - -> ">ONE Homo sapiens alu\nGGCCGGGCGCGGTGGCTCAC\n") - -(define res1 - (random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB 42)) - -(define res2 - (match res1 with - [R str -> - (random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN R)])) - -(check-type (proj res1 1) : String - -> ">TWO IUB ambiguity codes\nattRtBtaDtatVataKatgaatcccgDtY\n") - -(check-type (proj res2 1) : String - -> (string-append ">THREE Homo sapiens frequency\n" - "atttgcggaaacgacaaatattaacacatcatcagagtaccataaaggga\n")) - -(define (mk-fasta [n : Int] -> String) - (let - ([res1 (repeat-fasta ">ONE Homo sapiens alu\n" (* n 2) +alu+)] - [res2 (random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB 42)] - [res3 - (match res2 with - [R str -> - (random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN R)])]) - (string-append res1 (proj res2 1) (proj res3 1)))) - -(provide mk-fasta) - -(check-type (mk-fasta 100) - : String - -> (string-append - ">ONE Homo sapiens alu\n" - "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA\n" - "TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT\n" - "AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG\n" - "GCTGAGGCAGGAGAATCGCT\n" - ">TWO IUB ambiguity codes\n" - "attRtBtaDtatVataKatgaatcccgDtYtcccNaNgtRttNtatttatcctSaRataW\n" - "taatNtNctaatctttggMtMttKtYtMHagBttagcMKMttttcWaactgcSttgaaac\n" - "gtcatHagHtgtaHVgtcattatgRcaVcaatctcWgaNtttVaaYcaaaataYtgWgtt\n" - "acttMgtHHgagtattaaaKSgtBgacaaggSaaRttVaVDHttRgctagtaaacgaaac\n" - "ttcRNtgcatttSagBtHttNRaatgtctattcaSaRYcgtatSattttttttgaBgagD\n" - ">THREE Homo sapiens frequency\n" - "gaagacaggtgtaacgtgggaaaatctctagtaaagctttgatcagcggagacgcgatca\n" - "acagatcctttatatcgcgaaacttctctctatcagcgaactaaggagggcgacaatccg\n" - "agctgttccggaccaaaccctgaaagtacgactctgctctaataaagtcaaaacgtagaa\n" - "gactagatacaattatactgacaacaaaaaaaagttgcgtgcacaagagtacgatgtttg\n" - "accgccagttattatgacgagggtgagaacaagtcaggctaaagtagaagagcaccatag\n" - "gtatcagtttaactgagtaaatgcgaatgcgtgactttaaataagcctgcgtgtgtcaaa\n" - "actctacaatatctttgttatattattgaatcattctggatttgaggcagtggagcatac\n" - "tgtataaaataatttttcggtgggtcaaaaataaatttcaattaagacgttaaggataat\n" - "gaaatgactcaatctaaggt\n")) diff --git a/tapl/tests/mlish/fibo.mlish b/tapl/tests/mlish/fibo.mlish @@ -1,22 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define (fib [n : Int] -> Int) - (cond - [(< n 2) 1] - [else - (+ (fib (- n 2)) (fib (sub1 n)))])) - -(define (main [args : (Vector String)] -> Int) - (let ([n (if (= (vector-length args) 0) - 1 - (string->number (vector-ref args 0)))]) - (fib n))) - -(check-type (main (vector "0")) : Int -> 1) - -(check-type (main (vector "1")) : Int -> 1) - -(check-type (main (vector "2")) : Int -> 2) - -(check-type (main (vector "22")) : Int -> 28657) diff --git a/tapl/tests/mlish/find.mlish b/tapl/tests/mlish/find.mlish @@ -1,87 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define-type (List X) - Nil - (Cons X (List X))) - -(define-type (Option X) - None - (Some X)) - -(define (find [lst : (List X)] [pred : (→ X Bool)] → (Option X)) - (match lst with - [Nil -> None] - [Cons fst rst -> - (cond [(pred fst) (Some fst)] - [else (find rst pred)])])) - -(check-type - (find (Cons 1 (Cons 2 (Cons 3 Nil))) (λ ([x : Int]) (<= 2 x))) - : (Option Int) - -> (Some 2)) - -(check-type - (find (Cons 1 (Cons 0 (Cons -1 Nil))) (λ ([x : Int]) (<= 2 x))) - : (Option Int) - -> None) - -;; args inferred in order, L-to-R, currently no backtracking -(check-type - (find Nil (λ ([x : Int]) (<= 2 x))) - : (Option Int) - -> None) - -;; reversing arg order leads to successful inference -(define (find2 [pred : (→ X Bool)] [lst : (List X)] → (Option X)) - (match lst with - [Nil -> None] - [Cons fst rst -> - (cond [(pred fst) (Some fst)] - [else (find2 pred rst)])])) - -(check-type - (find2 (λ ([x : Int]) (<= 2 x)) Nil) - : (Option Int) - -> None) - -(define (find-min/max [lst : (List X)] [<? : (→ Y Y Bool)] [extract-key : (→ X Y)] - → (Option (× X X))) - (match lst with - [Nil -> None] - [Cons x1 rst -> - (let ([y1 (extract-key x1)]) - (Some (find-min/max-accum rst <? extract-key x1 y1 x1 y1)))])) - -(define (find-min/max-accum [lst : (List X)] [<? : (→ Y Y Bool)] [extract-key : (→ X Y)] - [x-min : X] [y-min : Y] [x-max : X] [y-max : Y] - → (× X X)) - (match lst with - [Nil -> (tup x-min x-max)] - [Cons x2 rst -> - (let ([y2 (extract-key x2)]) - (cond [(<? y2 y-min) - (find-min/max-accum rst <? extract-key x2 y2 x-max y-max)] - [(<? y-max y2) - (find-min/max-accum rst <? extract-key x-min y-min x2 y2)] - [else - (find-min/max-accum rst <? extract-key x-min y-min x-max y-max)]))])) - -(check-type - (find-min/max (Nil {Int}) - (λ ([x : Int] [y : Int]) - (< x y)) - (λ ([x : Int]) - x)) - : (Option (× Int Int)) - -> None) - -(check-type - (find-min/max (Cons 1 (Cons 2 (Cons 3 Nil))) - (λ ([x : Int] [y : Int]) - (< x y)) - (λ ([x : Int]) - x)) - : (Option (× Int Int)) - -> (Some (tup 1 3))) - diff --git a/tapl/tests/mlish/hash.mlish b/tapl/tests/mlish/hash.mlish @@ -1,19 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define (main [argv : (Vector String)] -> Int) - (let* ([n (string->number (vector-ref argv 0))] - [hash - (for/hash ([i (in-range n)]) - (let ([j (add1 i)]) - (tup (number->string j 16) j)))]) - (for/sum ([i (in-range 1 (add1 n))] - #:when - (hash-has-key? hash (number->string i))) - 1))) - -(check-type (main (vector "2000")) : Int -> 799) - -(check-type (main (vector "20000")) : Int -> 4999) - -(check-type (main (vector "200000")) : Int -> 30999) diff --git a/tapl/tests/mlish/infer-variances.mlish b/tapl/tests/mlish/infer-variances.mlish @@ -1,243 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define-type T1 t1) -;; No type arguments to determine variance for. - -(check-type t1 : T1 -> t1) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Non-Recursive Types - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T2 X) t2) -;; X should be inferred to be irrelevant within (T2 X). -;; That means it should be both covariant and contravariant. - -;; This checks that X is covariant within (T2 X). -(define (t2* → (T2 X)) t2) -(define (t2** → (→ (T2 X))) (inst t2* X)) -(check-type (t2**) : (→/test (T2 X))) - -;; This checks that X is contravariant within (T2 X), -;; by checking that X is covariant within (→ (T2 X) Int). -(define (t2->int [t2 : (T2 X)] → Int) 0) -(define (t2->int* → (→ (T2 X) Int)) (inst t2->int X)) -(check-type (t2->int*) : (→/test (T2 X) Int)) - -;; This checks that X is irrelevant, even within a Ref type, -;; by checking that X is covariant within (Ref (T2 X)). -;; This is still sound because a value of type (Ref (T2 X)) will never -;; contain anything of type X anyway. X is irrelevant within it. -(define (ref-t2* → (Ref (T2 X))) (ref (t2 {X}))) -(define (ref-t2** → (→ (Ref (T2 X)))) (inst ref-t2* X)) -(check-type (ref-t2**) : (→/test (Ref (T2 X)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T3 X) t3-none (t3-some X)) -;; X should be inferred to be covariant within (T3 X). - -;; This checks that X is covariant within (T3 X). -(define (t3-none* → (T3 X)) t3-none) -(define (t3-none** → (→ (T3 X))) (inst t3-none* X)) -(check-type (t3-none**) : (→/test (T3 X))) - -;; This checks that X is not contravariant within (T3 X), -;; by checking that X is not covariant within (→ (T3 X) Int). -(define (t3->int [t3 : (T3 X)] → Int) 0) -(define (t3->int* → (→ (T3 X) Int)) (inst t3->int X)) -(typecheck-fail (t3->int*)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T4 X) t4-none (t4-some (→ X Int))) -;; X should be inferred to be contravariant within (T4 X). - -;; This checks that X is not covariant within (T4 X). -(define (t4-none* → (T4 X)) t4-none) -(define (t4-none** → (→ (T4 X))) (inst t4-none* X)) -(typecheck-fail (t4-none**)) - -;; This checks that X is contravariant within (T4 X), -;; by checking that X is covariant within (→ (T4 X) Int). -(define (t4->int [t4 : (T4 X)] → Int) 0) -(define (t4->int* → (→ (T4 X) Int)) (inst t4->int X)) -(check-type (t4->int*) : (→/test (T4 X) Int)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T5 X) t5-none (t5-some+ X) (t5-some- (→ X Int))) -;; X should be inferred to be invariant within (T5 X). - -;; This checks that X is not covariant within (T5 X). -(define (t5-none* → (T5 X)) t5-none) -(define (t5-none** → (→ (T5 X))) (inst t5-none* X)) -(typecheck-fail (t5-none**)) - -;; This checks that X is not contravariant within (T5 X), -;; by checking that X is not covariant within (→ (T5 X) Int). -(define (t5->int [t5 : (T5 X)] → Int) 0) -(define (t5->int* → (→ (T5 X) Int)) (inst t5->int X)) -(typecheck-fail (t5->int*)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Recursive Types - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T6 X) t6-none (t6-same (T6 X))) -;; X should be inferred to be irrelevant within (T6 X). - -;; This checks that X is covariant within (T6 X). -(define (t6-none* → (T6 X)) t6-none) -(define (t6-none** → (→ (T6 X))) (inst t6-none* X)) -(check-type (t6-none**) : (→/test (T6 X))) - -;; This checks that X is contravariant within (T6 X), -;; by checking that X is covariant within (→ (T6 X) Int). -(define (t6->int [t6 : (T6 X)] → Int) 0) -(define (t6->int* → (→ (T6 X) Int)) (inst t6->int X)) -(check-type (t6->int*) : (→/test (T6 X) Int)) - -;; This checks that X is irrelevant, even within a Ref type, -;; by checking that X is covariant within (Ref (T6 X)). -;; This is still sound because a value of type (Ref (T6 X)) will never -;; contain anything of type X anyway. X is irrelevant within it. -(define (ref-t6* → (Ref (T6 X))) (ref (t6-none {X}))) -(define (ref-t6** → (→ (Ref (T6 X)))) (inst ref-t6* X)) -(check-type (ref-t6**) : (→/test (Ref (T6 X)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T7 X) t7-none (t7-weird (→ (T7 X) Int))) -(define-type (T8 X) t8-none (t8-weird (T8 (→ X Int)))) -(define-type (T9 X) t9-none (t9-weird (→ (T9 (→ X Int)) Int))) -;; X should be inferred to be irrelevant within (T7 X), (T8 X), and -;; (T9 X). None of these types could contain or recieve an actual X. - -(define-type (T10 X) (t10 (T7 X) (T8 X) (T9 X))) -;; So because of that, X should be irrelevant within (T10 X). - -;; This checks that X is covariant within (T10 X). -(define (t10-none* → (T10 X)) (t10 t7-none t8-none t9-none)) -(define (t10-none** → (→ (T10 X))) (inst t10-none* X)) -(check-type (t10-none**) : (→/test (T10 X))) - -;; This checks that X is contravariant within (T10 X), -;; by checking that X is covariant within (→ (T10 X) Int). -(define (t10->int [t10 : (T10 X)] → Int) 0) -(define (t10->int* → (→ (T10 X) Int)) (inst t10->int X)) -(check-type (t10->int*) : (→/test (T10 X) Int)) - -;; This checks that X is irrelevant, even within a Ref type, -;; by checking that X is covariant within (Ref (T10 X)). -;; This is still sound because a value of type (Ref (T10 X)) will never -;; contain anything of type X anyway. X is irrelevant within it. -(define (ref-t10* → (Ref (T10 X))) (ref (t10 (t7-none {X}) (t8-none {X}) (t9-none {X})))) -(define (ref-t10** → (→ (Ref (T10 X)))) (inst ref-t10* X)) -(check-type (ref-t10**) : (→/test (Ref (T10 X)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T11 X) t11-none (t11+ X) (t11-weird (→ (T11 X) Int))) -(define-type (T12 X) t12-none (t12+ X) (t12-weird (T12 (→ X Int)))) -(define-type (T13 X) t13-none (t13+ X) - (t13-weird (→ (T13 (→ X Int)) Int))) -(define-type (T14 X) t14-none (t14- (→ X Int)) - (t14-weird (→ (T14 (→ X Int)) Int))) -;; X should be inferred to be invariant within (T11 X) and (T12 X), -;; but covariant within (T13 X), and contravariant within (T14 X). - -;; This checks that X is covariant within (T13 X), but not any of the -;; others. -(define (t11-none* → (T11 X)) t11-none) -(define (t12-none* → (T12 X)) t12-none) -(define (t13-none* → (T13 X)) t13-none) -(define (t14-none* → (T14 X)) t14-none) -(define (t11-none** → (→ (T11 X))) (inst t11-none* X)) -(define (t12-none** → (→ (T12 X))) (inst t12-none* X)) -(define (t13-none** → (→ (T13 X))) (inst t13-none* X)) -(define (t14-none** → (→ (T14 X))) (inst t14-none* X)) -(typecheck-fail (t11-none**)) -(typecheck-fail (t12-none**)) -(check-type (t13-none**) : (→/test (T13 X))) -(typecheck-fail (t14-none**)) - -;; This checks that X is contravariant within (T14 X), but not any of -;; the others. -(define (t11->int [t11 : (T11 X)] → Int) 0) -(define (t12->int [t12 : (T12 X)] → Int) 0) -(define (t13->int [t13 : (T13 X)] → Int) 0) -(define (t14->int [t14 : (T14 X)] → Int) 0) -(define (t11->int* → (→ (T11 X) Int)) (inst t11->int X)) -(define (t12->int* → (→ (T12 X) Int)) (inst t12->int X)) -(define (t13->int* → (→ (T13 X) Int)) (inst t13->int X)) -(define (t14->int* → (→ (T14 X) Int)) (inst t14->int X)) -(typecheck-fail (t11->int*)) -(typecheck-fail (t12->int*)) -(typecheck-fail (t13->int*)) -(check-type (t14->int*) : (→/test (T14 X) Int)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T15 X) t15-none (t15-cons+ X (T15 X))) -(define-type (T16 X) t16-none (t16-cons- (→ X Int) (T16 X))) -;; X should be inferred to be covariant within (T15 X), and -;; contravariant within (T16 X). (T15 X) is just like a (List X) type, -;; and (T16 X) is just like a (List (→ X Int)). - -;; This checks that X is covariant within (T15 X). -(define (t15-none* → (T15 X)) t15-none) -(define (t15-none** → (→ (T15 X))) (inst t15-none* X)) -(check-type (t15-none**) : (→/test (T15 X))) -;; This checks that X is not covariant within (T16 X). -(define (t16-none* → (T16 X)) t16-none) -(define (t16-none** → (→ (T16 X))) (inst t16-none* X)) -(typecheck-fail (t16-none**)) - -;; This checks that X is not contravariant within (T15 X), -;; by checking that X is not covariant within (→ (T15 X) Int). -(define (t15->int [t15 : (T15 X)] → Int) 0) -(define (t15->int* → (→ (T15 X) Int)) (inst t15->int X)) -(typecheck-fail (t15->int*)) -;; This checks that X is contravariant within (T16 X), -;; by checking that X is covariant within (→ (T16 X) Int). -(define (t16->int [t16 : (T16 X)] → Int) 0) -(define (t16->int* → (→ (T16 X) Int)) (inst t16->int X)) -(check-type (t16->int*) : (→/test (T16 X) Int)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Mutually Recursive Types - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-type (T17 X) (t17-some X) (t18 (T18 X))) -(define-type (T18 X) t18-none (t18-cons (T17 X) (T18 X))) -;; X should be inferred to be covariant in both (T17 X) and (T18 X). -;; This is similar to an arbitrary-arity tree type. - -;; This checks that X is covariant within (T17 X). -(define (t17-none* → (T17 X)) (t18 t18-none)) -(define (t17-none** → (→ (T17 X))) (inst t17-none* X)) -(check-type (t17-none**) : (→/test (T17 X))) -;; This checks that X is covariant within (T18 X). -(define (t18-none* → (T18 X)) t18-none) -(define (t18-none** → (→ (T18 X))) (inst t18-none* X)) -(check-type (t18-none**) : (→/test (T18 X))) - -;; This checks that X is not contravariant within (T17 X), -;; by checking that X is not covariant within (→ (T17 X) Int). -(define (t17->int [t17 : (T17 X)] → Int) 0) -(define (t17->int* → (→ (T17 X) Int)) (inst t17->int X)) -(typecheck-fail (t17->int*)) -;; This checks that X is not contravariant within (T18 X), -;; by checking that X is not covariant within (→ (T18 X) Int). -(define (t18->int [t18 : (T18 X)] → Int) 0) -(define (t18->int* → (→ (T18 X) Int)) (inst t18->int X)) -(typecheck-fail (t18->int*)) - diff --git a/tapl/tests/mlish/inst.mlish b/tapl/tests/mlish/inst.mlish @@ -1,74 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; tests for instantiation of polymorphic functions and constructors - -(define-type (Result A B) - (Ok A) - (Error B)) - -(define (ok [a : A] -> (Result A B)) - (Ok a)) - -(check-type ok : (→/test A (Result A B))) ; test inferred -(check-type (inst ok Int String) : (→/test Int (Result Int String))) - -(define (f -> (Result Int String)) - (ok 1)) - -(check-type f : (→/test (Result Int String))) - -(define (g -> (Result Int String)) - (Ok 1)) - -(check-type g : (→/test (Result Int String))) - -(define (h -> (Result Int Y)) - (Ok 1)) - -(check-type h : (→/test (Result Int Y))) - -(define (i -> (Result Int String)) - (h)) - -(check-type i : (→/test (Result Int String))) - -(define (f/cond [b : Bool] -> (Result Int String)) - (cond [b (ok 1)] - [else (ok 0)])) - -(check-type f/cond : (→/test Bool (Result Int String))) - -(define-type-alias (Read-Result A) (Result (× A (List Char)) String)) - -(define (alias-test -> (Read-Result A)) - (Error "asd")) - -(check-type alias-test : (→/test (Result (× A (List Char)) String))) -(check-type alias-test : (→/test (Read-Result A))) - -(define (alias-test2 [in : A] -> (Read-Result A)) - (ok (tup in nil))) -(define (alias-test3 [in : A] -> (Read-Result A)) - (ok (tup in (list #\a #\b #\c)))) - -(check-type alias-test2 : (→/test A (Result (× A (List Char)) String))) -(check-type alias-test2 : (→/test A (Read-Result A))) -(check-type alias-test3 : (→/test A (Result (× A (List Char)) String))) -(check-type alias-test3 : (→/test A (Read-Result A))) - -(check-type alias-test2 : (→/test B (Result (× B (List Char)) String))) -(check-type alias-test2 : (→/test B (Read-Result B))) -(check-type alias-test3 : (→/test B (Result (× B (List Char)) String))) -(check-type alias-test3 : (→/test B (Read-Result B))) - -(define (expect-listof-int [loi : (List Int)] → Int) - 0) - -(check-type (expect-listof-int nil) : Int -> 0) - -(define (expect-→listof-int [f : (→ (List Int))] → Int) - 0) - -(check-type (expect-→listof-int (λ () nil)) : Int -> 0) - diff --git a/tapl/tests/mlish/knuc.mlish b/tapl/tests/mlish/knuc.mlish @@ -1,67 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(require-typed mk-fasta #:from "fasta.mlish") - -(define (all-counts [len : Int] [dna : String] -> (Hash String (Ref Int))) - (let ([table (hash {String (Ref Int)})]) - (for ([s (in-range (- (string-length dna) len) -1 -1)]) - (let ([key (make-string len)]) - (string-copy! key 0 dna s (+ s len)) - (let* ([b (if (hash-has-key? table key) - (hash-ref table key) - (let ([b (ref 0)]) - (hash-set! table key b) - b))]) - (:= b (add1 (deref b)))))) - table)) - - -(define dna - (let* ([in (mk-fasta 100000)] - ;; Skip to ">THREE ..." - [rst - (head (tail - (regexp-match - (regexp ">THREE Homo sapiens frequency\n(.*)$") - in)))]) - (let ([s (open-output-string)]) - ;; Copy everything but newlines to s: - (for ([l (in-lines rst)]) - (write-string l s)) - ;; Extract the string from s: - (string-upcase (get-output-string s))))) - -(check-type dna : String) - -;; 1-nucleotide counts: -(define counts1 (all-counts 1 dna)) - -(check-type counts1 : (Hash String (Ref Int))) - -(check-type (hash-count counts1) : Int -> 4) - -;; 2-nucleotide counts: -(define counts2 (all-counts 2 dna)) - -(check-type counts2 : (Hash String (Ref Int))) - -(check-type (hash-count counts2) : Int -> 16) - -;; 2-nucleotide counts: -(define counts3 (all-counts 3 dna)) - -(check-type counts3 : (Hash String (Ref Int))) - -(check-type (hash-count counts3) : Int -> 64) - -;; Specific sequences: -(check-type - (for/list ([seq (in-list (list "GGT" "GGTA" "GGTATT" - "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))]) - (let ([table (all-counts (string-length seq) dna)]) - (if (hash-has-key? table seq) - (deref (hash-ref table seq)) - 0))) - : (List Int) - -> (list 5861 1776 176 0 0)) diff --git a/tapl/tests/mlish/listpats.mlish b/tapl/tests/mlish/listpats.mlish @@ -1,70 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; pattern matching for built-in lists - -(check-type - (match (list 1 2) with - [[] -> 0] - [[x y] -> (+ x y)]) : Int -> 3) - -(typecheck-fail - (match (list 1 2) with - [[x y] -> (+ x y)]) #:with-msg "missing empty list case") - -(typecheck-fail - (match (list 1 2) with - [[] -> 0]) #:with-msg "missing non\\-empty list case") - -(check-type - (match (list 1 2) with - [[] -> 0] - [[x y] -> (+ x y)]) : Int -> 3) - -(check-type - (match (list 1 2) with - [[x y] -> (+ x y)] - [[] -> 0]) : Int -> 3) - -(check-type - (match (nil {Int}) with - [[x y] -> (+ x y)] - [[] -> 0]) : Int -> 0) - -(check-type - (match (list 1 2 3) with - [[] -> nil] - [x :: rst -> rst]) : (List Int) -> (list 2 3)) - -(check-type - (match (list 1 2 3) with - [[] -> nil] - [x :: y :: rst -> rst]) : (List Int) -> (list 3)) - -(check-type - (match (nil {Int}) with - [[] -> nil] - [x :: y :: rst -> rst]) : (List Int) -> nil) - -(check-type - (match (list 1 2 3) with - [[] -> 0] - [x :: y :: rst -> (+ x y)]) : Int -> 3) - -(check-type - (match (list 1 2 3) with - [[] -> 0] - [[x] -> 2] - [x :: rst -> 3]) : Int -> 3) - -(check-type - (match (list 1) with - [[] -> 0] - [[x] -> 2] - [x :: rst -> 3]) : Int -> 2) - -(check-type - (match (list 1) with - [[] -> 0] - [x :: rst -> 3] - [[x] -> 2]) : Int -> 3) diff --git a/tapl/tests/mlish/loop.mlish b/tapl/tests/mlish/loop.mlish @@ -1,121 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; datatype with no self-reference -(define-type (Test X) - (A X) - (B X X)) - -(typecheck-fail - (define-type (Test2 X) - (AA (Test2 X X))) - #:with-msg "Improper use of constructor Test2; expected 1 args, got 2") - -(typecheck-fail - (define-type (Test3 X) - (AA (→))) - #:with-msg "Improper usage of type constructor →") - -(typecheck-fail - (define-type (Test4 X) - (AA (+ 1 2))) - #:with-msg "\\(\\+ 1 2\\) is not a valid type") - -(check-type (A 1) : (Test Int)) -(check-type (B 1 2) : (Test Int)) - -(check-type - (match (A 1) with - [A x -> x] - [B x y -> (+ x y)]) : Int -> 1) - -(check-type - (match (B 1 2) with - [A x -> x] - [B x y -> (+ x y)]) : Int -> 3) - -;; datatype with self-reference -(define-type (Rec X) - N - (C X (Rec X))) - -; check inferred and explicit instantiation versions -(check-type N : (Rec Int) -> N) -(check-type (N {Int}) : (Rec Int) -> (N {Int})) -(check-type (C 1 N) : (Rec Int) -> (C 1 N)) - -(check-type - (match (N {Int}) with - [N -> 0] - [C x xs -> x]) : Int -> 0) - -(check-type - (match (C 1 N) with - [N -> 0] - [C x xs -> x]) : Int -> 1) - -;; mutually referential datatypes -(define-type (Loop1 X) - (L1 (Loop2 X))) -(define-type (Loop2 X) - (L2 (Loop1 X))) - -(define (looping-f [x : (Loop1 Y)] -> (Loop1 Y)) x) - -(define-type (ListA X) - NA - (CA X (ListB X))) -(define-type (ListB X) - NB - (CB X (ListA X))) - -(typecheck-fail - (define-type (ListC X) - NC - (CC X (ListA X X))) - #:with-msg - "Improper usage of type constructor ListA: \\(ListA X X\\), expected = 1 arguments") - -(typecheck-fail (CA 1 NA)) -(check-type (CA 1 NB) : (ListA Int)) -(check-type (CA 1 (CB 2 NA)) : (ListA Int)) -(typecheck-fail (CA 1 (CB 2 NB))) -(typecheck-fail (CB 1 NB)) -(check-type (CB 1 NA) : (ListB Int)) -(check-type (CB 1 (CA 2 NB)) : (ListB Int)) -(typecheck-fail (CB 1 (CA 2 NA))) - -(check-type - (match (CA 1 NB) with - [NA -> 0] - [CA x xs -> x]) : Int -> 1) - -(check-type - (match (CA 1 (CB 2 NA)) with - [NA -> 0] - [CA x xs -> - (match xs with - [NB -> 3] - [CB x xs -> x])]) : Int -> 2) - -;; "real world" mutually referential datatypes -(define-type (BankersDeque A) - [BD Int (List A) Int (List A)]) - -(define-type (ImplicitCatDeque A) - [Shallow (BankersDeque A)] - [Deep (BankersDeque A) - (ImplicitCatDeque (BankersDeque (CmpdElem (BankersDeque A)))) - (BankersDeque A) - (ImplicitCatDeque (BankersDeque (CmpdElem (BankersDeque A)))) - (BankersDeque A)]) - -(define-type (CmpdElem A) - [Simple (BankersDeque A)] - [Cmpd (BankersDeque A) - (ImplicitCatDeque - (BankersDeque (CmpdElem (BankersDeque A)))) (BankersDeque A)]) - -(define (id (icd : (ImplicitCatDeque Int)) → (ImplicitCatDeque Int)) - icd) - diff --git a/tapl/tests/mlish/match2.mlish b/tapl/tests/mlish/match2.mlish @@ -1,298 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; alternate match that supports nested patterns - -(define-type (Test X) - (A X) - (B (× X X)) - (C (× X (× X X)))) - -(typecheck-fail - (match2 (B (tup 2 3)) with - [B x -> x]) - #:with-msg "clauses not exhaustive; missing: A, C") - -(typecheck-fail - (match2 (B (tup 2 3)) with - [A x -> x] - [C (x,y) -> y] - [B x -> x]) #:with-msg "branches have incompatible types: Int and \\(× Int Int\\)") - -(typecheck-fail - (match2 (B (tup 2 3)) with - [A x -> (tup x x)] - [C x -> x] - [B x -> x]) - #:with-msg "branches have incompatible types: \\(× Int Int\\) and \\(× Int \\(× Int Int\\)\\)") - -(check-type - (match2 (B (tup 2 3)) with - [A x -> (tup x x)] - [C (x,y) -> y] - [B x -> x]) : (× Int Int) -> (list 2 3)) - -(typecheck-fail - (match2 (A (tup 2 3)) with - [A x -> x]) #:with-msg "clauses not exhaustive; missing: B, C") - -(check-type - (match2 (A (tup 2 3)) with - [B (x,y) -> y] - [C (x,y) -> x] - [A x -> x]) : (× Int Int) -> (list 2 3)) - -(check-type - (match2 (A (tup 2 3)) with - [B (x,y) -> y] - [A x -> x] - [C (x,y) -> x]) : (× Int Int) -> (list 2 3)) - -(typecheck-fail - (match2 (A (tup 2 3)) with - [B (x,y) -> y] - [A x -> x] - [C x -> x]) #:with-msg "branches have incompatible types") - -(check-type - (match2 (A 1) with - [A x -> x] - [_ -> -1]) : Int -> 1) - -(typecheck-fail - (match2 (B 1) with - [B x -> x]) - #:with-msg "expected: \\(× X X\\)\n *given: Int") - -(check-type - (match2 (B (tup 2 3)) with - [B (tup x y) -> (+ x y)] - [_ -> -1]) : Int -> 5) - -(check-type - (match2 (C (tup 2 (tup 3 4))) with - [C (tup x (tup y z)) -> (+ x (+ y z))] - [_ -> -1]) : Int -> 9) - -(check-type - (match2 (C (tup 2 (tup 3 4))) with - [A x -> x] - [_ -> 100]) : Int -> 100) - - - -;; lists - -(typecheck-fail - (match2 (list 1) with - [list x -> x]) #:with-msg "missing nil clause") - -(typecheck-fail - (match2 (list 1) with - [nil -> 0] - [list x -> x]) - #:with-msg "missing clause for non-empty, arbitrary length list") - -(check-type - (match2 (list 1) with - [nil -> 0] - [x :: xs -> x]) : Int -> 1) - -(check-type - (match2 (list 1) with - [nil -> 0] - [list x -> x] - [x :: xs -> x]) : Int -> 1) - -(check-type - (match2 (list 1) with - [list -> 0] - [list x -> x] - [x :: xs -> x]) : Int -> 1) - -(check-type - (match2 (list 1) with - [list x -> x] - [_ -> 0]) : Int -> 1) - -(check-type - (match2 (list 1) with - [x :: xs -> x] - [nil -> 0]) : Int -> 1) - -(check-type - (match2 (list 1) with - [_ -> -1] - [list x -> x] - [nil -> 0]) : Int -> -1) - -(check-type - (match2 (list 1) with - [_ -> -1] - [list x -> x] - [list -> 0]) : Int -> -1) - -(check-type - (match2 (list 1) with - [_ -> 0]) : Int -> 0) - -(typecheck-fail - (match2 (list 1) with - [nil -> 0]) - #:with-msg "missing clause for non-empty, arbitrary length list") - -(check-type - (match2 (list 1 2) with - [list x y -> (+ x y)] - [_ -> 0]) : Int -> 3) - -(check-type - (match2 (list 1 2) with - [list -> 0] - [list x y -> (+ x y)] - [_ -> -1]) : Int -> 3) - -(check-type - (match2 (list (list 3 4) (list 5 6)) with - [list -> 0] - [list (list w x) (list y z) -> (+ (+ x y) (+ z w))] - [_ -> -1]) : Int -> 18) - -(check-type - (match2 (list (tup 3 4) (tup 5 6)) with - [list -> 0] - [list (tup w x) (tup y z) -> (+ (+ x y) (+ z w))] - [_ -> -1]) : Int -> 18) - -(check-type - (match2 (nil {Int}) with - [nil -> 0] - [list x y -> (+ x y)] - [_ -> -1]) : Int -> 0) - -(check-type - (match2 (list 1 2) with - [nil -> 0] - [list x y -> (+ x y)] - [_ -> -1]) : Int -> 3) - -(check-type - (match2 (list 1 2 3) with - [nil -> 0] - [list x y -> (+ x y)] - [_ -> -1]) : Int -> -1) - -;; 0-arity constructors -(define-type (Test2 X) - AA - (BB X)) - -(check-type - (match2 (BB 1) with - [AA -> 0] - [BB x -> x]) : Int -> 1) - -(check-type - (match2 (BB (AA {Int})) with - [AA -> 0] - [BB AA -> 1] - [_ -> 2]) : Int -> 1) - -;; drop parens around 0-arity constructors -(check-type - (match2 (BB 1) with - [AA -> 0] - [BB x -> x]) : Int -> 1) - -(check-type - (match2 (BB (AA {Int})) with - [AA -> 0] - [BB AA -> 1] - [_ -> 2]) : Int -> 1) - -;; nicer cons pattern syntax (::) -(check-type - (match2 (list 1 2) with - [nil -> -1] - [x :: xs -> x]) - : Int -> 1) - -(check-type - (match2 (list 1 2) with - [nil -> -1] - [x :: y :: xs -> y]) : Int -> 2) - -(check-type - (match2 (list (tup 1 2) (tup 3 4)) with - [nil -> -1] - [(tup x y) :: (tup a b) :: xs -> (+ a b)]) : Int -> 7) - -(check-type - (match2 (list (list 2 3 4) (list 5 6 7) (list 9 10)) with - [nil -> -1] - [x :: (y :: z :: zs) :: xs -> z]) : Int -> 6) - -(check-type - (match2 (list (list 2 3 4) (list 5 6 7) (list 9 10)) with - [nil -> -1] - [x :: (list a b c) :: xs -> c]) : Int -> 7) - -(typecheck-fail - (match2 (list (list #t #f)) with - [nil -> -1] - [(list x y) :: tl -> (+ x y)]) - #:with-msg "expected: Int\n *given: Bool") - -;; comma tup pattern syntax - -(check-type - (match2 (tup 1 2) with - [(x,y) -> (+ x y)]) : Int -> 3) - -(check-type - (match2 (tup 1 2 4) with - [(_,y,z) -> (+ z y)]) : Int -> 6) - -(check-type - (match2 (list (tup 1 2) (tup 3 4) (tup 5 6)) with - [(x,y) :: (a,b) :: rst -> (+ y a)] - [_ -> -1]) : Int -> 5) - -(check-type - (match2 (list (tup (BB 1) (AA {Int})) (tup (BB 2) (AA {Int}))) with - [((BB x),AA) :: ((BB y),AA) :: rst -> (+ y x)] - [_ -> -1]) : Int -> 3) - -(check-type - (match2 (tup (tup (tup 1 2) (tup 3)) (tup 4 (tup 6 7))) with - [(((x,y),z),(a,(b,c))) -> (+ c y)]) : Int -> 9) - -(check-type - (match2 (tup (tup (tup 1 2) (tup 3)) (tup 4 (tup 6 7))) with - [(((x,y),z),(_,(_,c))) -> (+ c y)]) : Int -> 9) - -(check-type - (match2 (tup (tup (tup 1 2) (tup 3)) (tup 4 (tup 6 7))) with - [(((_,y),_),(_,(_,c))) -> (+ c y)]) : Int -> 9) - -(typecheck-fail - (match2 (tup (BB 1) (BB 2)) with - [((BB x),(BB y)) -> (+ x y)]) - #:with-msg "clauses not exhaustive; missing: AA") - -;; TODO: should tail -#;(typecheck-fail - (match2 (tup (BB 1) (BB 2)) with - [((BB x),(BB y)) -> (+ x y)] - [(AA,AA) -> 0]) - #:with-msg "clauses not exhaustive; missing: AA") - -;; falls off; runtime match exception -#;(match2 (tup (BB 2) (AA {Int})) with - [((BB x),(BB y)) -> (+ x y)] - [(AA,AA) -> 0]) - -(check-type - (match2 (tup (BB 1) (BB 2)) with - [((BB x),(BB y)) -> (+ x y)] - [_ -> -1]) : Int -> 3) diff --git a/tapl/tests/mlish/matrix.mlish b/tapl/tests/mlish/matrix.mlish @@ -1,73 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define-type-alias Matrix (Vector (Vector Int))) - -(define size 30) - -(define (vector-map [f : (→ X Y)] [v : (Vector X)] -> (Vector Y)) - (for/vector ([x (in-vector v)]) (f x))) - -(define (mkmatrix [rows : Int] [cols : Int] -> Matrix) - (for/vector ([i (in-range rows)] - [count (in-range 1 (* rows cols) cols)]) - (for/vector ([j (in-range cols)] - [x (in-naturals count)]) - x))) - -(check-type (mkmatrix 3 4) : Matrix - -> (vector (vector 1 2 3 4) - (vector 5 6 7 8) - (vector 9 10 11 12))) - -(check-type (mkmatrix 3 3) - : Matrix - -> (vector (vector 1 2 3) - (vector 4 5 6) - (vector 7 8 9))) - -(check-type (mkmatrix 4 3) - : Matrix - -> (vector (vector 1 2 3) - (vector 4 5 6) - (vector 7 8 9) - (vector 10 11 12))) - -(define (num-cols [mx : Matrix] -> Int) - (let ((row (vector-ref mx 0))) - (vector-length row))) - -(define (num-rows [mx : Matrix] -> Int) - (vector-length mx)) - -(define (vec-mult [v1 : (Vector Int)] [v2 : (Vector Int)] -> Int) - (for/sum ([x (in-vector v1)] - [y (in-vector v2)]) - (* x y))) - -(define (mmult [m1 : Matrix] [m2 : Matrix] -> Matrix) - (for/vector ([row (in-vector m1)]) - (for/vector ([col-num (in-range (num-cols m2))]) - (let ([col - (vector-map - (λ ([r : (Vector Int)]) (vector-ref r col-num)) - m2)]) - (vec-mult row col))))) - -(check-type (mmult (mkmatrix 3 3) (mkmatrix 3 3)) - : Matrix - -> (vector (vector 30 36 42) - (vector 66 81 96) - (vector 102 126 150))) - -(check-type (mmult (mkmatrix 2 3) (mkmatrix 3 2)) - : Matrix - -> (vector (vector 22 28) - (vector 49 64))) - -(check-type (mmult (mkmatrix 4 3) (mkmatrix 3 4)) - : Matrix - -> (vector (vector 38 44 50 56) - (vector 83 98 113 128) - (vector 128 152 176 200) - (vector 173 206 239 272))) diff --git a/tapl/tests/mlish/nbody.mlish b/tapl/tests/mlish/nbody.mlish @@ -1,185 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define +pi+ 3.141592653589793) - -(check-type +pi+ : Float) - -(define +days-per-year+ 365.24) - -(define * fl*) - -(define +solar-mass+ (* 4.0 (* +pi+ +pi+))) - -(check-type +solar-mass+ : Float) - -(define +dt+ 0.01) - -(define-type Body (body Float ; x - Float ; y - Float ; z - Float ; vx - Float ; vy - Float ; vz - Float ; mass - )) - -(define *sun* - (body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+)) - -(define *jupiter* - (body 4.84143144246472090 - -1.16032004402742839 - -1.03622044471123109e-1 - (* 1.66007664274403694e-3 +days-per-year+) - (* 7.69901118419740425e-3 +days-per-year+) - (* -6.90460016972063023e-5 +days-per-year+) - (* 9.54791938424326609e-4 +solar-mass+))) - -(define *saturn* - (body 8.34336671824457987 - 4.12479856412430479 - -4.03523417114321381e-1 - (* -2.76742510726862411e-3 +days-per-year+) - (* 4.99852801234917238e-3 +days-per-year+) - (* 2.30417297573763929e-5 +days-per-year+) - (* 2.85885980666130812e-4 +solar-mass+))) - -(define *uranus* - (body 1.28943695621391310e1 - -1.51111514016986312e1 - -2.23307578892655734e-1 - (* 2.96460137564761618e-03 +days-per-year+) - (* 2.37847173959480950e-03 +days-per-year+) - (* -2.96589568540237556e-05 +days-per-year+) - (* 4.36624404335156298e-05 +solar-mass+))) - -(define *neptune* - (body 1.53796971148509165e+01 - -2.59193146099879641e+01 - 1.79258772950371181e-01 - (* 2.68067772490389322e-03 +days-per-year+) - (* 1.62824170038242295e-03 +days-per-year+) - (* -9.51592254519715870e-05 +days-per-year+) - (* 5.15138902046611451e-05 +solar-mass+))) - -(define *system* (list *sun* *jupiter* *saturn* *uranus* *neptune*)) - -(check-type *system* : (List Body)) - -(define (offset-momentum -> Unit) - (let loop-i : Unit - ([i *system*] [px 0.0] [py 0.0] [pz 0.0]) - (cond - [(isnil i) - (match (head *system*) with ; sun - [body x y z vx vy vz m -> - (let ([new - (body x y z - (fl/ (fl- 0.0 px) +solar-mass+) - (fl/ (fl- 0.0 py) +solar-mass+) - (fl/ (fl- 0.0 pz) +solar-mass+) - m)]) - (set! *system* (cons new (tail *system*))))])] - [else - (match (head i) with - [body x y z vx vy vz m -> - (loop-i (tail i) - (fl+ px (fl* vx m)) - (fl+ py (fl* vy m)) - (fl+ pz (fl* vz m)))])]))) - -(define (energy [o : (List Body)] -> Float) - (let loop-o : Float ([o o] [e 0.0]) - (cond - [(isnil o) e] - [else - (match (head o) with - [body x y z vx vy vz m -> - (let* ([e (fl+ e (fl* 0.5 - (fl* m - (fl+ (fl+ (fl* vx vx) - (fl* vy vy)) - (fl* vz vz)))))]) - (let loop-i : Float ([i (tail o)] [e e]) - (if (isnil i) - (loop-o (tail o) e) - (match (head i) with - [body x2 y2 z2 vx2 vy2 vz2 m2 -> - (let* ([dx (fl- x x2)] - [dy (fl- y y2)] - [dz (fl- z z2)] - [dist (flsqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) - (fl* dz dz)))] - [e (fl- e (fl/ (fl* m m2) dist))]) - (loop-i (tail i) e))]))))])]))) - -(define (advance [bs : (List Body)] -> (List Body)) - (if (isnil bs) - bs - (let ([new (advance2 bs)]) - (cons (head new) (advance (tail new)))))) -;; bs is non-null -(define (advance2 [bs : (List Body)] -> (List Body)) - (match (head bs) with - [body o1x o1y o1z vx vy vz om -> - (let loop-i : (List Body) - ([i (tail bs)] [res (nil {Body})] [vx vx] [vy vy] [vz vz]) - (cond - [(isnil i) - (cons - (body - (fl+ o1x (fl* +dt+ vx)) - (fl+ o1y (fl* +dt+ vy)) - (fl+ o1z (fl* +dt+ vz)) - vx vy vz om) - (reverse res))] - [else - (match (head i) with - [body i1x i1y i1z i1vx i1vy i1vz im -> - (let* ([dx (fl- o1x i1x)] - [dy (fl- o1y i1y)] - [dz (fl- o1z i1z)] - [dist2 (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz))] - [mag (fl/ +dt+ (fl* dist2 (flsqrt dist2)))] - [dxmag (fl* dx mag)] - [dymag (fl* dy mag)] - [dzmag (fl* dz mag)]) - (loop-i - (tail i) - (cons (body i1x i1y i1z - (fl+ i1vx (fl* dxmag om)) - (fl+ i1vy (fl* dymag om)) - (fl+ i1vz (fl* dzmag om)) - im) res) - (fl- vx (fl* dxmag im)) - (fl- vy (fl* dymag im)) - (fl- vz (fl* dzmag im))))])]))])) - -(check-type (real->decimal-string (energy *system*) 9) - : String -> "-0.169289903") - -(offset-momentum) - -(check-type (real->decimal-string (energy *system*) 9) - : String -> "-0.169075164") - -(check-type - (real->decimal-string - (energy (advance *system*)) - 9) - : String -> "-0.169074954") - -(check-type - (real->decimal-string - (energy (advance (advance *system*))) 9) - : String -> "-0.169074743") - -(check-type - (real->decimal-string - (energy - (for/fold ([bs *system*]) - ([i (in-range 10)]) - (advance bs))) - 9) - : String -> "-0.169073022") diff --git a/tapl/tests/mlish/polyrecur.mlish b/tapl/tests/mlish/polyrecur.mlish @@ -1,117 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; tests of polymorphic recursion - -;; polymorphic recursion of functions -(define (polyf [lst : (List X)] -> (List X)) - (let ([x (polyf (list 1 2 3))] - [y (polyf (list #t #f))]) - (polyf lst))) - -;; polymorphic recursive type -;; from okasaki, ch10 -(define-type (Seq X) - Nil - (Cons X (Seq (× X X)))) - -(define (size [s : (Seq X)] -> Int) - (match s with - [Nil -> 0] - [Cons x ps -> (add1 (* 2 (size ps)))])) - -(check-type (size (Nil {Int})) : Int -> 0) -(check-type (size (Cons 1 Nil)) : Int -> 1) -(check-type (size (Cons 1 (Cons (tup 2 3) Nil))) : Int -> 3) -(check-type - (size (Cons 1 (Cons (tup 2 3) (Cons (tup (tup 4 5) (tup 6 7)) Nil)))) - : Int -> 7) - -;; implicit queue -(define-type (Digit X) - (Zero) - (One X) - (Two X X)) - -(define-type (ImplicitQueue X) - [Shallow (d : (Digit X))] - [Deep (f : (Digit X)) - (m : (ImplicitQueue (× X X))) - (r : (Digit X))]) - -(define (empty -> (ImplicitQueue X)) - (Shallow (Zero))) - -(define (iq-isEmpty [iq : (ImplicitQueue A)] → Bool) - (match iq with - [Shallow d -> - (match d with - [Zero -> #t] - [One x -> #f] - [Two x y -> #f])] - [Deep a b c -> #f])) - -(define (iq-snoc [iq : (ImplicitQueue A)] [y : A] → (ImplicitQueue A)) - (match iq with - [Shallow d -> - (match d with - [Zero -> (Shallow (One y))] - [One x -> (Deep (Two x y) (empty) Zero)] - [Two x y -> (empty)])] ;; Error - [Deep f m d -> - (match d with - [Zero -> (Deep f m (One y))] - [One x -> (Deep f (iq-snoc m (tup x y)) Zero)] - [Two x y -> (empty)])])) ; Error - -(check-type (iq-isEmpty (Shallow (Zero {Int}))) : Bool -> #t) - -(check-type (iq-isEmpty (iq-snoc (Shallow (Zero {Int})) 5)) : Bool -> #f) - -;; example from: -;; blogs.janestreet.com/ensuring-that-a-function-is-polymorphic-in-ocaml-3-12 - -(define-type (PerfectTree X) - (Leaf X) - (Node X (PerfectTree (× X X)))) -(define (flatten [t : (PerfectTree X)] -> (List X)) - (match t with - [Leaf x -> (list x)] - [Node x rst -> - (cons x - (for/fold ([acc nil]) ([p (in-list (flatten rst))]) - (match p with - [x y -> (cons x (cons y acc))])))])) - -(check-type (flatten (Leaf 1)) : (List Int) -> (list 1)) -(check-type (flatten (Node 1 (Leaf (tup 2 3)))) : (List Int) -> (list 1 2 3)) -(check-type - (flatten (Node 1 (Node (tup 2 3) (Leaf (tup (tup 4 5) (tup 6 7)))))) - : (List Int) -> (list 1 6 7 4 5 2 3)) - - -;; catch type constructor arity error; should not loop -(define-type (BankersDeque A) - [BD Int (List A) Int (List A)]) - -(typecheck-fail - (define-type (ImplicitCatDeque A) - [Shall (BankersDeque A)] - [Dp (BankersDeque A) - (ImplicitCatDeque (BankersDeque A) (CmpdElem (BankersDeque A))) - (BankersDeque A) - (ImplicitCatDeque (BankersDeque A) (CmpdElem (BankersDeque A))) - (BankersDeque A)]) - #:with-msg "Improper use of constructor ImplicitCatDeque; expected 1 args, got 2") - -#;(define-type (CmpdElem A) - [Simple (BankersDeque A)] - [Cmpd (BankersDeque A) - (ImplicitCatDeque (BankersDeque (CmpdElem (BankersDeque A)))) - (BankersDeque A)]) - - -#;(typecheck-fail - (λ ([icd : (ImplicitCatDeque A)]) icd) - #:with-msg - "type constructor ImplicitCatDeque expects 1 args, given 2") diff --git a/tapl/tests/mlish/queens.mlish b/tapl/tests/mlish/queens.mlish @@ -1,186 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; function polymorphic in list element -(define-type (List X) - Nil - (Cons X (List X))) - -(typecheck-fail - (match (Cons 1 Nil) with - [Nil -> 1]) - #:with-msg "clauses not exhaustive; missing\\: Cons") -(typecheck-fail - (match (Cons 1 Nil) with - [Cons x xs -> 1]) - #:with-msg "clauses not exhaustive; missing: Nil") - -;; list fns ---------- - -; map: tests whether match and define properly propagate 'expected-type -(define (map [f : (→ X Y)] [lst : (List X)] → (List Y)) - (match lst with - [Nil -> Nil] - [Cons x xs -> (Cons (f x) (map f xs))])) -(check-type map : (→/test (→ X Y) (List X) (List Y))) -(check-type map : (→/test {Y X} (→ Y X) (List Y) (List X))) -(check-type map : (→/test (→ A B) (List A) (List B))) -(check-not-type map : (→/test (→ A B) (List B) (List A))) -(check-not-type map : (→/test (→ X X) (List X) (List X))) ; only 1 bound tyvar - -; map: alt signature syntax -(define (map2 f lst) - : (→ X Y) (List X) → (List Y) - (match lst with - [Nil -> Nil] - [Cons x xs -> (Cons (f x) (map2 f xs))])) -(check-type map2 : (→/test (→ X Y) (List X) (List Y))) -(check-type map2 : (→/test {Y X} (→ Y X) (List Y) (List X))) -(check-type map2 : (→/test (→ A B) (List A) (List B))) -(check-not-type map2 : (→/test (→ A B) (List B) (List A))) -(check-not-type map2 : (→/test (→ X X) (List X) (List X))) ; only 1 bound tyvar - -; nil without annotation; tests fn-first, left-to-right arg inference -; does work yet, need to add left-to-right inference in #%app -(check-type (map add1 Nil) : (List Int) ⇒ Nil) -(check-type (map add1 (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ (Cons 2 (Cons 3 (Cons 4 Nil)))) -(typecheck-fail (map add1 (Cons "1" Nil)) - #:with-msg "expected: Int\n *given: String") -(check-type (map (λ ([x : Int]) (+ x 2)) (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ (Cons 3 (Cons 4 (Cons 5 Nil)))) -;; ; doesnt work yet: all lambdas need annotations -;; (check-type (map (λ (x) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) - -(define (filter [p? : (→ X Bool)] [lst : (List X)] → (List X)) - (match lst with - [Nil -> Nil] - [Cons x xs -> (if (p? x) - (Cons x (filter p? xs)) - (filter p? xs))])) -(define (filter/guard [p? : (→ X Bool)] [lst : (List X)] → (List X)) - (match lst with - [Nil -> Nil] - [Cons x xs #:when (p? x) -> (Cons x (filter p? xs))] - [Cons x xs -> (filter p? xs)])) -(check-type (filter zero? Nil) : (List Int) ⇒ Nil) -(check-type (filter zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ Nil) -(check-type (filter zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 0 Nil)) -(check-type - (filter - (λ ([x : Int]) (not (zero? x))) - (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) -(check-type (filter/guard zero? Nil) : (List Int) ⇒ Nil) -(check-type (filter/guard zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) - : (List Int) ⇒ Nil) -(check-type (filter/guard zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 0 Nil)) -(check-type - (filter/guard - (λ ([x : Int]) (not (zero? x))) - (Cons 0 (Cons 1 (Cons 2 Nil)))) - : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) -; doesnt work yet: all lambdas need annotations -;(check-type (filter (λ (x) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) - -(define (foldr [f : (→ X Y Y)] [base : Y] [lst : (List X)] → Y) - (match lst with - [Nil -> base] - [Cons x xs -> (f x (foldr f base xs))])) -(define (foldl [f : (→ X Y Y)] [acc : Y] [lst : (List X)] → Y) - (match lst with - [Nil -> acc] - [Cons x xs -> (foldr f (f x acc) xs)])) - -(define (all? [p? : (→ X Bool)] [lst : (List X)] → Bool) - (match lst with - [Nil -> #t] - [Cons x xs #:when (p? x) -> (all? p? xs)] - [Cons x xs -> #f])) - -(define (tails [lst : (List X)] → (List (List X))) - (match lst with - [Nil -> (Cons Nil Nil)] - [Cons x xs -> (Cons lst (tails xs))])) - -(define (build-list [n : Int] [f : (→ Int X)] → (List X)) - (if (zero? (sub1 n)) - (Cons (f 0) Nil) - (Cons (f (sub1 n)) (build-list (sub1 n) f)))) - -(check-type (build-list 1 add1) - : (List Int) ⇒ (Cons 1 Nil)) -(check-type (build-list 3 add1) - : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 Nil)))) -(check-type (build-list 5 sub1) - : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 (Cons 0 (Cons -1 Nil)))))) - -;; map + filter + fold + build example -(define INPUT (build-list 1000 number->string)) -(check-type (foldl + 0 (filter even? (map string->number INPUT))) : Int -> 249500) - -(define (append [lst1 : (List X)] [lst2 : (List X)] → (List X)) - (match lst1 with - [Nil -> lst2] - [Cons x xs -> (Cons x (append xs lst2))])) - -;; n-queens -------------------- -(define-type Queen (Q Int Int)) - -(define (safe? [q1 : Queen] [q2 : Queen] → Bool) - (match q1 with - [Q x1 y1 -> - (match q2 with - [Q x2 y2 -> - (not (or (= x1 x2) - (= y1 y2) - (= (abs (- x1 x2)) - (abs (- y1 y2)))))])])) - -(define (safe/list? [qs : (List Queen)] → Bool) - (match qs with - [Nil -> #t] - [Cons q1 rst -> - (all? (λ ([q2 : Queen]) (safe? q1 q2)) rst)])) - -(define (valid? [lst : (List Queen)] → Bool) - (all? safe/list? (tails lst))) - -(define (nqueens [n : Int] → (List Queen)) - (let* ([process-row - (λ ([r : Int] - [all-possible-so-far : (List (List Queen))]) - (foldr - (λ ([qs : (List Queen)] - [new-qss : (List (List Queen))]) - (append - (map - (λ ([c : Int]) (Cons (Q r c) qs)) - (build-list n add1)) - new-qss)) - Nil - all-possible-so-far))] - [all-possible - (foldl process-row - (Cons Nil Nil) - (build-list n add1))]) - (let ([solns (filter valid? all-possible)]) - (match solns with - [Nil -> Nil] - [Cons x xs -> x])))) - -(check-type nqueens : (→ Int (List Queen))) -(check-type (nqueens 1) : (List Queen) ⇒ (Cons (Q 1 1) Nil)) -(check-type (nqueens 2) : (List Queen) ⇒ Nil) -(check-type (nqueens 3) : (List Queen) ⇒ Nil) -(check-type (nqueens 4) - : (List Queen) - ⇒ (Cons (Q 3 1) (Cons (Q 2 4) - (Cons (Q 1 2) (Cons (Q 4 3) Nil))))) -(check-type (nqueens 5) - : (List Queen) - ⇒ (Cons (Q 4 2) (Cons (Q 3 4) - (Cons (Q 2 1) (Cons (Q 1 3) (Cons (Q 5 5) Nil)))))) diff --git a/tapl/tests/mlish/result.mlish b/tapl/tests/mlish/result.mlish @@ -1,129 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt" "../../typed-lang-builder/mlish-do.rkt") - -(define-type (Result A B) - (Ok A) - (Error B)) - -(define (ok [a : A] → (Result A B)) - (Ok a)) -(define (error [b : B] → (Result A B)) - (Error b)) - -(provide-type Result) -(provide ok) -(provide error) - -(check-type ok : (→/test A (Result A B))) -(check-type error : (→/test B (Result A B))) -(check-type (inst ok Int String) : (→ Int (Result Int String))) -(check-type (inst error String Int) : (→ String (Result Int String))) - -(check-type - (list (Ok 3) (Error "abject failure") (Ok 4)) - : (List (Result Int String)) - -> (list (Ok 3) (Error "abject failure") (Ok 4))) - -(define (result-bind [a : (Result A Er)] [f : (→ A (Result B Er))] - → (Result B Er)) - (match a with - [Ok v -> (f v)] - [Error er -> (Error er)])) - -(provide result-bind) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; read-tree, a function that parses a tree and uses the result monad. - -(require "trees.mlish") - -;; Parsing 42 in base 10: (rev-list->int 10 (list 2 4) 1 0) yields 42. -(define (rev-list->int [base : Int] [rev-list : (List Int)] [place : Int] [accum : Int] → Int) - (cond - [(isnil rev-list) accum] - [else (rev-list->int base - (tail rev-list) - (* base place) - (+ accum (* place (head rev-list))))])) - -(define (digit? [c : Char] → Bool) - (or (equal? c #\0) - (equal? c #\1) - (equal? c #\2) - (equal? c #\3) - (equal? c #\4) - (equal? c #\5) - (equal? c #\6) - (equal? c #\7) - (equal? c #\8) - (equal? c #\9))) - -(define (digit->int [c : Char] → Int) - (string->number (string c))) - -(define-type-alias (Read-Result A) (Result (× A (List Char)) String)) - -(define (read-int [str : (List Char)] [accum : (List Int)] → (Read-Result Int)) - (cond - [(isnil str) - (cond [(isnil accum) (error "expected an int, given nothing")] - [else (ok (tup (rev-list->int 10 accum 1 0) str))])] - [(digit? (head str)) - (read-int (tail str) (cons (digit->int (head str)) accum))] - [else - (ok (tup (rev-list->int 10 accum 1 0) str))])) - -(define (read-tree [str : (List Char)] → (Read-Result (Tree Int))) - (cond - [(isnil str) - (error "expected a tree of integers, given nothing")] - [(equal? (head str) #\( ) - (let ([do-ok (inst ok Unit String)] - [do-error (inst error String Unit)]) - (do result-bind - [tree1+str <- (read-tree (tail str))] - [(cond [(equal? (head (proj tree1+str 1)) #\space) - (do-ok (void))] - [else (do-error "expected a space")])] - [int+str <- (read-int (tail (proj tree1+str 1)) nil)] - [(cond [(equal? (head (proj int+str 1)) #\space) - (do-ok (void))] - [else (do-error "expected a space")])] - [tree2+str <- (read-tree (tail (proj int+str 1)))] - [(cond [(equal? (head (proj tree2+str 1)) #\) ) - (do-ok (void))] - [else (do-error "expected a `)`")])] - (ok - (tup (Node (proj tree1+str 0) - (proj int+str 0) - (proj tree2+str 0)) - (tail (proj tree2+str 1))))))] - [(digit? (head str)) - (do result-bind - [int+str <- (read-int str nil)] - (ok - (tup (Leaf (proj int+str 0)) - (proj int+str 1))))] - [else - (error "expected either a `(` or a digit")])) - -(check-type - (read-tree (string->list "42")) - : (Read-Result (Tree Int)) - -> (ok - (tup (Leaf 42) nil))) - -(check-type - (read-tree (string->list "x")) - : (Read-Result (Tree Int)) - -> (error - "expected either a `(` or a digit")) - -(check-type - (read-tree (string->list "(42 43 (44 45 46))")) - : (Read-Result (Tree Int)) - -> (ok - (tup (Node (Leaf 42) 43 (Node (Leaf 44) 45 (Leaf 46))) nil))) - - diff --git a/tapl/tests/mlish/sweet-map.rkt b/tapl/tests/mlish/sweet-map.rkt @@ -1,20 +0,0 @@ -#lang sweet-exp "../../typed-lang-builder/mlish.rkt" - -define - sum [lst : (List Int)] → Int - match lst with - [] -> 0 - x :: xs -> - {x + sum(xs)} - -define - map [f : (→ X Y)] [lst : (List X)] → (List Y) - match lst with - [] -> nil - x :: xs -> - cons - f x - map f xs - -sum - map string->number (list "1" "2" "3") diff --git a/tapl/tests/mlish/term.mlish b/tapl/tests/mlish/term.mlish @@ -1,295 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -;; from chap 6 of RW OCaml - -;; checks: -;; - nested recursive types (see expr) -;; - labeled adts -;; - records -;; - ho polymorphic fn argument - -(define-type BasicColor - Black - Red - Green - Yellow - Blue - Magenta - Cyan - White) - -(check-type Cyan : BasicColor) - -(check-type (list Blue Magenta Red) : (List BasicColor)) - -(define (basic-color->int [c : BasicColor] -> Int) - (match c with - [Black -> 0] [Red -> 1] [Green -> 2] [Yellow -> 3] - [Blue -> 4] [Magenta -> 5] [Cyan -> 6] [White -> 7])) - -(define (map [f : (→ X Y)] [lst : (List X)] -> (List Y)) - (if (isnil lst) - nil - (cons (f (head lst)) (map f (tail lst))))) - -(check-type (map basic-color->int (list Blue Red)) - : (List Int) -> (list 4 1)) - -(define (color-by-number [n : Int] [txt : String] -> String) - (format "\e[38;5;~am~a\e[0m" n txt)) - -(define blue - (color-by-number (basic-color->int Blue) "Blue")) - -(check-type blue : String -> "\e[38;5;4mBlue\e[0m") - -(printf "Hello ~a World!\n" blue) - -(define-type Weight Regular Bold) -(define-type Color - (Basic BasicColor Weight) - (RGB Int Int Int) - (Gray Int)) - -(check-type (list (RGB 250 70 70) (Basic Green Regular)) - : (List Color)) - -(define (color->int [c : Color] -> Int) - (match c with - [Basic bc w -> - (let ([base (match w with [Bold -> 8] [Regular -> 0])]) - (+ base (basic-color->int bc)))] - [RGB r g b -> - (+ 16 (+ b (+ (* g 6) (* r 36))))] - [Gray i -> (+ 232 i)])) - -(define (color-print [c : Color] [s : String] -> Unit) - (printf "~a\n" (color-by-number (color->int c) s))) - -(color-print (Basic Red Bold) "A bold red!") -(color-print (Gray 4) "A muted gray...") - -;; refactoring Color and Weight -(define-type NewColor - (NewBasic BasicColor) - (NewBold BasicColor) - (NewRGB Int Int Int) - (NewGray Int)) - -(typecheck-fail - (match (NewGray 1) with - [Basic bc w -> - (let ([base (match w with [Bold -> 8] [Regular -> 0])]) - (+ base (basic-color->int bc)))] - [RGB r g b -> - (+ 16 (+ b (+ (* g 6) (* r 36))))] - [Gray i -> (+ 232 i)]) - #:with-msg - "clauses not exhaustive; missing: NewGray, NewRGB, NewBold, NewBasic") - -(typecheck-fail - (match (NewGray 1) with - [NewBasic bc w -> - (let ([base (match w with [Bold -> 8] [Regular -> 0])]) - (+ base (basic-color->int bc)))] - [NewRGB r g b -> - (+ 16 (+ b (+ (* g 6) (* r 36))))] - [NewGray i -> (+ 232 i)]) - #:with-msg "clauses not exhaustive; missing: NewBold") - -(typecheck-fail - (match (NewGray 1) with - [NewBasic bc w -> - (let ([base (match w with [Bold -> 8] [Regular -> 0])]) - (+ base (basic-color->int bc)))] - [NewBold bc -> 1] - [NewRGB r g b -> - (+ 16 (+ b (+ (* g 6) (* r 36))))] - [NewGray i -> (+ 232 i)])) ; todo: better err msg for arity - -(check-type - (match (NewGray 1) with - [NewBasic bc -> (basic-color->int bc)] - [NewBold bc -> (+ 8 (basic-color->int bc))] - [NewRGB r g b -> - (+ 16 (+ b (+ (* g 6) (* r 36))))] - [NewGray i -> (+ 232 i)]) : Int) - -;; 2016-03-09: match currently does not support else -(define-type Details - (Logon [user : String] [credentials : String]) - (Heartbeat [status : String]) - (LogEntry [important? : Bool] [msg : String])) - -(define-type-alias SessionID String) -(define-type-alias Time String) -(define-type-alias Common (× SessionID Time)) - -(define-type-alias Msg (× Common Details)) - -(define (foldl [f : (→ X Y Y)] [init : Y] [lst : (List X)] -> Y) - (if (isnil lst) - init - (foldl f (f (head lst) init) (tail lst)))) - -(define (msgs-for-user [user : String] [msgs : (List Msg)] -> (List Msg)) - (match - (foldl - (λ ([m : Msg] [res : (× (List Msg) (List SessionID))]) - (match res with - [ms_out ids_out -> - (match m with - [common details -> - (match common with - [id t -> - (match details with - [Logon u c -> (if (string=? u user) - (tup (cons m ms_out) (cons id ids_out)) - res)] - [Heartbeat st -> (if (member id ids_out) - (tup (cons m ms_out) ids_out) - res)] - [LogEntry i? lmgs -> (if (member id ids_out) - (tup (cons m ms_out) ids_out) - res)])])])])) - (tup nil nil) - msgs) with - [msgs ids -> (reverse msgs)])) - -;; this is incomplete (and wrong, eg logentry has wrong arity) code in the book -(define (handle-msg [state : Int] [msg : Msg] -> String) - (match msg with - [common details -> - (match details with - [LogEntry i? lmsg -> lmsg] - [Logon u c -> u] - [Heartbeat s -> s])])) - -;; expr example -(define-type (Expr X) - (Base X) - (Const Bool) - (And (List (Expr X))) - (Or (List (Expr X))) - (Not (Expr X))) - -(define-type MailField To From CC Date Subject) - -(define-type-alias MailPred (×× [field : MailField] - [contains? : String])) - -(define (test [f : MailField] [c? : String] -> (Expr MailPred)) - (Base (rec [field = f] [contains? = c?]))) - -(check-type (rec [field = To] [contains = "doligez"]) - : (×× [field : MailField] [contains : String])) - -(check-type (get (rec [field = To] [contains = "doligez"]) field) - : MailField -> To) - -(check-type - (And (list (Or (list (Base (rec [field = To] [contains? = "doligez"])) - (Base (rec [field = CC] [contains? = "doligez"])))) - (Base (rec [field = Subject] [contains? = "runtime"])))) - : (Expr MailPred)) - -(define (andmap [f : (→ X Bool)] [lst : (List X)] -> Bool) - (if (isnil lst) - #t - (and (f (head lst)) (andmap f (tail lst))))) -(define (ormap [f : (→ X Bool)] [lst : (List X)] -> Bool) - (if (isnil lst) - #f - (or (f (head lst)) (ormap f (tail lst))))) - -(define (filter [p? : (→ X Bool)] [lst : (List X)] -> (List X)) - (if (isnil lst) - nil - (if (p? (head lst)) - (cons (head lst) (filter p? (tail lst))) - (filter p? (tail lst))))) - -(define (eval [e : (Expr X)] [eval-base : (→ X Bool)] -> Bool) - (let ([eval2 (λ ([e : (Expr X)]) (eval e eval-base))]) - (match e with - [Base base -> (eval-base base)] - [Const b -> b] - [And es -> (andmap eval2 es)] - [Or es -> (ormap eval2 es)] - [Not e -> (not (eval2 e))]))) - -(define (andfn [lst : (List (Expr X))] -> (Expr X)) - (if (member (Const #f) lst) - (Const #f) - (let ([lst2 - (filter (λ ([x : (Expr X)]) (not (equal? x (Const #t)))) lst)]) - (if (isnil lst2) - (Const #t) - (if (isnil (tail lst2)) - (head lst2) - (And lst2)))))) - -(define (orfn [lst : (List (Expr X))] -> (Expr X)) - (if (member (Const #t) lst) - (Const #t) - (let ([lst2 - (filter (λ ([x : (Expr X)]) (not (equal? x (Const #f)))) lst)]) - (if (isnil lst2) - (Const #f) - (if (isnil (tail lst2)) - (head lst2) - (And lst2)))))) - -(define (notfn [e : (Expr X)] -> (Expr X)) - (match e with - [Base b -> (Not e)] - [Const b -> (Const (not b))] - [And es -> (Not e)] - [Or es -> (Not e)] - [Not e2 -> (Not e)])) - -(define (simplify [e : (Expr X)] -> (Expr X)) - (match e with - [Base b -> e] - [Const x -> e] - [And es -> (andfn (map (inst simplify X) es))] - [Or es -> (orfn (map (inst simplify X) es))] - [Not e -> (notfn (simplify e))])) - -(check-type - (simplify (Not (And (list (Or (list (Base "it's snowing") - (Const #t))) - (Base "it's raining"))))) - : (Expr String) - -> (Not (Base "it's raining"))) - -(check-type - (simplify (Not (And (list (Or (list (Base "it's snowing") - (Const #t))) - (Not (Not (Base "it's raining"))))))) - : (Expr String) - -> (Not (Not (Not (Base "it's raining"))))) - -(define (notfn2 [e : (Expr X)] -> (Expr X)) - (match e with - [Const b -> (Const (not b))] - [Base b -> (Not e)] - [And es -> (Not e)] - [Or es -> (Not e)] - [Not e -> e])) - -(define (simplify2 [e : (Expr X)] -> (Expr X)) - (match e with - [Base b -> e] - [Const x -> e] - [And es -> (andfn (map (inst simplify2 X) es))] - [Or es -> (orfn (map (inst simplify2 X) es))] - [Not e -> (notfn2 (simplify2 e))])) - -(check-type - (simplify2 (Not (And (list (Or (list (Base "it's snowing") - (Const #t))) - (Not (Not (Base "it's raining"))))))) - : (Expr String) - -> (Not (Base "it's raining"))) diff --git a/tapl/tests/mlish/trees-tests.mlish b/tapl/tests/mlish/trees-tests.mlish @@ -1,51 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") -(require "trees.mlish") - -(define (make [item : Int] [depth : Int] -> (Tree Int)) - (if (zero? depth) - (Leaf item) - (let ([item2 (* item 2)] - [depth2 (sub1 depth)]) - (Node (make (sub1 item2) depth2) - item - (make item2 depth2))))) - -(define tree1 (make 4 1)) -(define tree2 (make 3 2)) - -(check-type tree1 - : (Tree Int) -> (Node (Leaf 7) 4 (Leaf 8))) - -(check-type tree2 - : (Tree Int) - -> (Node - (Node (Leaf 9) 5 (Leaf 10)) - 3 - (Node (Leaf 11) 6 (Leaf 12)))) - -(define (sum [t : (Tree Int)] -> Int) - (match t with - [Leaf v -> v] - [Node l v r -> (+ (+ (sum l) v) (sum r))])) - -(check-type (sum tree1) : Int -> 19) -(check-type (sum tree2) : Int -> 56) - -(define (check/acc [t : (Tree Int)] [acc : Int] -> Int) - (match t with - [Leaf v -> - (+ acc v)] - [Node l v r -> - (check/acc l (- acc (check/acc r 0)))])) -(define (check [t : (Tree Int)] -> Int) - (check/acc t 0)) - -(define min-depth 4) - -(define (main [n : Int] -> Int) - (let* ([max-depth (max (+ min-depth 2) n)] - [stretch-depth (add1 max-depth)]) - (check (make 0 stretch-depth)))) - -(check-type (main 17) : Int -> 0) diff --git a/tapl/tests/mlish/trees.mlish b/tapl/tests/mlish/trees.mlish @@ -1,8 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define-type (Tree X) - (Leaf X) - (Node (Tree X) X (Tree X))) - -(provide-type Tree Leaf Node) diff --git a/tapl/tests/mlish/value-restriction-example.mlish b/tapl/tests/mlish/value-restriction-example.mlish @@ -1,25 +0,0 @@ -#lang s-exp "../../typed-lang-builder/mlish.rkt" -(require "../rackunit-typechecking.rkt") - -(define-type (Option X) - None - (Some X)) - -(define (make-f → (→ A A)) - (let ([r (ref (None {A}))]) - (λ (x) - (let ([y (deref r)]) - (begin - (:= r (Some x)) - (match y with - [None -> x] - [Some y -> y])))))) -;; This has to fail, because if could succeed with the type (→ A A), -;; then it could cause unsoundness. -(typecheck-fail (make-f) #:with-msg "Could not infer instantiation of polymorphic function make-f.") -; ;; If f were defined as the result of (make-f), then it would result -; ;; in unsoundess if these two expressions were also accepted: -; (f 13) -; ;; Because this would typecheck as a String even though it returns 13, an Int: -; (f "foo") - diff --git a/tapl/tests/rackunit-typechecking.rkt b/tapl/tests/rackunit-typechecking.rkt @@ -1,92 +0,0 @@ -#lang racket/base -(require (for-syntax rackunit syntax/srcloc) rackunit "../typecheck.rkt") -(provide check-type typecheck-fail check-not-type check-props check-runtime-exn) - -(begin-for-syntax - (define (add-esc s) (string-append "\\" s)) - (define escs (map add-esc '("(" ")" "[" "]"))) - (define (replace-brackets str) - (regexp-replace* "\\]" (regexp-replace* "\\[" str "(") ")")) - (define (add-escs str) - (replace-brackets - (foldl (lambda (c s) (regexp-replace* c s (add-esc c))) str escs))) - (define (expected tys #:given [givens ""] #:note [note ""]) - (string-append - note ".*Expected.+argument\\(s\\) with type\\(s\\).+" - (add-escs tys) ".*Given:.*" - (string-join (map add-escs (string-split givens ", ")) ".*")))) - -(define-syntax (check-type stx) - (syntax-parse stx #:datum-literals (: ⇒ ->) - ;; duplicate code to avoid redundant expansions - [(_ e : τ-expected (~or ⇒ ->) v) - #:with e+ (expand/df #'(add-expected e τ-expected)) - #:with τ (typeof #'e+) - #:fail-unless (typecheck? #'τ ((current-type-eval) #'τ-expected)) - (format - "Expression ~a [loc ~a:~a] has type ~a, expected ~a" - (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) - (type->str #'τ) (type->str #'τ-expected)) - (syntax/loc stx (check-equal? e+ (add-expected v τ-expected)))] - [(_ e : τ-expected) - #:with τ (typeof (expand/df #'(add-expected e τ-expected))) - #:fail-unless - (typecheck? #'τ ((current-type-eval) #'τ-expected)) - (format - "Expression ~a [loc ~a:~a] has type ~a, expected ~a" - (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) - (type->str #'τ) (type->str #'τ-expected)) - #'(void)])) - -;; for checking properties other than types -(define-syntax (check-props stx) - (syntax-parse stx #:datum-literals (: ⇒ ->) - [(_ prop e : v (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e]))) - #:with props (or (syntax-property (expand/df #'e) (syntax->datum #'prop)) - #'()) - #:fail-unless (equal? (syntax->datum #'v) - (syntax->datum #'props)) - (format - "Expression ~a [loc ~a:~a:~a] does not have prop ~a, actual: ~a" - (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) (syntax-position #'e) - (syntax->datum #'v) (syntax->datum #'props)) - (syntax/loc stx (check-equal? e v2))])) - -(define-syntax (check-not-type stx) - (syntax-parse stx #:datum-literals (:) - [(_ e : not-τ) - #:with τ (typeof (expand/df #'e)) - #:fail-when - (typecheck? #'τ ((current-type-eval) #'not-τ)) - (format - "(~a:~a) Expression ~a has type ~a; should not typecheck with ~a" - (syntax-line stx) (syntax-column stx) - (syntax->datum #'e) (type->str #'τ) (type->str #'not-τ)) - #'(void)])) - -(define-syntax (typecheck-fail stx) - (syntax-parse stx #:datum-literals (:) - [(_ e (~optional (~seq #:with-msg msg-pat) #:defaults ([msg-pat #'""]))) - #:with msg:str - (eval-syntax (datum->syntax #'here (syntax->datum #'msg-pat))) - #:when (with-check-info* - (list (make-check-expected (syntax-e #'msg)) - (make-check-expression (syntax->datum stx)) - (make-check-location (build-source-location-list stx)) - (make-check-name 'typecheck-fail) - (make-check-params (list (syntax->datum #'e) (syntax-e #'msg)))) - (λ () - (check-exn - (λ (ex) - (and (or (exn:fail? ex) (exn:test:check? ex)) - ; check err msg matches - (regexp-match? (syntax-e #'msg) (exn-message ex)))) - (λ () - (expand/df #'e))))) - #'(void)])) - -(define-syntax (check-runtime-exn stx) - (syntax-parse stx - [(_ e) - #:with e- (expand/df #'e) - (syntax/loc stx (check-exn exn:fail? (lambda () e-)))])) diff --git a/tapl/tests/run-all-tests.rkt b/tapl/tests/run-all-tests.rkt @@ -1,37 +0,0 @@ -#lang racket - -;; stlc and extensions -(require "stlc-tests.rkt") -(require "stlc+lit-tests.rkt") -(require "ext-stlc-tests.rkt") -(require "stlc+tup-tests.rkt") -(require "stlc+reco+var-tests.rkt") -(require "stlc+cons-tests.rkt") -(require "stlc+box-tests.rkt") - -(require "stlc+rec-iso-tests.rkt") - -(require "exist-tests.rkt") - -;; subtyping -(require "stlc+sub-tests.rkt") -(require "stlc+reco+sub-tests.rkt") - -;; system F -(require "sysf-tests.rkt") - -(require "fsub-tests.rkt") ; sysf + reco-sub - -;; F_omega -(require "fomega-tests.rkt") -(require "fomega2-tests.rkt") -(require "fomega3-tests.rkt") - -(require "stlc+occurrence-tests.rkt") -(require "stlc+overloading-tests.rkt") - -;; type inference -(require "infer-tests.rkt") - -;; type and effects -(require "stlc+effect-tests.rkt") diff --git a/tapl/tests/stlc+box-tests.rkt b/tapl/tests/stlc+box-tests.rkt @@ -1,239 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+box.rkt" -(require "rackunit-typechecking.rkt") - -(define x (ref 10)) -(check-type x : (Ref Int)) -(check-type (deref x) : Int ⇒ 10) -(check-type (:= x 20) : Unit) ; x still 10 because check-type does not evaluate -(check-type (begin (:= x 20) (deref x)) : Int ⇒ 20) -(check-type x : (Ref Int)) -(check-type (deref (ref 20)) : Int ⇒ 20) -(check-type (deref x) : Int ⇒ 20) - -(check-type ((λ ([b : (Ref Int)]) (deref b)) (ref 10)) : Int ⇒ 10) -(check-type ((λ ([b : (Ref Int)]) (begin (begin (:= b 20) (deref b)))) (ref 10)) : Int ⇒ 20) - -;; Ref err msgs -; wrong arity -(typecheck-fail - (λ ([lst : (Ref Int Int)]) lst) - #:with-msg - "Improper usage of type constructor Ref: \\(Ref Int Int\\), expected = 1 arguments") -(typecheck-fail - (λ ([lst : (Ref)]) lst) - #:with-msg - "Improper usage of type constructor Ref: \\(Ref\\), expected = 1 arguments") -(typecheck-fail - (deref 1) - #:with-msg - "Expected Ref type, got: Int") -(typecheck-fail - (:= 1 1) - #:with-msg - "Expected Ref type, got: Int") - -;; previous tests: ------------------------------------------------------------ -(typecheck-fail (cons 1 2)) -;(typecheck-fail (cons 1 nil)) ; works now -(check-type (cons 1 nil) : (List Int)) -(check-type (cons 1 (nil {Int})) : (List Int)) -(typecheck-fail nil) -(typecheck-fail (nil Int)) -(typecheck-fail (nil (Int))) -; passes bc ⇒-rhs is only used for its runtime value -(check-type (nil {Int}) : (List Int) ⇒ (nil {Bool})) -(check-not-type (nil {Bool}) : (List Int)) -(check-type (nil {Bool}) : (List Bool)) -(check-type (nil {(→ Int Int)}) : (List (→ Int Int))) -(define fn-lst (cons (λ ([x : Int]) (+ 10 x)) (nil {(→ Int Int)}))) -(check-type fn-lst : (List (→ Int Int))) -(check-type (isnil fn-lst) : Bool ⇒ #f) -(typecheck-fail (isnil (head fn-lst))) ; head lst is not List -(check-type (isnil (tail fn-lst)) : Bool ⇒ #t) -(check-type (head fn-lst) : (→ Int Int)) -(check-type ((head fn-lst) 25) : Int ⇒ 35) -(check-type (tail fn-lst) : (List (→ Int Int)) ⇒ (nil {(→ Int Int)})) - -;; previous tests: ------------------------------------------------------------ -;; define-type-alias -(define-type-alias Integer Int) -(define-type-alias ArithBinOp (→ Int Int Int)) - -(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) -(check-type + : ArithBinOp) -(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) - -(check-type "Stephen" : String) -(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [male? : Bool])) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) - : Int ⇒ 781) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) - : Bool ⇒ #t) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [my-name : String] [phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [my-phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [is-male? : Bool])) - - -(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) -(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) - (var coffee = (void) as (∨ [coffee : Unit])))) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - : (∨ [coffee : Unit] [tea : Unit])) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1])) ; not enough clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [teaaaaaa x => 2])) ; wrong clause -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [tea x => 2] - [coke x => 3])) ; too many clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => "1"] - [tea x => 2])) ; mismatched branch types -(check-type - (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) - [coffee x => x] - [tea x => 2]) : Int ⇒ 1) -(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) -(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) -(check-type - (case ((λ ([d : Drink]) d) - (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -(check-type - (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -;; previous tests: ------------------------------------------------------------ -;; tests for tuples ----------------------------------------------------------- -; fail bc tuple changed syntax -;(check-type (tup 1 2 3) : (× Int Int Int)) -;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) -; -;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) -;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") -;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) -;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large -;(typecheck-fail (proj 1 2)) ; not tuple - -;; ext-stlc.rkt tests --------------------------------------------------------- -;; should still pass - -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) -(typecheck-fail ((λ ([x : Unit]) x) 2)) -(typecheck-fail ((λ ([x : Unit])) void)) -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(typecheck-fail (begin)) -(check-type (begin 1) : Int) -;; 2016-03-06: begin terms dont need to be Unit -(check-type (begin 1 2 3) : Int) -#;(typecheck-fail - (begin 1 2 3) - #:with-msg "Expected expression 1 to have Unit type, got: Int") -(check-type (begin (void) 1) : Int ⇒ 1) - -;;ascription -(typecheck-fail (ann 1 : Bool)) -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(typecheck-fail (let ([x #f]) (+ x 1))) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) - -; letrec -(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) -(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/stlc+cons-tests.rkt b/tapl/tests/stlc+cons-tests.rkt @@ -1,229 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+cons.rkt" -(require "rackunit-typechecking.rkt") - -(typecheck-fail (cons 1 2) - #:with-msg "expected \\(List Int\\), given Int\n *expression: 2") -;(typecheck-fail (cons 1 nil) -; #:with-msg "nil: requires type annotation") -(check-type (cons 1 nil) : (List Int)) -(check-type (cons 1 (nil {Int})) : (List Int)) -(typecheck-fail nil #:with-msg "nil: no expected type, add annotations") -(typecheck-fail - (nil Int) - #:with-msg - "Improperly formatted type annotation: Int; should have shape {τ}, where τ is a valid type.") -(typecheck-fail - (nil (Int)) - #:with-msg - "Improperly formatted type annotation: \\(Int\\); should have shape {τ}, where τ is a valid type.") -(typecheck-fail - (λ ([lst : (List Int Int)]) lst) - #:with-msg - "Improper usage of type constructor List: \\(List Int Int\\), expected = 1 arguments") -(typecheck-fail - (λ ([lst : (List)]) lst) - #:with-msg - "Improper usage of type constructor List: \\(List\\), expected = 1 arguments") -;; passes bc ⇒-rhs is only used for its runtime value -(check-type (nil {Int}) : (List Int) ⇒ (nil {Bool})) -(check-not-type (nil {Bool}) : (List Int)) -(check-type (nil {Bool}) : (List Bool)) -(check-type (nil {(→ Int Int)}) : (List (→ Int Int))) -(define fn-lst (cons (λ ([x : Int]) (+ 10 x)) (nil {(→ Int Int)}))) -(check-type fn-lst : (List (→ Int Int))) -(check-type (isnil fn-lst) : Bool ⇒ #f) -(typecheck-fail - (isnil (head fn-lst)) - #:with-msg - "Expected List type, got: \\(→ Int Int\\)") -(check-type (isnil (tail fn-lst)) : Bool ⇒ #t) -(check-type (head fn-lst) : (→ Int Int)) -(check-type ((head fn-lst) 25) : Int ⇒ 35) -(check-type (tail fn-lst) : (List (→ Int Int)) ⇒ (nil {(→ Int Int)})) - -; more list errors -(typecheck-fail - (cons 1 1) - #:with-msg - "expected \\(List Int\\), given Int\n *expression: 1") - -;; previous tests: ------------------------------------------------------------ -;; define-type-alias -(define-type-alias Integer Int) -(define-type-alias ArithBinOp (→ Int Int Int)) - -(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) -(check-type + : ArithBinOp) -(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) - -;; records (ie labeled tuples) -(check-type "Stephen" : String) -(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [male? : Bool])) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) - : Int ⇒ 781) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) - : Bool ⇒ #t) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [my-name : String] [phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [my-phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [is-male? : Bool])) - - -(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) -(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) - (var coffee = (void) as (∨ [coffee : Unit])))) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - : (∨ [coffee : Unit] [tea : Unit])) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1])) ; not enough clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - ["teaaaaaa" x => 2])) ; wrong clause -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [tea x => 2] - [coke x => 3])) ; too many clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => "1"] - [tea x => 2])) ; mismatched branch types -(check-type - (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) - [coffee x => x] - [tea x => 2]) : Int ⇒ 1) -(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) -(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) -(check-type - (case ((λ ([d : Drink]) d) - (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -(check-type - (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -;; previous tests: ------------------------------------------------------------ -;; tests for tuples ----------------------------------------------------------- -; fail because changed tuple syntax -;(check-type (tup 1 2 3) : (× Int Int Int)) -;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) -; -;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) -;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") -;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) -;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large -;(typecheck-fail (proj 1 2)) ; not tuple - -;; ext-stlc.rkt tests --------------------------------------------------------- -;; should still pass - -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) -(typecheck-fail ((λ ([x : Unit]) x) 2)) -(typecheck-fail ((λ ([x : Unit])) void)) -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(typecheck-fail (begin)) -(check-type (begin 1) : Int) -;(typecheck-fail (begin 1 2 3)) -(check-type (begin (void) 1) : Int ⇒ 1) - -;;ascription -(typecheck-fail (ann 1 : Bool)) -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(typecheck-fail (let ([x #f]) (+ x 1))) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) - -;; letrec -(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) -(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; tests from stlc+lit-tests.rkt -------------------------- -;; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;;(typecheck-fail "one") ; literal now supported -;;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -;(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type -;;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/stlc+effect-tests.rkt b/tapl/tests/stlc+effect-tests.rkt @@ -1,241 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+effect.rkt" -(require "rackunit-typechecking.rkt") - -(check-props ν (ref 11) : '(107)) -(check-props ! (deref (ref 11)) : '(141)) -(check-props ν (deref (ref 11)) : '(190)) -(check-props ν ((λ ([x : Int]) (ref x)) 21) : '(241)) - -(define x (ref 10)) -(check-type x : (Ref Int)) -(check-type (deref x) : Int ⇒ 10) -(check-type (:= x 20) : Unit) ; x still 10 because check-type does not evaluate -(check-type (begin (:= x 20) (deref x)) : Int ⇒ 20) -(check-type x : (Ref Int)) -(check-type (deref (ref 20)) : Int ⇒ 20) -(check-type (deref x) : Int ⇒ 20) - -(check-type ((λ ([b : (Ref Int)]) (deref b)) (ref 10)) : Int ⇒ 10) -(check-type ((λ ([x : Int]) x) ((λ ([b : (Ref Int)]) (deref b)) (ref 10))) : Int ⇒ 10) -(check-type ((λ ([b : (Ref Int)]) (begin (begin (:= b 20) (deref b)))) (ref 10)) : Int ⇒ 20) - -;; Ref err msgs -; wrong arity -(typecheck-fail - (λ ([lst : (Ref Int Int)]) lst) - #:with-msg - "Improper usage of type constructor Ref: \\(Ref Int Int\\), expected = 1 arguments") -(typecheck-fail - (λ ([lst : (Ref)]) lst) - #:with-msg - "Improper usage of type constructor Ref: \\(Ref\\), expected = 1 arguments") -(typecheck-fail - (deref 1) - #:with-msg - "Expected Ref type, got: Int") -(typecheck-fail - (:= 1 1) - #:with-msg - "Expected Ref type, got: Int") - -;; previous tests: ------------------------------------------------------------ -(typecheck-fail (cons 1 2)) -;(typecheck-fail (cons 1 nil)) ; works now -(check-type (cons 1 nil) : (List Int)) -(check-type (cons 1 (nil {Int})) : (List Int)) -(typecheck-fail nil) -(typecheck-fail (nil Int)) -(typecheck-fail (nil (Int))) -; passes bc ⇒-rhs is only used for its runtime value -(check-type (nil {Int}) : (List Int) ⇒ (nil {Bool})) -(check-not-type (nil {Bool}) : (List Int)) -(check-type (nil {Bool}) : (List Bool)) -(check-type (nil {(→ Int Int)}) : (List (→ Int Int))) -(define fn-lst (cons (λ ([x : Int]) (+ 10 x)) (nil {(→ Int Int)}))) -(check-type fn-lst : (List (→ Int Int))) -(check-type (isnil fn-lst) : Bool ⇒ #f) -(typecheck-fail (isnil (head fn-lst))) ; head lst is not List -(check-type (isnil (tail fn-lst)) : Bool ⇒ #t) -(check-type (head fn-lst) : (→ Int Int)) -(check-type ((head fn-lst) 25) : Int ⇒ 35) -(check-type (tail fn-lst) : (List (→ Int Int)) ⇒ (nil {(→ Int Int)})) - -;; previous tests: ------------------------------------------------------------ -;; define-type-alias -(define-type-alias Integer Int) -(define-type-alias ArithBinOp (→ Int Int Int)) - -(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) -(check-type + : ArithBinOp) -(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) - -(check-type "Stephen" : String) -(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [male? : Bool])) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) - : Int ⇒ 781) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) - : Bool ⇒ #t) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [my-name : String] [phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [my-phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [is-male? : Bool])) - - -(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) -(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) - (var coffee = (void) as (∨ [coffee : Unit])))) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - : (∨ [coffee : Unit] [tea : Unit])) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1])) ; not enough clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [teaaaaaa x => 2])) ; wrong clause -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [tea x => 2] - [coke x => 3])) ; too many clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => "1"] - [tea x => 2])) ; mismatched branch types -(check-type - (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) - [coffee x => x] - [tea x => 2]) : Int ⇒ 1) -(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) -(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) -(check-type - (case ((λ ([d : Drink]) d) - (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -(check-type - (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -;; previous tests: ------------------------------------------------------------ -;; tests for tuples ----------------------------------------------------------- -; fail bc tuple changed syntax -;(check-type (tup 1 2 3) : (× Int Int Int)) -;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) -;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) -; -;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) -;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") -;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) -;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large -;(typecheck-fail (proj 1 2)) ; not tuple - -;; ext-stlc.rkt tests --------------------------------------------------------- -;; should still pass - -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) -(typecheck-fail ((λ ([x : Unit]) x) 2)) -(typecheck-fail ((λ ([x : Unit])) void)) -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(typecheck-fail (begin)) -(check-type (begin 1) : Int) -;(typecheck-fail (begin 1 2 3)) -(check-type (begin (void) 1) : Int ⇒ 1) - -;;ascription -(typecheck-fail (ann 1 : Bool)) -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(typecheck-fail (let ([x #f]) (+ x 1))) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) - -; letrec -(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) -(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/stlc+lit-tests.rkt b/tapl/tests/stlc+lit-tests.rkt @@ -1,65 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+lit.rkt" -(require "rackunit-typechecking.rkt") - -;; thunk -(check-type (λ () 1) : (→ Int)) - -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) - -(typecheck-fail "one" #:with-msg "Unsupported literal") -(typecheck-fail #f #:with-msg "Unsupported literal") - -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) - -(typecheck-fail - (λ ([x : →]) x) - #:with-msg "Improper usage of type constructor →: →, expected >= 1 arguments") -(typecheck-fail - (λ ([x : (→ →)]) x) - #:with-msg "Improper usage of type constructor →: →, expected >= 1 arguments") -(typecheck-fail - (λ ([x : (→)]) x) - #:with-msg "Improper usage of type constructor →: \\(→\\), expected >= 1 arguments") - -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) - -(typecheck-fail ((λ ([x : Bool]) x) 1) - #:with-msg "Bool: unbound identifier") -(typecheck-fail (λ ([x : (→ Bool Bool)]) x) - #:with-msg "Bool: unbound identifier") -(typecheck-fail (λ ([x : Bool]) x) - #:with-msg "Bool: unbound identifier") -(typecheck-fail - (λ ([f : Int]) (f 1 2)) - #:with-msg - "Expected → type, got: Int") - -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) - -(typecheck-fail - (+ 1 (λ ([x : Int]) x)) - #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: \\(λ \\(\\(x : Int\\)\\) x\\)") -(typecheck-fail - (λ ([x : (→ Int Int)]) (+ x x)) - #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: x") -(typecheck-fail - ((λ ([x : Int] [y : Int]) y) 1) - #:with-msg "wrong number of arguments: expected 2, given 1") - -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - -(typecheck-fail (λ ([x : (→ 1 2)]) x) #:with-msg "not a valid type") -(typecheck-fail (λ ([x : 1]) x) #:with-msg "not a valid type") -(typecheck-fail (λ ([x : (+ 1 2)]) x) #:with-msg "not a valid type") -(typecheck-fail (λ ([x : (λ ([y : Int]) y)]) x) #:with-msg "not a valid type") - -(typecheck-fail - (ann (ann 5 : Int) : (→ Int)) - #:with-msg "expected \\(→ Int\\), given Int\n *expression: \\(ann 5 : Int\\)") - diff --git a/tapl/tests/stlc+occurrence-tests.rkt b/tapl/tests/stlc+occurrence-tests.rkt @@ -1,618 +0,0 @@ -#lang s-exp "../stlc+occurrence.rkt" -(require "rackunit-typechecking.rkt") - -;; ----------------------------------------------------------------------------- -;; basic types & syntax - -(check-type 1 : Int) -(check-type #f : Boolean) -(check-type "hello" : Str) -(check-type 1 : Top) -(check-type (λ ([x : (∪ Boolean Int)]) x) - : (→ (∪ Boolean Int) (∪ Boolean Int))) - -(typecheck-fail - (λ ([x : ∪]) x) - #:with-msg "Improper usage of type constructor ∪: ∪, expected >= 1 arguments") -(typecheck-fail - (λ ([x : (∪)]) x) - #:with-msg "Improper usage of type constructor ∪") -(typecheck-fail - (λ ([x : (∪ ∪)]) x) - #:with-msg "Improper usage of type constructor ∪") -(typecheck-fail - (λ ([x : (1 ∪)]) x) - #:with-msg "") -(typecheck-fail - (λ ([x : (Int ∪)]) x) - #:with-msg "expected identifier") -(typecheck-fail - (λ ([x : (→ ∪ ∪)]) x) - #:with-msg "Improper usage of type constructor ∪") -(typecheck-fail - (λ ([x : (→ Int ∪)]) x) - #:with-msg "Improper usage of type constructor ∪: ∪, expected >= 1 arguments") -(typecheck-fail - (λ ([x : (∪ Int →)]) x) - #:with-msg "Improper usage of type constructor →: →, expected >= 1 arguments") - -;; ----------------------------------------------------------------------------- -;; --- type evaluation - -(check-type (λ ([x : (∪ Int Int Int Int)]) x) - : (→ Int Int)) -(check-type (λ ([x : (∪ Int Boolean)]) 42) - : (→ (∪ Boolean Int) Int)) -(check-type (λ ([x : (∪ Int Boolean Boolean Int)]) x) - : (→ (∪ Boolean Int) (∪ Boolean Int))) -(check-type (λ ([x : (∪ (∪ Int Boolean))]) 42) - : (→ (∪ Int Boolean) Int)) -(check-type (λ ([x : (∪ Int Boolean)]) 42) - : (→ (∪ (∪ Int Boolean)) Int)) -(check-type (λ ([x : (∪ Int Boolean)]) 42) - : (→ (∪ (∪ Int Boolean) (∪ Int Boolean)) Int)) - - -;; ----------------------------------------------------------------------------- -;; --- subtyping - -;; ---- basics -(check-type 1 : (∪ Int)) -(check-type 1 : (∪ (∪ Int))) -(check-type (λ ([x : Int]) x) - : (→ Bot Top)) - -(check-not-type 1 : (∪ Boolean)) - -;; - AMB : t <: t' => t <: (U ... t' ...) -(check-type 1 : (∪ Boolean Int)) -(check-type -1 : (∪ Int Boolean)) -(check-type 1 : (∪ Boolean Int (→ Boolean Boolean))) -(check-type 1 : (∪ (∪ Int Boolean) (∪ Int Boolean))) - -(check-not-type 1 : (∪ Boolean (→ Int Int))) - -;; --- EXT : (U t' ...) <: (U t t' ...) -(check-type (λ ([x : (∪ Int Boolean)]) x) - : (→ (∪ Int Boolean) (∪ Int Boolean Str))) -(check-type (λ ([x : (∪ Int Boolean)]) x) - : (→ (∪ Boolean) (∪ Int Boolean Str))) - -(check-not-type (λ ([x : (∪ Int Boolean)]) x) - : (→ (∪ Int Boolean) (∪ Int))) -(check-not-type (λ ([x : (∪ Int Boolean)]) x) - : (→ (∪ Boolean Int Str) (∪ Int Boolean))) - -;; --- SUB : a<:b => (U a t' ...) <: (U b t' ...) -(check-type (λ ([x : (∪ Int Str)]) x) - : (→ (∪ Int Str) (∪ Num Str))) -(check-type (λ ([x : (∪ Int Str)]) x) - : (→ (∪ Nat Str) (∪ Num Str))) - -(check-type (λ ([x : (∪ Int Str)]) x) - : (→ (∪ Int Str) Top)) - -(check-not-type (λ ([x : (∪ Int Str)]) x) - : (→ Top (∪ Num Str))) - -;; --- ALL -(check-type (λ ([x : (∪ Boolean Int Str)]) x) - : (→ (∪ Boolean Int Str) Top)) -(check-type (λ ([x : (∪ Nat Int Num)]) x) - : (→ (∪ Nat Int Num) Num)) -(check-type (λ ([x : (∪ Nat Int Num)]) x) - : (→ Nat Num)) - -;; --- misc -;; Because Int<:(U Int ...) -(check-type (λ ([x : (∪ Int Nat)]) #t) - : (→ Int Boolean)) - -;; ----------------------------------------------------------------------------- -;; --- Basic Filters (applying functions) - -;; --- is-boolean? -(check-type - (λ ([x : (∪ Boolean Int)]) - (test [Boolean ? x] - #t - #f)) - : (→ (∪ Boolean Int) Boolean)) -(check-type - ((λ ([x : (∪ Boolean Int)]) - (test (Boolean ? x) - #t - #f)) #t) - : Boolean ⇒ #t) -(check-type - ((λ ([x : (∪ Boolean Int)]) - (test (Boolean ? x) - #t - #f)) 902) - : Boolean ⇒ #f) - -;; --- successor -(check-type - (λ ([x : (∪ Int Boolean)]) - (test (Int ? x) - (+ 1 x) - 0)) - : (→ (∪ Int Boolean) (∪ Num Nat))) -(check-type - ((λ ([x : (∪ Int Boolean)]) - (test (Int ? x) - (+ 1 x) - 0)) #f) - : Num ⇒ 0) -(check-type - ((λ ([x : (∪ Int Boolean)]) - (test (Int ? x) - (+ 1 x) - 1)) #t) - : Num ⇒ 1) -(check-type - ((λ ([x : (∪ Int Boolean)]) - (test (Int ? x) - (+ 1 x) - 0)) 9000) - : Num ⇒ 9001) - -;; ;; --- Do-nothing filter -(check-type - (λ ([x : Int]) - (test (Int ? x) #t #f)) - : (→ Int Boolean)) -(check-type - (λ ([x : Int]) - (test (Boolean ? x) 0 x)) - : (→ Int (∪ Nat Int))) - -;; --- Filter a subtype -(check-type - (λ ([x : (∪ Nat Boolean)]) - (test (Int ? x) - x - x)) - : (→ (∪ Nat Boolean) (∪ Int (∪ Nat Boolean)))) - -(check-type - (λ ([x : (∪ Int Boolean)]) - (test (Nat ? x) - x - x)) - : (→ (∪ Boolean Int) (∪ Int Nat Boolean))) - -;; --- Filter a supertype -(check-type - (λ ([x : (∪ Int Boolean)]) - (test (Num ? x) - 1 - x)) - : (→ (∪ Boolean Int) (∪ Nat Boolean))) - -(check-type - ((λ ([x : (∪ Int Boolean)]) - (test (Num ? x) - #f - x)) #t) - : Boolean - ⇒ #t) - -;; Should filter all the impossible types -(check-type - ((λ ([x : (∪ Nat Int Num Boolean)]) - (test (Num ? x) - #f - x)) #t) - : Boolean - ⇒ #t) - -;; Can refine non-union types -(check-type - ((λ ([x : Top]) - (test (Str ? x) - x - "nope")) - "yes") - : Str ⇒ "yes") - -;; ----------------------------------------------------------------------------- -;; --- misc subtyping + filters (regression tests) -(check-type - (λ ([x : (∪ Int Boolean)]) - (test (Int ? x) - 0 - 1)) - : (→ (∪ Int Boolean) Nat)) -(check-type - (λ ([x : (∪ Int Boolean)]) - (test (Int ? x) - 0 - 1)) - : (→ (∪ Int Boolean) Int)) - -;; ----------------------------------------------------------------------------- -;; --- Invalid filters - -(typecheck-fail - (λ ([x : (∪ Int Boolean)]) - (test (1 ? x) #t #f)) - #:with-msg "not a valid type") -(typecheck-fail - (test (1 ? 1) #t #f) - #:with-msg "not a valid type") -(typecheck-fail - (test (1 ? 1) #t #f) - #:with-msg "not a valid type") -(typecheck-fail - (test (#f ? #t) #t #f) - #:with-msg "not a valid type") - -;; ----------------------------------------------------------------------------- -;; --- Subtypes should not be collapsed - -(check-not-type (λ ([x : (∪ Int Nat)]) #t) - : (→ Num Boolean)) -(check-type ((λ ([x : (∪ Int Nat Boolean)]) - (test (Int ? x) - 2 - (test (Nat ? x) - 1 - 0))) - #t) - : Nat ⇒ 0) -(check-type ((λ ([x : (∪ Int Nat)]) - (test (Nat ? x) - 1 - (test (Int ? x) - 2 - 0))) - 1) - : Nat ⇒ 1) -(check-type ((λ ([x : (∪ Int Nat)]) - (test (Int ? x) - 2 - (test (Nat ? x) - 1 - 0))) - -10) - : Nat ⇒ 2) - -;; ----------------------------------------------------------------------------- -;; --- Functions in union - -(check-type (λ ([x : (∪ Int (∪ Nat) (∪ (→ Int Str Int)) (→ (→ (→ Int Int)) Int))]) #t) - : (→ (∪ Int Nat (→ Int Str Int) (→ (→ (→ Int Int)) Int)) Boolean)) - -(check-type (λ ([x : (∪ Int (→ Int Int))]) #t) - : (→ Int Boolean)) - -;; --- filter functions -(check-type - (λ ([x : (∪ Int (→ Int Int))]) - (test ((→ Int Int) ? x) - (x 0) - x)) - : (→ (∪ Int (→ Int Int)) Int)) - -(check-type - (λ ([x : (∪ (→ Int Int Int) (→ Int Int))]) - (test ((→ Int Int) ? x) - (x 0) - (test (Int ? x) - x - (x 1 0)))) - : (→ (∪ (→ Int Int Int) (→ Int Int)) Int)) - -(check-type - ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)]) - (test ((→ Int Int) ? x) - (x 0) - (test (Int ? x) - x - (x 1 0)))) 1) - : Int ⇒ 1) - -(check-type - ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)]) - (test ((→ Int Int) ? x) - (x 0) - (test (Int ? x) - x - (x 1 0)))) (λ ([y : Int]) 5)) - : Int ⇒ 5) - -(check-type - ((λ ([x : (∪ (→ Int Int Int) (→ Int Int) Int)]) - (test ((→ Int Int) ? x) - (x 0) - (test (Int ? x) - x - (x 1 0)))) (λ ([y : Int] [z : Int]) z)) - : Int ⇒ 0) - -;; --- disallow same-arity functions -(typecheck-fail - (λ ([x : (∪ (→ Int Int) (→ Str Str))]) 1) - #:with-msg "Cannot discriminate") - -;; ----------------------------------------------------------------------------- -;; --- Filter with unions - -(check-type - (λ ([x : (∪ Int Str)]) - (test ((∪ Int Str) ? x) - x - "nope")) - : (→ (∪ Int Str) (∪ Int Str))) - -(check-type - (λ ([x : (∪ Int Str Boolean)]) - (test ((∪ Int Str) ? x) - x - "Nope")) - : (→ (∪ Int Str Boolean) (∪ Int Str))) - -(check-type - (λ ([x : (∪ Int Str Boolean)]) - (test ((∪ Int Str) ? x) - (test (Str ? x) - "yes" - "int") - "bool")) - : (→ (∪ Int Str Boolean) Str)) - -(check-type - ((λ ([x : (∪ Str Boolean)]) - (test ((∪ Int Nat Num) ? x) - x - (+ 1 2))) "hi") - : Num ⇒ 3) - -(check-type - ((λ ([x : (∪ Str Int Boolean)]) - (test ((∪ Int Str) ? x) - x - "error")) 1) - : (∪ Str Int) ⇒ 1) - -(check-type - ((λ ([x : (∪ Str Int Boolean)]) - (test ((∪ Int Str) ? x) - x - "error")) "hi") - : (∪ Int Str) ⇒ "hi") - -;; ----------------------------------------------------------------------------- -;; --- Subtyping products - -(check-type (tup 1) : (× Nat)) -(check-type (tup 1) : (× Int)) -(check-type (tup 1) : (× Num)) -(check-type (tup 1) : (× Top)) -(check-type (tup 1) : Top) - -(check-not-type (tup 1) : Boolean) -(check-not-type (tup 1) : Str) -(check-not-type (tup 1) : (× Str)) -(check-not-type (tup 1) : (× Int Str)) -(check-not-type (tup 1) : Bot) - -(check-type (tup 1 2 3) : (× Int Nat Num)) -(check-type (tup 1 2 3) : (× Num Nat Num)) -(check-type (tup 1 2 3) : (× Top Top Num)) -(check-type (tup 1 "2" 3) : (× Int Top Int)) - -(check-not-type (tup 1 2 3) : (× Nat Nat Str)) - -;; ----------------------------------------------------------------------------- -;; --- Latent filters (on products) - -(check-type - (λ ([v : (× (∪ Int Str) Int)]) - (test (Int ? (proj v 0)) - (+ (proj v 0) (proj v 1)) - 0)) - : (→ (× (∪ Int Str) Int) Num)) - -(check-type - ((λ ([v : (× (∪ Int Str) Int)]) - (test (Int ? (proj v 0)) - (+ (proj v 0) (proj v 1)) - 0)) - (tup ((λ ([x : (∪ Int Str)]) x) -2) -3)) - : Num ⇒ -5) - -(check-type - ((λ ([v : (× (∪ Int Str) Int)]) - (test (Int ? (proj v 0)) - (+ (proj v 0) (proj v 1)) - 0)) - (tup "hi" -3)) - : Num ⇒ 0) - -;; --- Use a product as filter - -(check-type - (λ ([x : (∪ Int (× Int Int Int))]) - (test (Int ? x) - (+ 1 x) - (+ (proj x 0) (+ (proj x 1) (proj x 2))))) - : (→ (∪ (× Int Int Int) Int) Num)) - -(check-type - ((λ ([x : (∪ Int (× Int Int Int))]) - (test (Int ? x) - (+ 1 x) - (+ (proj x 0) (+ (proj x 1) (proj x 2))))) - 0) - : Num ⇒ 1) - -(check-type - ((λ ([x : (∪ Int (× Int Int Int))]) - (test (Int ? x) - (+ 1 x) - (+ (proj x 0) (+ (proj x 1) (proj x 2))))) - (tup 2 2 2)) - : Num ⇒ 6) - -(check-type - ((λ ([x : (∪ Int (× Str Nat) (× Int Int Int))]) - (test (Int ? x) - (+ 1 x) - (test ((× Int Int Int) ? x) - (+ (proj x 0) (+ (proj x 1) (proj x 2))) - (proj x 1)))) - (tup 2 2 2)) - : Num ⇒ 6) - -(check-type - ((λ ([x : (∪ Int (× Str Nat) (× Int Int Int))]) - (test (Int ? x) - (+ 1 x) - (test ((× Int Int Int) ? x) - (+ (proj x 0) (+ (proj x 1) (proj x 2))) - (proj x 1)))) - (tup "yolo" 33)) - : Num ⇒ 33) - -;; -- All together now - -(check-type - ((λ ([x : (∪ Int (× Boolean Boolean) (× Int (∪ Str Int)))]) - (test (Int ? x) - "just an int" - (test ((× Boolean Boolean) ? x) - "pair of bools" - (test (Str ? (proj x 1)) - (proj x 1) - "pair of ints")))) - (tup 33 "success")) - : Str ⇒ "success") - -(check-type - ((λ ([x : (∪ Int (× Int Int) (× Int (∪ Str Int)))]) - (test (Int ? x) - "just an int" - (test ((× Int Int) ? x) - "pair of ints" - (test (Str ? (proj x 1)) - (proj x 1) - "another pair of ints")))) - (tup 33 "success")) - : Str ⇒ "success") - -;; ----------------------------------------------------------------------------- -;; --- Filter lists - -(check-type - (λ ([x : (List (∪ Int Str))]) - (test ((List Str) ? x) - x - #f)) - : (→ (List (∪ Int Str)) (∪ Boolean (List Str)))) - -;; -- -subtyping lists -(check-type - (cons 1 (nil {Nat})) - : (List Int)) - -(check-type - ((λ ([filter/3 : (→ (List (∪ Int Str)) (List Int))] - [add*/3 : (→ Num (List Num) (List Num))] - [xs : (× (∪ Int Str) (∪ Int Str) (∪ Int Str))]) - (add*/3 5 (filter/3 (cons (proj xs 0) - (cons (proj xs 1) - (cons (proj xs 2) - (nil {(∪ Str Int)}))))))) - ;; filter (okay this is a little tricky for recursion) - (λ ([xs : (List (∪ Int Str))]) - ((λ ([v1 : (∪ Int Str)] - [v2 : (∪ Int Str)] - [v3 : (∪ Int Str)]) - (test (Int ? v1) - (cons v1 (test (Int ? v2) - (cons v2 (test (Int ? v3) - (cons v3 (nil {Int})) - (nil {Int}))) - (test (Int ? v3) - (cons v3 (nil {Int})) - (nil {Int})))) - (test (Int ? v2) - (cons v2 (test (Int ? v3) - (cons v3 (nil {Int})) - (nil {Int}))) - (test (Int ? v3) - (cons v3 (nil {Int})) - (nil {Int}))))) - (head xs) (head (tail xs)) (head (tail (tail xs))))) - ;; add3 - (λ ([n : Num] [xs : (List Num)]) - (cons (+ n (head xs)) - (cons (+ n (head (tail xs))) - (cons (+ n (head (tail (tail xs)))) - (nil {Num}))))) - ;; xs (3-tuple) - (tup 1 "foo" 3)) - : (List Num)) - -;; ----------------------------------------------------------------------------- -;; --- ICFP'10 examples - -;; -- Exaple 1 (x can have any type) -(check-type - (λ ([x : Top]) - (test (Num ? x) - (+ 1 x) - 0)) - : (→ Top Num)) - -;; -- Example 2 -(check-type - (λ ([x : (∪ Str Num)] - [str-length : (→ Str Num)]) - (test (Num ? x) - (+ 1 x) - (str-length x))) - : (→ (∪ Str Num) (→ Str Num) Num)) - -;; -- TODO Example 3 (requires IF) -;; (check-type -;; (λ ([member : (→ Num (List Num) Boolean)]) -;; (λ ([x : Num] [l : (List Num)]) -;; (if (member x l) -;; <compute with x> -;; <fail>))) -;; : <compute-result> - -;; -- Example 4 -(check-type - (λ ([x : (∪ Num Str Top)] [f : (→ (∪ Num Str) Num)]) - (test ((∪ Num Str) ? x) - (f x) - 0)) - : (→ (∪ Num Str Top) (→ (∪ Num Str) Num) Num)) - -;; Exmample 10 (we don't allow non-homogenous lists, so need to select head before filtering) -(check-type - (λ ([p : (List (∪ Nat Str))]) - ((λ ([x : (∪ Nat Str)]) - (test (Num ? x) - (+ 1 x) - 7)) - (head p))) - : (→ (List (∪ Nat Str)) Num)) - -;; ----------------------------------------------------------------------------- -;; --- TODO CPS filters - -;; ----------------------------------------------------------------------------- -;; --- TODO Filter on values (should do nothing) - -;; (check-type -;; (test (Int ? 1) #t #f) -;; : Boolean) - -;; ----------------------------------------------------------------------------- -;; --- TODO Values as filters (check equality) - diff --git a/tapl/tests/stlc+overloading-tests.rkt b/tapl/tests/stlc+overloading-tests.rkt @@ -1,120 +0,0 @@ -#lang s-exp "../stlc+overloading.rkt" -(require "rackunit-typechecking.rkt") - -;; ----------------------------------------------------------------------------- -;; --- syntax for ψ types - -(typecheck-fail - (signature (to-string0 α) (→ α Str Str)) - #:with-msg "Expected") - -(typecheck-fail - (signature (to-string0 α) (→ Str Str)) - #:with-msg "Expected") - -(typecheck-fail - (signature (to-string0 α) (→ α Str)) - #:with-msg "not allowed in an expression context") - -;; ----------------------------------------------------------------------------- -;; --- basic overloading - -(signature (to-string α) (→ α Str)) - -(typecheck-fail - (to-string 1) - #:with-msg "Resolution for 'to-string' failed") - -(typecheck-fail - (to-string "yolo") - #:with-msg "Resolution for 'to-string' failed") - -;; -- can later add cases to an overloaded name -(instance (to-string Nat) - (λ ([x : Nat]) "nat")) - -(instance (to-string Str) - (λ ([x : Str]) "string")) - -(check-type - (to-string 3) - : Str ⇒ "nat") - -(typecheck-fail - (to-string (+ 0 0)) - #:with-msg "Resolution for 'to-string' failed") - -(instance (to-string Num) - (λ ([x : Num]) "num")) - -(check-type - (to-string (+ 2 2)) - : Str ⇒ "num") - -(check-type - (to-string -1) - : Str ⇒ "num") - -(check-type - (to-string "hi") - : Str ⇒ "string") - -;; -- use 'resolve' to get exact matches - -(check-type - ((resolve to-string Nat) 1) - : Str ⇒ "nat") - -(check-type - ((resolve to-string Num) 1) - : Str ⇒ "num") - -(typecheck-fail - (resolve to-string Int) - #:with-msg "Resolution for 'to-string' failed") - -(typecheck-fail - ((resolve to-string Num) "hello") - #:with-msg (expected "Num" #:given "Str")) - -;; -- instances are type-checked. They must match -(typecheck-fail - (instance (to-string Int) - (λ ([x : Num]) "num")) - #:with-msg "must be the instance type") - -(typecheck-fail - (instance (to-string Int) - (λ ([x : Int]) 0)) - #:with-msg "must match template codomain") - -(typecheck-fail - (instance (to-string Int) - 42) - #:with-msg "May only overload single-argument functions") - -;; -- no overlapping instances -(typecheck-fail - (instance (to-string Nat) - (λ ([x : Nat]) "wrong")) - #:with-msg "Overlaps with existing instance") - -;; -- can't instantiate non-overloadeds -(typecheck-fail - (λ ([x : (→ Int Int)]) - (instance (x Int) - 0)) - #:with-msg "Identifier 'x' is not overloaded") - -;; -- explicit resolve - -;; -- recursive instances are fine [TODO really want (List α)] -(instance (to-string (List Nat)) - (λ ([x : (List Nat)]) "listnat")) - -(check-type - (to-string (cons 1 (cons 2 (nil {Nat})))) - : Str ⇒ "listnat") - -;; -- higher-order use - diff --git a/tapl/tests/stlc+rec-iso-tests.rkt b/tapl/tests/stlc+rec-iso-tests.rkt @@ -1,247 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+rec-iso.rkt" -(require "rackunit-typechecking.rkt") - -(define-type-alias IntList (μ (X) (∨ [nil : Unit] [cons : (× Int X)]))) -(define-type-alias ILBody (∨ [nil : Unit] [cons : (× Int IntList)])) - -;; nil -(define nil (fld {IntList} (var nil = (void) as ILBody))) -(check-type nil : IntList) - -;; cons -(define cons (λ ([n : Int] [lst : IntList]) (fld {IntList} (var cons = (tup n lst) as ILBody)))) -(check-type cons : (→ Int IntList IntList)) -(check-type (cons 1 nil) : IntList) -(typecheck-fail (cons 1 2)) -(typecheck-fail (cons "1" nil)) - -;; isnil -(define isnil - (λ ([lst : IntList]) - (case (unfld {IntList} lst) - [nil n => #t] - [cons p => #f]))) -(check-type isnil : (→ IntList Bool)) -(check-type (isnil nil) : Bool ⇒ #t) -(check-type (isnil (cons 1 nil)) : Bool ⇒ #f) -(typecheck-fail (isnil 1)) -(typecheck-fail (isnil (cons 1 2))) -(check-type (λ ([f : (→ IntList Bool)]) (f nil)) : (→ (→ IntList Bool) Bool)) -(check-type ((λ ([f : (→ IntList Bool)]) (f nil)) isnil) : Bool ⇒ #t) - -;; hd -(define hd - (λ ([lst : IntList]) - (case (unfld {IntList} lst) - [nil n => 0] - [cons p => (proj p 0)]))) -(check-type hd : (→ IntList Int)) -(check-type (hd nil) : Int ⇒ 0) -(typecheck-fail (hd 1)) -(check-type (hd (cons 11 nil)) : Int ⇒ 11) - -;; tl -(define tl - (λ ([lst : IntList]) - (case (unfld {IntList} lst) - [nil n => lst] - [cons p => (proj p 1)]))) -(check-type tl : (→ IntList IntList)) -(check-type (tl nil) : IntList ⇒ nil) -(check-type (tl (cons 1 nil)) : IntList ⇒ nil) -(check-type (tl (cons 1 (cons 2 nil))) : IntList ⇒ (cons 2 nil)) -(typecheck-fail (tl 1)) - -;; some typecheck failure msgs -(typecheck-fail - (fld {Int} 1) - #:with-msg - "Expected μ type, got: Int") -(typecheck-fail - (unfld {Int} 1) - #:with-msg - "Expected μ type, got: Int") - -;; previous stlc+var tests ---------------------------------------------------- -;; define-type-alias -(define-type-alias Integer Int) -(define-type-alias ArithBinOp (→ Int Int Int)) -;(define-type-alias C Complex) ; error, Complex undefined - -(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) -(check-type + : ArithBinOp) -(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) - -;; records (ie labeled tuples) -; no records, only tuples -(check-type "Stephen" : String) -;(check-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : -; (× [: "name" String] [: "phone" Int] [: "male?" Bool])) -;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "name") -; : String ⇒ "Stephen") -;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "name") -; : String ⇒ "Stephen") -;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "phone") -; : Int ⇒ 781) -;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "male?") -; : Bool ⇒ #t) -;(check-not-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : -; (× [: "my-name" String] [: "phone" Int] [: "male?" Bool])) -;(check-not-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : -; (× [: "name" String] [: "my-phone" Int] [: "male?" Bool])) -;(check-not-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : -; (× [: "name" String] [: "phone" Int] [: "is-male?" Bool])) - -;; variants -(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) -(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) - (var coffee = (void) as (∨ [coffee : Unit])))) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1])) ; not enough clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [teaaaaaa x => 2])) ; wrong clause -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [tea x => 2] - [coke x => 3])) ; too many clauses -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => "1"] - [tea x => 2])) ; mismatched branch types -(check-type - (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) - [coffee x => x] - [tea x => 2]) : Int ⇒ 1) -(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) -(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) -(check-type - (case ((λ ([d : Drink]) d) - (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -(check-type - (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -;; previous tests: ------------------------------------------------------------ -;; tests for tuples ----------------------------------------------------------- -(check-type (tup 1 2 3) : (× Int Int Int)) -(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) - -(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) -(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") -(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) -(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large -(typecheck-fail - (proj 1 2) - #:with-msg - "Expected × type, got: Int") - -;; ext-stlc.rkt tests --------------------------------------------------------- -;; should still pass - -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) -(typecheck-fail ((λ ([x : Unit]) x) 2)) -(typecheck-fail ((λ ([x : Unit])) void)) -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(typecheck-fail (begin)) -(check-type (begin 1) : Int) -;(typecheck-fail (begin 1 2 3)) -(check-type (begin (void) 1) : Int ⇒ 1) - -;;ascription -(typecheck-fail (ann 1 : Bool)) -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(typecheck-fail (let ([x #f]) (+ x 1))) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) - -; letrec -(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) -(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/stlc+reco+sub-tests.rkt b/tapl/tests/stlc+reco+sub-tests.rkt @@ -1,113 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+reco+sub.rkt" -(require "rackunit-typechecking.rkt") - -;; record subtyping tests -(check-type "coffee" : String) -(check-type (tup [coffee = 3]) : (× [coffee : Int])) ; element subtyping -(check-type (var coffee = 3 as (∨ [coffee : Nat])) : (∨ [coffee : Int])) ; element subtyping -;err -(typecheck-fail - (var cooffee = 3 as (∨ [coffee : Nat])) - #:with-msg "cooffee field does not exist") -(check-type (tup [coffee = 3]) : (× [coffee : Nat])) -(check-type (tup [coffee = 3]) : (× [coffee : Top])) -(check-type (var coffee = 3 as (∨ [coffee : Int])) : (∨ [coffee : Top])) ; element subtyping (twice) -(check-type (tup [coffee = 3]) : (× [coffee : Num])) -(check-not-type (tup [coffee = -3]) : (× [coffee : Nat])) -(check-type (tup [coffee = -3]) : (× [coffee : Num])) -(check-type (tup [coffee = -3] [tea = 3]) : (× [coffee : Int])) ; width subtyping -(check-type (tup [coffee = -3] [tea = 3]) : (× [coffee : Num])) ; width+element subtyping - -;; record + fns -(check-type (tup [plus = +]) : (× [plus : (→ Num Num Num)])) -(check-type + : (→ Num Num Num)) -(check-type (tup [plus = +]) : (× [plus : (→ Int Num Num)])) -(check-type (tup [plus = +]) : (× [plus : (→ Int Num Top)])) -(check-type (tup [plus = +] [mul = *]) : (× [plus : (→ Int Num Top)])) - -;; examples from tapl ch26, bounded quantification -(check-type (λ ([x : (× [a : Int])]) x) : (→ (× [a : Int]) (× [a : Int]))) - -(check-type ((λ ([x : (× [a : Int])]) x) (tup [a = 0])) - : (× [a : Int]) ⇒ (tup [a = 0])) -(check-type ((λ ([x : (× [a : Int])]) x) (tup [a = 0][b = #t])) - : (× [a : Int]) ⇒ (tup [a = 0][b = #t])) - -(check-type (proj ((λ ([x : (× [a : Int])]) x) (tup [a = 0][b = #t])) a) - : Int ⇒ 0) - -;; this should work! but needs bounded quantification, see fsub.rkt -(typecheck-fail (proj ((λ ([x : (× [a : Int])]) x) (tup [a = 0][b = #t])) b)) - -; conditional -(check-not-type (λ ([x : Int]) (if #t 1 -1)) : (→ Int Nat)) -(check-type (λ ([x : Int]) (if #t 1 -1)) : (→ Int Int)) -(check-not-type (λ ([x : Int]) (if #t -1 1)) : (→ Int Nat)) -(check-type (λ ([x : Int]) (if #t -1 1)) : (→ Int Int)) -(check-type (λ ([x : Bool]) (if x "1" 1)) : (→ Bool Top)) - -;; previous record tests ------------------------------------------------------ -;; records (ie labeled tuples) -(check-type "Stephen" : String) -(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [male? : Bool])) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) - : Int ⇒ 781) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) - : Bool ⇒ #t) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [my-name : String] [phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [my-phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [is-male? : Bool])) - - -;; previous basic subtyping tests ------------------------------------------------------ -(check-type 1 : Top) -(check-type 1 : Num) -(check-type 1 : Int) -(check-type 1 : Nat) -(check-type -1 : Top) -(check-type -1 : Num) -(check-type -1 : Int) -(check-not-type -1 : Nat) -(check-type ((λ ([x : Top]) x) 1) : Top ⇒ 1) -(check-type ((λ ([x : Top]) x) -1) : Top ⇒ -1) -(check-type ((λ ([x : Num]) x) -1) : Num ⇒ -1) -(check-type ((λ ([x : Int]) x) -1) : Int ⇒ -1) -(typecheck-fail ((λ ([x : Nat]) x) -1)) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([x : Int]) x) : (→ Int Num)) ; covariant output -(check-not-type (λ ([x : Int]) x) : (→ Int Nat)) -(check-type (λ ([x : Int]) x) : (→ Nat Int)) ; contravariant input -(check-not-type (λ ([x : Int]) x) : (→ Num Int)) - -;; previous tests ------------------------------------------------------------- -;; some change due to more specific types -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -;(typecheck-fail "one") ; unsupported literal -;(typecheck-fail #f) ; unsupported literal -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -; Bool now defined -;(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -;(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -;; changed test -(check-type ((λ ([f : (→ Num Num Num)] [x : Int] [y : Int]) (f x y)) + 1 2) : Num ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Num ⇒ 20) diff --git a/tapl/tests/stlc+reco+var-tests.rkt b/tapl/tests/stlc+reco+var-tests.rkt @@ -1,232 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+reco+var.rkt" -(require "rackunit-typechecking.rkt") - -;; define-type-alias -(define-type-alias Integer Int) -(define-type-alias ArithBinOp (→ Int Int Int)) -;(define-type-alias C Complex) ; error, Complex undefined - -(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) -(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) -(check-type + : ArithBinOp) -(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) - -; records (ie labeled tuples) -(check-type "Stephen" : String) -(check-type (tup) : (×)) -(check-type (tup [name = "Stephen"]) : (× [name : String])) -(check-type (proj (tup [name = "Stephen"]) name) : String ⇒ "Stephen") -(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [male? : Bool])) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) - : String ⇒ "Stephen") -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) - : Int ⇒ 781) -(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) - : Bool ⇒ #t) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [my-name : String] [phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [my-phone : Int] [male? : Bool])) -(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : - (× [name : String] [phone : Int] [is-male? : Bool])) - -;; record errors -(typecheck-fail - (proj 1 "a") - #:with-msg - "expected identifier") -(typecheck-fail - (proj 1 a) - #:with-msg - "Expected expression 1 to have × type, got: Int") - -;; variants -(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) -(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) -(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) - (var coffee = (void) as (∨ [coffee : Unit]))) - #:with-msg - "expected \\(∨ \\(coffee : Unit\\) \\(tea : Unit\\)\\), given \\(∨ \\(coffee : Unit\\)\\)") -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) : - (∨ [coffee : Unit] [tea : Unit])) -(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) - -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1]) - #:with-msg "wrong number of case clauses") -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [teaaaaaa x => 2]) - #:with-msg "case clauses not exhaustive") -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => 1] - [tea x => 2] - [coke x => 3]) - #:with-msg "wrong number of case clauses") -(typecheck-fail - (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) - [coffee x => "1"] - [tea x => 2]) - #:with-msg "branches have incompatible types: String and Int") -(check-type - (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) - [coffee x => x] - [tea x => 2]) : Int ⇒ 1) -(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) -(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) -(check-type - (case ((λ ([d : Drink]) d) - (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -(check-type - (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) - [coffee x => (+ (+ x x) (+ x x))] - [tea x => 2] - [coke y => 3]) - : Int ⇒ 4) - -;; variant errors -(typecheck-fail - (var name = "Steve" as Int) - #:with-msg - "Expected the expected type to be a ∨ type, got: Int") -(typecheck-fail - (case 1 [racket x => 1]) - #:with-msg - "Expected ∨ type, got: Int") -(typecheck-fail - (λ ([x : (∨)]) x) - #:with-msg "Improper usage of type constructor ∨: \\(∨\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") -(typecheck-fail - (λ ([x : (∨ 1)]) x) - #:with-msg "Improper usage of type constructor ∨: \\(∨ 1\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") -(typecheck-fail - (λ ([x : (∨ [1 2])]) x) - #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(1 2\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") -(typecheck-fail - (λ ([x : (∨ [a 2])]) x) - #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a 2\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") -(typecheck-fail - (λ ([x : (∨ [a Int])]) x) - #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a Int\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") -(typecheck-fail - (λ ([x : (∨ [1 : Int])]) x) - #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(1 : Int\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") -(typecheck-fail - (λ ([x : (∨ [a : 1])]) x) - #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a : 1\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") - -;; previous tuple tests: ------------------------------------------------------------ -;; wont work anymore -;;(check-type (tup 1 2 3) : (× Int Int Int)) -;;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) -;;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) -;;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) -;;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) -;;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) -;; -;;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) -;;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") -;;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) -;;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large -;;(typecheck-fail (proj 1 2)) ; not tuple - -;; ext-stlc.rkt tests --------------------------------------------------------- -;; should still pass - -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) -(typecheck-fail ((λ ([x : Unit]) x) 2)) -(typecheck-fail ((λ ([x : Unit])) void)) -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(typecheck-fail (begin)) -(check-type (begin 1) : Int) -;(typecheck-fail (begin 1 2 3)) -(check-type (begin (void) 1) : Int ⇒ 1) - -;;ascription -(typecheck-fail (ann 1 : Bool)) -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) - -;; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(typecheck-fail (let ([x #f]) (+ x 1))) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) - -;; letrec -(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) -(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; tests from stlc+lit-tests.rkt -------------------------- -;; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -;(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/stlc+sub-tests.rkt b/tapl/tests/stlc+sub-tests.rkt @@ -1,63 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+sub.rkt" -(require "rackunit-typechecking.rkt") - -;; subtyping tests -(check-type 1 : Top) -(check-type 1 : Num) -(check-type 1 : Int) -(check-type 1 : Nat) -(check-type -1 : Top) -(check-type -1 : Num) -(check-type -1 : Int) -(check-not-type -1 : Nat) -(check-type ((λ ([x : Top]) x) 1) : Top ⇒ 1) -(check-type ((λ ([x : Top]) x) -1) : Top ⇒ -1) -(check-type ((λ ([x : Num]) x) -1) : Num ⇒ -1) -(check-type ((λ ([x : Int]) x) -1) : Int ⇒ -1) -(typecheck-fail ((λ ([x : Nat]) x) -1)) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([x : Int]) x) : (→ Int Num)) ; covariant output -(check-not-type (λ ([x : Int]) x) : (→ Int Nat)) -(check-type (λ ([x : Int]) x) : (→ Nat Int)) ; contravariant input -(check-not-type (λ ([x : Int]) x) : (→ Num Int)) - -(check-type ((λ ([f : (→ Int Int)]) (f -1)) add1) : Int ⇒ 0) -(check-type ((λ ([f : (→ Nat Int)]) (f 1)) add1) : Int ⇒ 2) -(typecheck-fail ((λ ([f : (→ Num Int)]) (f 1.1)) add1)) -(check-type ((λ ([f : (→ Nat Num)]) (f 1)) add1) : Num ⇒ 2) -(typecheck-fail ((λ ([f : (→ Num Num)]) (f 1.1)) add1)) - -(check-type + : (→ Num Num Num)) -(check-type + : (→ Int Num Num)) -(check-type + : (→ Int Int Num)) -(check-not-type + : (→ Top Int Num)) -(check-not-type + : (→ Top Int Int)) -(check-type + : (→ Nat Int Top)) - -;; previous tests ------------------------------------------------------------- -;; some change due to more specific types -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -(check-type "one" : String) -(check-type #f : Bool) -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Sym]) x) 1)) ; Sym is not valid type -(typecheck-fail (λ ([x : Sym]) x)) ; Sym is not valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -;(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -;; changed test -(check-type ((λ ([f : (→ Num Num Num)] [x : Int] [y : Int]) (f x y)) + 1 2) : Num ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Num ⇒ 20) - -(check-not-type (λ ([x : Int]) x) : Int) -(check-not-type (λ ([x : Int] [y : Int]) x) : (→ Int Int)) -(check-not-type (λ ([x : Int]) x) : (→ Int Int Int Int)) diff --git a/tapl/tests/stlc+tup-tests.rkt b/tapl/tests/stlc+tup-tests.rkt @@ -1,107 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc+tup.rkt" -(require "rackunit-typechecking.rkt") - -;; tests for tuples -(check-type (tup 1 2 3) : (× Int Int Int)) -(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) -(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) - -(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) -(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") -(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) -(typecheck-fail (proj (tup 1 "2" #f) -1) #:with-msg "expected exact-nonnegative-integer") -(typecheck-fail (proj (tup 1 "2" #f) 3) #:with-msg "index too large") -(typecheck-fail - (proj 1 2) - #:with-msg - "proj: Expected × type, got: Int") - -;; ext-stlc.rkt tests --------------------------------------------------------- -;; should still pass - -;; new literals and base types -(check-type "one" : String) ; literal now supported -(check-type #f : Bool) ; literal now supported - -(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type - -;; Unit -(check-type (void) : Unit) -(check-type void : (→ Unit)) -(typecheck-fail ((λ ([x : Unit]) x) 2)) -(typecheck-fail ((λ ([x : Unit])) void)) -(check-type ((λ ([x : Unit]) x) (void)) : Unit) - -;; begin -(typecheck-fail (begin)) -(check-type (begin 1) : Int) -;(typecheck-fail (begin 1 2 3)) -(check-type (begin (void) 1) : Int ⇒ 1) - -;;ascription -(typecheck-fail (ann 1 : Bool)) -(check-type (ann 1 : Int) : Int ⇒ 1) -(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) - -; let -(check-type (let () (+ 1 1)) : Int ⇒ 2) -(check-type (let ([x 10]) (+ 1 2)) : Int) -(typecheck-fail (let ([x #f]) (+ x 1))) -(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) -(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier - -(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) -(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) - -; letrec -(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) -(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) - -(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) - -;; recursive -(check-type - (letrec ([(countdown : (→ Int String)) - (λ ([i : Int]) - (if (= i 0) - "liftoff" - (countdown (- i 1))))]) - (countdown 10)) : String ⇒ "liftoff") - -;; mutually recursive -(check-type - (letrec ([(is-even? : (→ Int Bool)) - (λ ([n : Int]) - (or (zero? n) - (is-odd? (sub1 n))))] - [(is-odd? : (→ Int Bool)) - (λ ([n : Int]) - (and (not (zero? n)) - (is-even? (sub1 n))))]) - (is-odd? 11)) : Bool ⇒ #t) - -;; tests from stlc+lit-tests.rkt -------------------------- -; most should pass, some failing may now pass due to added types/forms -(check-type 1 : Int) -;(check-not-type 1 : (Int → Int)) -;(typecheck-fail "one") ; literal now supported -;(typecheck-fail #f) ; literal now supported -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type -;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) - diff --git a/tapl/tests/stlc-tests.rkt b/tapl/tests/stlc-tests.rkt @@ -1,12 +0,0 @@ -#lang s-exp "../typed-lang-builder/stlc.rkt" -(require "rackunit-typechecking.rkt") - -;; cannot write any terms without base types, but can check some errors - -(typecheck-fail (λ ([x : Undef]) x) #:with-msg "Undef: unbound identifier") -(typecheck-fail (λ ([x : →]) x) - #:with-msg "Improper usage of type constructor →.+expected >= 1 arguments") -(typecheck-fail (λ ([x : (→)]) x) - #:with-msg "Improper usage of type constructor →.+expected >= 1 arguments") -(typecheck-fail (λ ([x : (→ →)]) x) - #:with-msg "Improper usage of type constructor →.+expected >= 1 arguments") -\ No newline at end of file diff --git a/tapl/tests/sysf-tests.rkt b/tapl/tests/sysf-tests.rkt @@ -1,76 +0,0 @@ -#lang s-exp "../typed-lang-builder/sysf.rkt" -(require "rackunit-typechecking.rkt") - -(check-type (Λ (X) (λ ([x : X]) x)) : (∀ (X) (→ X X))) - -(check-type (Λ (X) (λ ([t : X] [f : X]) t)) : (∀ (X) (→ X X X))) ; true -(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (X) (→ X X X))) ; false -(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (Y) (→ Y Y Y))) ; false, alpha equiv - -(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ (t1) (∀ (t2) (→ t1 (→ t2 t2))))) - -(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ (t3) (∀ (t4) (→ t3 (→ t4 t4))))) - -(check-not-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) - : (∀ (t4) (∀ (t3) (→ t3 (→ t4 t4))))) - -(check-type (inst (Λ (t) (λ ([x : t]) x)) Int) : (→ Int Int)) -(check-type (inst (Λ (t) 1) (→ Int Int)) : Int) -; first inst should be discarded -(check-type (inst (inst (Λ (t) (Λ (t) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) -; second inst is discarded -(check-type (inst (inst (Λ (t1) (Λ (t2) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) - -;; inst err -(typecheck-fail - (inst 1 Int) - #:with-msg - "Expected ∀ type, got: Int") - -;; polymorphic arguments -(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (t) (→ t t))) -(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (s) (→ s s))) -(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (s) (∀ (t) (→ t t)))) -(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (t) (→ t t)))) -(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (s) (→ s s)))) -(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (u) (→ u u)))) -(check-type (λ ([x : (∀ (t) (→ t t))]) x) : (→ (∀ (s) (→ s s)) (∀ (u) (→ u u)))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) -(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) -(check-type ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) : (∀ (u) (→ u u))) -(check-type - (inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) : (→ Int Int)) -(check-type - ((inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) 10) - : Int ⇒ 10) -(check-type (λ ([x : (∀ (t) (→ t t))]) (inst x Int)) : (→ (∀ (t) (→ t t)) (→ Int Int))) -(check-type (λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) : (→ (∀ (t) (→ t t)) Int)) -(check-type ((λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) - (Λ (s) (λ ([y : s]) y))) - : Int ⇒ 10) - -; ∀ errs -(typecheck-fail (λ ([x : (∀ (y) (+ 1 y))]) x)) - -;; previous tests ------------------------------------------------------------- -(check-type 1 : Int) -(check-not-type 1 : (→ Int Int)) -(typecheck-fail "one") ; unsupported literal -(typecheck-fail #f) ; unsupported literal -(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) -(check-not-type (λ ([x : Int]) x) : Int) -(check-type (λ ([x : Int]) x) : (→ Int Int)) -(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) -(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) -(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type -(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type -(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type -(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) - : (→ (→ Int Int Int) Int Int Int)) -(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) -(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int -(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int -(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args -(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/tapl/typed-lang-builder/exist.rkt b/tapl/typed-lang-builder/exist.rkt @@ -1,75 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+reco+var.rkt") -(reuse #:from "stlc+rec-iso.rkt") ; want type=?, but only need to load current-type=? - -;; existential types -;; Types: -;; - types from stlc+reco+var.rkt -;; - ∃ -;; Terms: -;; - terms from stlc+reco+var.rkt -;; - pack and open -;; Other: type=? from stlc+rec-iso.rkt - - -(define-type-constructor ∃ #:bvs = 1) - -(define-typed-syntax pack - [(pack (τ:type e) as ∃τ:type) ≫ - [#:with (~∃* (τ_abstract) τ_body) #'∃τ.norm] - [#:with τ_e (subst #'τ.norm #'τ_abstract #'τ_body)] - [⊢ [[e ≫ e-] ⇐ : τ_e]] - -------- - [⊢ [[_ ≫ e-] ⇒ : ∃τ.norm]]]) - -(define-typed-syntax open #:datum-literals (<= with) - [(open [x:id <= e_packed with X:id] e) - ≫ - ;; The subst below appears to be a hack, but it's not really. - ;; It's the (TaPL) type rule itself that is fast and loose. - ;; Leveraging the macro system's management of binding reveals this. - ;; - ;; Specifically, here is the TaPL Unpack type rule, fig24-1, p366: - ;; Γ ⊢ e_packed : {∃X,τ_body} - ;; Γ,X,x:τ_body ⊢ e : τ_e - ;; ------------------------------ - ;; Γ ⊢ (open [x <= e_packed with X] e) : τ_e - ;; - ;; There's *two* separate binders, the ∃ and the let, - ;; which the rule conflates. - ;; - ;; Here's the rule rewritten to distinguish the two binding positions: - ;; Γ ⊢ e_packed : {∃X_1,τ_body} - ;; Γ,X_???,x:τ_body ⊢ e : τ_e - ;; ------------------------------ - ;; Γ ⊢ (open [x <= e_packed with X_2] e) : τ_e - ;; - ;; The X_1 binds references to X in T_12. - ;; The X_2 binds references to X in t_2. - ;; What should the X_??? be? - ;; - ;; A first guess might be to replace X_??? with both X_1 and X_2, - ;; so all the potentially referenced type vars are bound. - ;; Γ ⊢ e_packed : {∃X_1,τ_body} - ;; Γ,X_1,X_2,x:τ_body ⊢ e : τ_e - ;; ------------------------------ - ;; Γ ⊢ (open [x <= e_packed with X_2] e) : τ_e - ;; - ;; But this example demonstrates that the rule above doesnt work: - ;; (open [x <= (pack (Int 0) as (∃ (X_1) X_1)) with X_2] - ;; ((λ ([y : X_2]) y) x) - ;; Here, x has type X_1, y has type X_2, but they should be the same thing, - ;; so we need to replace all X_1's with X_2 - ;; - ;; Here's the fixed rule, which is implemented here - ;; - ;; Γ ⊢ e_packed : {∃X_1,τ_body} - ;; Γ,X_2:#%type,x:[X_2/X_1]τ_body ⊢ e : τ_e - ;; ------------------------------ - ;; Γ ⊢ (open [x <= e_packed with X_2] e) : τ_e - ;; - [⊢ [[e_packed ≫ e_packed-] ⇒ : (~∃ (Y) τ_body)]] - [#:with τ_x (subst #'X #'Y #'τ_body)] - [([X : #%type ≫ X-]) ([x : τ_x ≫ x-]) ⊢ [[e ≫ e-] ⇒ : τ_e]] - -------- - [⊢ [[_ ≫ (let- ([x- e_packed-]) e-)] ⇒ : τ_e]]]) diff --git a/tapl/typed-lang-builder/ext-stlc.rkt b/tapl/typed-lang-builder/ext-stlc.rkt @@ -1,145 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+lit.rkt" #:except #%datum) -(provide ⊔ (for-syntax current-join)) - -;; Simply-Typed Lambda Calculus, plus extensions (TAPL ch11) -;; Types: -;; - types from stlc+lit.rkt -;; - Bool, String -;; - Unit -;; Terms: -;; - terms from stlc+lit.rkt -;; - literals: bool, string -;; - boolean prims, numeric prims -;; - if -;; - prim void : (→ Unit) -;; - begin -;; - ascription (ann) -;; - let, let*, letrec - -(define-base-type Bool) -(define-base-type String) -(define-base-type Float) -(define-base-type Char) - -(define-typed-syntax #%datum - [(#%datum . b:boolean) ≫ - -------- - [⊢ [[_ ≫ (#%datum- . b)] ⇒ : Bool]]] - [(#%datum . s:str) ≫ - -------- - [⊢ [[_ ≫ (#%datum- . s)] ⇒ : String]]] - [(#%datum . f) ≫ - [#:when (flonum? (syntax-e #'f))] - -------- - [⊢ [[_ ≫ (#%datum- . f)] ⇒ : Float]]] - [(#%datum . c:char) ≫ - -------- - [⊢ [[_ ≫ (#%datum- . c)] ⇒ : Char]]] - [(#%datum . x) ≫ - -------- - [_ ≻ (stlc+lit:#%datum . x)]]) - -(define-primop zero? : (→ Int Bool)) -(define-primop = : (→ Int Int Bool)) -(define-primop - : (→ Int Int Int)) -(define-primop add1 : (→ Int Int)) -(define-primop sub1 : (→ Int Int)) -(define-primop not : (→ Bool Bool)) - -(define-typed-syntax and - [(and e1 e2) ≫ - [⊢ [[e1 ≫ e1-] ⇐ : Bool]] - [⊢ [[e2 ≫ e2-] ⇐ : Bool]] - -------- - [⊢ [[_ ≫ (and- e1- e2-)] ⇒ : Bool]]]) - -(define-typed-syntax or - [(or e ...) ≫ - [⊢ [[e ≫ e-] ⇐ : Bool] ...] - -------- - [⊢ [[_ ≫ (or- e- ...)] ⇒ : Bool]]]) - -(begin-for-syntax - (define current-join - (make-parameter - (λ (x y) - (unless (typecheck? x y) - (type-error - #:src x - #:msg "branches have incompatible types: ~a and ~a" x y)) - x)))) - -(define-syntax ⊔ - (syntax-parser - [(⊔ τ1 τ2 ...) - (for/fold ([τ ((current-type-eval) #'τ1)]) - ([τ2 (in-list (stx-map (current-type-eval) #'[τ2 ...]))]) - ((current-join) τ τ2))])) - -(define-typed-syntax if - [(if e_tst e1 e2) ⇐ : τ-expected ≫ - [⊢ [[e_tst ≫ e_tst-] ⇒ : _]] ; Any non-false value is truthy. - [⊢ [[e1 ≫ e1-] ⇐ : τ-expected]] - [⊢ [[e2 ≫ e2-] ⇐ : τ-expected]] - -------- - [⊢ [[_ ≫ (if- e_tst- e1- e2-)] ⇐ : _]]] - [(if e_tst e1 e2) ≫ - [⊢ [[e_tst ≫ e_tst-] ⇒ : _]] ; Any non-false value is truthy. - [⊢ [[e1 ≫ e1-] ⇒ : τ1]] - [⊢ [[e2 ≫ e2-] ⇒ : τ2]] - -------- - [⊢ [[_ ≫ (if- e_tst- e1- e2-)] ⇒ : (⊔ τ1 τ2)]]]) - -(define-base-type Unit) -(define-primop void : (→ Unit)) - -(define-typed-syntax begin - [(begin e_unit ... e) ⇐ : τ_expected ≫ - [⊢ [[e_unit ≫ e_unit-] ⇒ : _] ...] - [⊢ [[e ≫ e-] ⇐ : τ_expected]] - -------- - [⊢ [[_ ≫ (begin- e_unit- ... e-)] ⇐ : _]]] - [(begin e_unit ... e) ≫ - [⊢ [[e_unit ≫ e_unit-] ⇒ : _] ...] - [⊢ [[e ≫ e-] ⇒ : τ_e]] - -------- - [⊢ [[_ ≫ (begin- e_unit- ... e-)] ⇒ : τ_e]]]) - -(define-typed-syntax let - [(let ([x e] ...) e_body) ⇐ : τ_expected ≫ - [⊢ [[e ≫ e-] ⇒ : τ_x] ...] - [() ([x : τ_x ≫ x-] ...) ⊢ [[e_body ≫ e_body-] ⇐ : τ_expected]] - -------- - [⊢ [[_ ≫ (let- ([x- e-] ...) e_body-)] ⇐ : _]]] - [(let ([x e] ...) e_body) ≫ - [⊢ [[e ≫ e-] ⇒ : τ_x] ...] - [() ([x : τ_x ≫ x-] ...) ⊢ [[e_body ≫ e_body-] ⇒ : τ_body]] - -------- - [⊢ [[_ ≫ (let- ([x- e-] ...) e_body-)] ⇒ : τ_body]]]) - -; dont need to manually transfer expected type -; result template automatically propagates properties -; - only need to transfer expected type when local expanding an expression -; - see let/tc -(define-typed-syntax let* - [(let* () e_body) ≫ - -------- - [_ ≻ e_body]] - [(let* ([x e] [x_rst e_rst] ...) e_body) ≫ - -------- - [_ ≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body))]]) - -(define-typed-syntax letrec - [(letrec ([b:type-bind e] ...) e_body) ⇐ : τ_expected ≫ - [() ([b.x : b.type ≫ x-] ...) - ⊢ [[e ≫ e-] ⇐ : b.type] ... [[e_body ≫ e_body-] ⇐ : τ_expected]] - -------- - [⊢ [[_ ≫ (letrec- ([x- e-] ...) e_body-)] ⇐ : _]]] - [(letrec ([b:type-bind e] ...) e_body) ≫ - [() ([b.x : b.type ≫ x-] ...) - ⊢ [[e ≫ e-] ⇐ : b.type] ... [[e_body ≫ e_body-] ⇒ : τ_body]] - -------- - [⊢ [[_ ≫ (letrec- ([x- e-] ...) e_body-)] ⇒ : τ_body]]]) - - diff --git a/tapl/typed-lang-builder/fomega.rkt b/tapl/typed-lang-builder/fomega.rkt @@ -1,116 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "sysf.rkt" #:except #%datum ∀ Λ inst) -(reuse String #%datum #:from "stlc+reco+var.rkt") - -;; System F_omega -;; Type relation: -;; Types: -;; - types from sysf.rkt -;; - String from stlc+reco+var -;; Terms: -;; - extend ∀ Λ inst from sysf -;; - add tyλ and tyapp -;; - #%datum from stlc+reco+var - -(define-syntax-category kind) - -; want #%type to be equiv to★ -; => edit current-kind? so existing #%type annotations (with no #%kind tag) -; are treated as kinds -; <= define ★ as rename-transformer expanding to #%type -(begin-for-syntax - (current-kind? (λ (k) (or (#%type? k) (kind? k)))) - ;; Try to keep "type?" backward compatible with its uses so far, - ;; eg in the definition of λ or previous type constuctors. - ;; (However, this is not completely possible, eg define-type-alias) - ;; So now "type?" no longer validates types, rather it's a subset. - ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) - (current-type? (λ (t) - (define k (typeof t)) - #;(or (type? t) (★? (typeof t)) (∀★? (typeof t))) - (and ((current-kind?) k) (not (⇒? k)))))) - -; must override, to handle kinds -(provide define-type-alias) -(define-syntax define-type-alias - (syntax-parser - [(define-type-alias alias:id τ) - #:with (τ- k_τ) (infer+erase #'τ) - #:fail-unless ((current-kind?) #'k_τ) (format "not a valid type: ~a\n" (type->str #'τ)) - #'(define-syntax alias (syntax-parser [x:id #'τ-] [(_ . rst) #'(τ- . rst)]))])) - -(provide ★ (for-syntax ★?)) -(define-for-syntax ★? #%type?) -(define-syntax ★ (make-rename-transformer #'#%type)) -(define-kind-constructor ⇒ #:arity >= 1) -(define-kind-constructor ∀★ #:arity >= 0) - -(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) - -;; alternative: normalize before type=? -; but then also need to normalize in current-promote -(begin-for-syntax - (define (normalize τ) - (syntax-parse τ #:literals (#%plain-app #%plain-lambda) - [x:id #'x] - [(#%plain-app - (#%plain-lambda (tv ...) τ_body) τ_arg ...) - (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] - [(#%plain-lambda (x ...) . bodys) - #:with bodys_norm (stx-map normalize #'bodys) - (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] - [(#%plain-app x:id . args) - #:with args_norm (stx-map normalize #'args) - (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] - [(#%plain-app . args) - #:with args_norm (stx-map normalize #'args) - #:with res (normalize #'(#%plain-app . args_norm)) - (transfer-stx-props #'res τ #:ctx τ)] - [_ τ])) - - (define old-eval (current-type-eval)) - (define (type-eval τ) (normalize (old-eval τ))) - (current-type-eval type-eval) - - (define old-type=? (current-type=?)) - ; ty=? == syntax eq and syntax prop eq - (define (type=? t1 t2) - (let ([k1 (typeof t1)][k2 (typeof t2)]) - (and (or (and (not k1) (not k2)) - (and k1 k2 ((current-type=?) k1 k2))) - (old-type=? t1 t2)))) - (current-type=? type=?) - (current-typecheck-relation (current-type=?))) - -(define-typed-syntax Λ - [(Λ bvs:kind-ctx e) ≫ - [([bvs.x : bvs.kind ≫ tv-] ...) () ⊢ [[e ≫ e-] ⇒ : τ_e]] - -------- - [⊢ [[_ ≫ e-] ⇒ : (∀ ([tv- : bvs.kind] ...) τ_e)]]]) - -(define-typed-syntax inst - [(inst e τ ...) ≫ - [⊢ [[e ≫ e-] ⇒ : (~∀ (tv ...) τ_body) (⇒ : (~∀★ k ...))]] - [⊢ [[τ ≫ τ-] ⇐ : k] ...] - [#:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)] - -------- - [⊢ [[_ ≫ e-] ⇒ : τ-inst]]]) - -;; TODO: merge with regular λ and app? -;; - see fomega2.rkt -(define-typed-syntax tyλ - [(tyλ bvs:kind-ctx τ_body) ≫ - [() ([bvs.x : bvs.kind ≫ tv-] ...) ⊢ [[τ_body ≫ τ_body-] ⇒ : k_body]] - [#:fail-unless ((current-kind?) #'k_body) - (format "not a valid type: ~a\n" (type->str #'τ_body))] - -------- - [⊢ [[_ ≫ (λ- (tv- ...) τ_body-)] ⇒ : (⇒ bvs.kind ... k_body)]]]) - -(define-typed-syntax tyapp - [(tyapp τ_fn τ_arg ...) ≫ - [⊢ [[τ_fn ≫ τ_fn-] ⇒ : (~⇒ k_in ... k_out)]] - [#:fail-unless (stx-length=? #'[k_in ...] #'[τ_arg ...]) - (num-args-fail-msg #'τ_fn #'[k_in ...] #'[τ_arg ...])] - [⊢ [[τ_arg ≫ τ_arg-] ⇐ : k_in] ...] - -------- - [⊢ [[_ ≫ (#%app- τ_fn- τ_arg- ...)] ⇒ : k_out]]]) diff --git a/tapl/typed-lang-builder/fomega2.rkt b/tapl/typed-lang-builder/fomega2.rkt @@ -1,94 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "sysf.rkt" #:except #%datum ∀ Λ inst);#:rename [~∀ ~sysf:∀]) -(reuse String #%datum #:from "stlc+reco+var.rkt") - -; same as fomega.rkt except here λ and #%app works as both type and terms -; - uses definition from stlc, but tweaks type? and kind? predicates -;; → is also both type and kind - -;; System F_omega -;; Type relation: -;; Types: -;; - types from sysf.rkt -;; - String from stlc+reco+var -;; Terms: -;; - extend ∀ Λ inst from sysf -;; - #%datum from stlc+reco+var - -(define-syntax-category kind) - -(begin-for-syntax - (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) - ;; Try to keep "type?" backward compatible with its uses so far, - ;; eg in the definition of λ or previous type constuctors. - ;; (However, this is not completely possible, eg define-type-alias) - ;; So now "type?" no longer validates types, rather it's a subset. - ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) - (current-type? (λ (t) (or (type? t) - (let ([k (typeof t)]) - (or (★? k) (∀★? k))) - ((current-kind?) t))))) - -; must override -(provide define-type-alias) -(define-syntax define-type-alias - (syntax-parser - [(_ alias:id τ) - #:with (τ- k_τ) (infer+erase #'τ) - #'(define-syntax alias (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))])) - -(define-base-kind ★) -(define-kind-constructor ∀★ #:arity >= 0) -(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) - -;; alternative: normalize before type=? -; but then also need to normalize in current-promote -(begin-for-syntax - (define (normalize τ) - (syntax-parse τ #:literals (#%plain-app #%plain-lambda) - [x:id #'x] - [(#%plain-app - (#%plain-lambda (tv ...) τ_body) τ_arg ...) - (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] - [(#%plain-lambda (x ...) . bodys) - #:with bodys_norm (stx-map normalize #'bodys) - (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] - [(#%plain-app x:id . args) - #:with args_norm (stx-map normalize #'args) - (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] - [(#%plain-app . args) - #:with args_norm (stx-map normalize #'args) - (transfer-stx-props (normalize #'(#%plain-app . args_norm)) τ #:ctx τ)] - [_ τ])) - - (define old-eval (current-type-eval)) - (define (type-eval τ) (normalize (old-eval τ))) - (current-type-eval type-eval) - - (define old-type=? (current-type=?)) - (define (type=? t1 t2) - (or (and (★? t1) (#%type? t2)) - (and (#%type? t1) (★? t2)) - (and (syntax-parse (list t1 t2) #:datum-literals (:) - [((~∀ ([tv1 : k1]) tbody1) - (~∀ ([tv2 : k2]) tbody2)) - ((current-type=?) #'k1 #'k2)] - [_ #t]) - (old-type=? t1 t2)))) - (current-type=? type=?) - (current-typecheck-relation (current-type=?))) - -(define-typed-syntax Λ - [(Λ bvs:kind-ctx e) ≫ - [() ([bvs.x : bvs.kind ≫ tv-] ...) ⊢ [[e ≫ e-] ⇒ : τ_e]] - -------- - [⊢ [[_ ≫ e-] ⇒ : (∀ ([tv- : bvs.kind] ...) τ_e)]]]) - -(define-typed-syntax inst - [(inst e τ ...) ≫ - [⊢ [[e ≫ e-] ⇒ : (~∀ (tv ...) τ_body) (⇒ : (~∀★ k ...))]] - [⊢ [[τ ≫ τ-] ⇐ : k] ...] - [#:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)] - -------- - [⊢ [[_ ≫ e-] ⇒ : τ-inst]]]) - diff --git a/tapl/typed-lang-builder/fomega3.rkt b/tapl/typed-lang-builder/fomega3.rkt @@ -1,33 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "sysf.rkt" #:except #%datum ∀ Λ inst) -(reuse String #%datum #:from "stlc+reco+var.rkt") -(require (only-in "fomega.rkt" current-kind? ∀★? ★? kind?)) -(reuse ★ ∀ Λ inst define-type-alias ∀★ #:from "fomega.rkt") - -; same as fomega2.rkt --- λ and #%app works as both regular and type versions, -; → is both type and kind --- but reuses parts of fomega.rkt, -; ie removes the duplication in fomega2.rkt - -;; System F_omega -;; Type relation: -;; - redefine current-kind? and current-type so #%app and λ -;; work for both terms and types -;; Types: -;; - types from fomega.rkt -;; - String from stlc+reco+var -;; Terms: -;; - extend ∀ Λ inst from fomega.rkt -;; - #%datum from stlc+reco+var - -;; types and kinds are now mixed, due to #%app and λ -(begin-for-syntax - (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) - ;; Try to keep "type?" backward compatible with its uses so far, - ;; eg in the definition of λ or previous type constuctors. - ;; (However, this is not completely possible, eg define-type-alias) - ;; So now "type?" no longer validates types, rather it's a subset. - ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) - (current-type? (λ (t) (or (type? t) - (let ([k (typeof t)]) - (or (★? k) (∀★? k))) - ((current-kind?) t))))) diff --git a/tapl/typed-lang-builder/fsub.rkt b/tapl/typed-lang-builder/fsub.rkt @@ -1,92 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+reco+sub.rkt" #:except +) -(require (rename-in (only-in "sysf.rkt" ∀? ∀ ~∀) [~∀ ~sysf:∀] [∀ sysf:∀])) - -;; System F<: -;; Types: -;; - types from sysf.rkt and stlc+reco+sub -;; - extend ∀ with bounds -;; Terms: -;; - terms from sysf.rkt and stlc+reco+sub -;; - extend Λ and inst -;; - redefine + with Nat -;; Other -;; - current-promote, expose -;; - extend current-sub? to call current-promote - -(define-primop + : (→ Nat Nat Nat)) - -; can't just call expose in type-eval, -; otherwise typevars will have bound as type, rather than instantiated type -; only need expose during -; 1) subtype checking -; 2) pattern matching -- including base types -(begin-for-syntax - (define (expose t) - (cond [(identifier? t) - (define sub (typeof t #:tag '<:)) - (if sub (expose sub) t)] - [else t])) - (current-promote expose) - (define stlc:sub? (current-sub?)) - (define (sub? t1 t2) - (stlc:sub? ((current-promote) t1) t2)) - (current-sub? sub?) - (current-typecheck-relation (current-sub?))) - -; quasi-kind, but must be type constructor because its arguments are types -(define-type-constructor <: #:arity >= 0) -(begin-for-syntax - (current-type? (λ (t) (or (type? t) (<:? (typeof t)))))) - -;; Type annotations used in two places: -;; 1) typechecking the body of -;; 2) instantiation of ∀ -;; Problem: need type annotations, even in expanded form -;; Solution: store type annotations in a (quasi) kind <: -(define-typed-syntax ∀ #:datum-literals (<:) - [(∀ ([tv:id <: τ:type] ...) τ_body) ≫ - -------- - ; eval first to overwrite the old #%type - [⊢ [[_ ≫ #,((current-type-eval) #'(sysf:∀ (tv ...) τ_body))] ⇒ : (<: τ.norm ...)]]]) -(begin-for-syntax - (define-syntax ~∀ - (pattern-expander - (syntax-parser #:datum-literals (<:) #:literals (...) - [(_ ([tv:id <: τ_sub] ooo:...) τ) - #'(~and ∀τ - (~parse (~sysf:∀ (tv ooo) τ) #'∀τ) - (~parse (~<: τ_sub ooo) (typeof #'∀τ)))] - [(_ . args) - #'(~and ∀τ - (~parse (~sysf:∀ (tv (... ...)) τ) #'∀τ) - (~parse (~<: τ_sub (... ...)) (typeof #'∀τ)) - (~parse args #'(([tv τ_sub] (... ...)) τ)))]))) - (define-syntax ~∀* - (pattern-expander - (syntax-parser #:datum-literals (<:) - [(_ . args) - #'(~or - (~∀ . args) - (~and any (~do - (type-error - #:src #'any - #:msg "Expected ∀ type, got: ~a" #'any))))])))) - -(define-typed-syntax Λ #:datum-literals (<:) - [(Λ ([tv:id <: τsub:type] ...) e) ≫ - ;; NOTE: store the subtyping relation of tv and τsub in the - ;; environment with a syntax property using another tag: '<: - ;; The "expose" function looks for this tag to enforce the bound, - ;; as in TaPL (fig 28-1) - [([tv : #%type <: τsub ≫ tv-] ...) () ⊢ [[e ≫ e-] ⇒ : τ_e]] - -------- - [⊢ [[_ ≫ e-] ⇒ : (∀ ([tv- <: τsub] ...) τ_e)]]]) -(define-typed-syntax inst - [(inst e τ:type ...) ≫ - [⊢ [[e ≫ e-] ⇒ : (~∀ ([tv <: τ_sub] ...) τ_body)]] - [τ.norm τ⊑ τ_sub #:for τ] ... - [#:with τ_inst (substs #'(τ.norm ...) #'(tv ...) #'τ_body)] - -------- - [⊢ [[_ ≫ e-] ⇒ : τ_inst]]]) - diff --git a/tapl/typed-lang-builder/lang/reader.rkt b/tapl/typed-lang-builder/lang/reader.rkt @@ -1,2 +0,0 @@ -#lang s-exp syntax/module-reader -macrotypes/tapl/typed-lang-builder/typed-lang-builder diff --git a/tapl/typed-lang-builder/mlish.rkt b/tapl/typed-lang-builder/mlish.rkt @@ -1,1430 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(require racket/fixnum racket/flonum - (for-syntax "../type-constraints.rkt" "../variance-constraints.rkt")) - -(extends "ext-stlc.rkt" #:except #%app λ → + - void = zero? sub1 add1 not let let* and #%datum begin - #:rename [~→ ~ext-stlc:→]) -(reuse inst #:from "sysf.rkt") -(require (only-in "ext-stlc.rkt" → →?)) -(require (only-in "sysf.rkt" ~∀ ∀ ∀? Λ)) -(reuse × tup proj define-type-alias #:from "stlc+rec-iso.rkt") -(require (only-in "stlc+rec-iso.rkt" ~× ×?)) ; using current-type=? from here -(provide (rename-out [ext-stlc:and and] [ext-stlc:#%datum #%datum])) -(reuse member length reverse list-ref cons nil isnil head tail list #:from "stlc+cons.rkt") -(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list cons nil))) -(require (only-in "stlc+cons.rkt" ~List List? List)) -(provide List) -(reuse ref deref := Ref #:from "stlc+box.rkt") -(require (rename-in (only-in "stlc+reco+var.rkt" tup proj ×) - [tup rec] [proj get] [× ××])) -(provide rec get ××) -;; for pattern matching -(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list))) -(require (prefix-in stlc+tup: (only-in "stlc+tup.rkt" tup))) - -(module+ test - (require (for-syntax rackunit))) - -(provide → →/test match2 define-type) - -;; ML-like language -;; - top level recursive functions -;; - user-definable algebraic datatypes -;; - pattern matching -;; - (local) type inference - -;; creating possibly polymorphic types -;; ?∀ only wraps a type in a forall if there's at least one type variable -(define-syntax ?∀ - (lambda (stx) - (syntax-case stx () - [(?∀ () body) - #'body] - [(?∀ (X ...) body) - #'(∀ (X ...) body)]))) - -;; ?Λ only wraps an expression in a Λ if there's at least one type variable -(define-syntax ?Λ - (lambda (stx) - (syntax-case stx () - [(?Λ () body) - #'body] - [(?Λ (X ...) body) - #'(Λ (X ...) body)]))) - -(begin-for-syntax - ;; matching possibly polymorphic types - (define-syntax ~?∀ - (pattern-expander - (lambda (stx) - (syntax-case stx () - [(?∀ vars-pat body-pat) - #'(~or (~∀ vars-pat body-pat) - (~and (~not (~∀ _ _)) - (~parse vars-pat #'()) - body-pat))])))) - - ;; find-free-Xs : (Stx-Listof Id) Type -> (Listof Id) - ;; finds the free Xs in the type - (define (find-free-Xs Xs ty) - (for/list ([X (in-list (stx->list Xs))] - #:when (stx-contains-id? ty X)) - X)) - - ;; solve for Xs by unifying quantified fn type with the concrete types of stx's args - ;; stx = the application stx = (#%app e_fn e_arg ...) - ;; tyXs = input and output types from fn type - ;; ie (typeof e_fn) = (-> . tyXs) - ;; It infers the types of arguments from left-to-right, - ;; and it expands and returns all of the arguments. - ;; It returns list of 3 values if successful, else throws a type error - ;; - a list of all the arguments, expanded - ;; - a list of all the type variables - ;; - the constraints for substituting the types - (define (solve Xs tyXs stx) - (syntax-parse tyXs - [(τ_inX ... τ_outX) - ;; generate initial constraints with expected type and τ_outX - #:with (~?∀ Vs expected-ty) (and (get-expected-type stx) - ((current-type-eval) (get-expected-type stx))) - (define initial-cs - (if (and (syntax-e #'expected-ty) (stx-null? #'Vs)) - (add-constraints Xs '() (list (list #'expected-ty #'τ_outX))) - #'())) - (syntax-parse stx - [(_ e_fn . args) - (define-values (as- cs) - (for/fold ([as- null] [cs initial-cs]) - ([a (in-list (syntax->list #'args))] - [tyXin (in-list (syntax->list #'(τ_inX ...)))]) - (define ty_in (inst-type/cs Xs cs tyXin)) - (define/with-syntax [a- ty_a] - (infer+erase (if (empty? (find-free-Xs Xs ty_in)) - (add-expected-ty a ty_in) - a))) - (values - (cons #'a- as-) - (add-constraints Xs cs (list (list ty_in #'ty_a)) - (list (list (inst-type/cs/orig - Xs cs ty_in - (λ (id1 id2) - (equal? (syntax->datum id1) - (syntax->datum id2)))) - #'ty_a)))))) - - (list (reverse as-) Xs cs)])])) - - (define (mk-app-poly-infer-error stx expected-tys given-tys e_fn) - (format (string-append - "Could not infer instantiation of polymorphic function ~s.\n" - " expected: ~a\n" - " given: ~a") - (syntax->datum (get-orig e_fn)) - (string-join (stx-map type->str expected-tys) ", ") - (string-join (stx-map type->str given-tys) ", "))) - - ;; covariant-Xs? : Type -> Bool - ;; Takes a possibly polymorphic type, and returns true if all of the - ;; type variables are in covariant positions within the type, false - ;; otherwise. - (define (covariant-Xs? ty) - (syntax-parse ((current-type-eval) ty) - [(~?∀ Xs ty) - (for/and ([X (in-list (syntax->list #'Xs))]) - (covariant-X? X #'ty))])) - - ;; find-X-variance : Id Type [Variance] -> Variance - ;; Returns the variance of X within the type ty - (define (find-X-variance X ty [ctxt-variance covariant]) - (match (find-variances (list X) ty ctxt-variance) - [(list variance) variance])) - - ;; covariant-X? : Id Type -> Bool - ;; Returns true if every place X appears in ty is a covariant position, false otherwise. - (define (covariant-X? X ty) - (variance-covariant? (find-X-variance X ty covariant))) - - ;; contravariant-X? : Id Type -> Bool - ;; Returns true if every place X appears in ty is a contravariant position, false otherwise. - (define (contravariant-X? X ty) - (variance-contravariant? (find-X-variance X ty covariant))) - - ;; find-variances : (Listof Id) Type [Variance] -> (Listof Variance) - ;; Returns the variances of each of the Xs within the type ty, - ;; where it's already within a context represented by ctxt-variance. - (define (find-variances Xs ty [ctxt-variance covariant]) - (syntax-parse ty - [A:id - (for/list ([X (in-list Xs)]) - (cond [(free-identifier=? X #'A) ctxt-variance] - [else irrelevant]))] - [(~Any tycons) - (make-list (length Xs) irrelevant)] - [(~?∀ () (~Any tycons τ ...)) - #:when (get-arg-variances #'tycons) - #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) - (define τ-ctxt-variances - (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) - (variance-compose ctxt-variance arg-variance))) - (for/fold ([acc (make-list (length Xs) irrelevant)]) - ([τ (in-list (syntax->list #'[τ ...]))] - [τ-ctxt-variance (in-list τ-ctxt-variances)]) - (map variance-join - acc - (find-variances Xs τ τ-ctxt-variance)))] - [ty - #:when (not (for/or ([X (in-list Xs)]) - (stx-contains-id? #'ty X))) - (make-list (length Xs) irrelevant)] - [_ (make-list (length Xs) invariant)])) - - ;; find-variances/exprs : (Listof Id) Type [Variance-Expr] -> (Listof Variance-Expr) - ;; Like find-variances, but works with Variance-Exprs instead of - ;; concrete variance values. - (define (find-variances/exprs Xs ty [ctxt-variance covariant]) - (syntax-parse ty - [A:id - (for/list ([X (in-list Xs)]) - (cond [(free-identifier=? X #'A) ctxt-variance] - [else irrelevant]))] - [(~Any tycons) - (make-list (length Xs) irrelevant)] - [(~?∀ () (~Any tycons τ ...)) - #:when (get-arg-variances #'tycons) - #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) - (define τ-ctxt-variances - (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) - (variance-compose/expr ctxt-variance arg-variance))) - (for/fold ([acc (make-list (length Xs) irrelevant)]) - ([τ (in-list (syntax->list #'[τ ...]))] - [τ-ctxt-variance (in-list τ-ctxt-variances)]) - (map variance-join/expr - acc - (find-variances/exprs Xs τ τ-ctxt-variance)))] - [ty - #:when (not (for/or ([X (in-list Xs)]) - (stx-contains-id? #'ty X))) - (make-list (length Xs) irrelevant)] - [_ (make-list (length Xs) invariant)])) - - ;; current-variance-constraints : (U False (Mutable-Setof Variance-Constraint)) - ;; If this is false, that means that infer-variances should return concrete Variance values. - ;; If it's a mutable set, that means that infer-variances should mutate it and return false, - ;; and type constructors should return the list of variance vars. - (define current-variance-constraints (make-parameter #false)) - - ;; infer-variances : - ;; ((-> Stx) -> Stx) (Listof Variance-Var) (Listof Id) (Listof Type-Stx) - ;; -> (U False (Listof Variance)) - (define (infer-variances with-variance-vars-okay variance-vars Xs τs) - (cond - [(current-variance-constraints) - (define variance-constraints (current-variance-constraints)) - (define variance-exprs - (for/fold ([exprs (make-list (length variance-vars) irrelevant)]) - ([τ (in-list τs)]) - (define/syntax-parse (~?∀ Xs* τ*) - ;; This can mutate variance-constraints! - ;; This avoids causing an infinite loop by having the type - ;; constructors provide with-variance-vars-okay so that within - ;; this call they declare variance-vars for their variances. - (with-variance-vars-okay - (λ () ((current-type-eval) #`(∀ #,Xs #,τ))))) - (map variance-join/expr - exprs - (find-variances/exprs (syntax->list #'Xs*) #'τ* covariant)))) - (for ([var (in-list variance-vars)] - [expr (in-list variance-exprs)]) - (set-add! variance-constraints (variance= var expr))) - #f] - [else - (define variance-constraints (mutable-set)) - ;; This will mutate variance-constraints! - (parameterize ([current-variance-constraints variance-constraints]) - (infer-variances with-variance-vars-okay variance-vars Xs τs)) - (define mapping - (solve-variance-constraints variance-vars - (set->list variance-constraints) - (variance-mapping))) - (for/list ([var (in-list variance-vars)]) - (variance-mapping-ref mapping var))])) - - ;; make-arg-variances-proc : - ;; (Listof Variance-Var) (Listof Id) (Listof Type-Stx) -> (Stx -> (U (Listof Variance) - ;; (Listof Variance-Var))) - (define (make-arg-variances-proc arg-variance-vars Xs τs) - ;; variance-vars-okay? : (Parameterof Boolean) - ;; A parameter that determines whether or not it's okay for - ;; this type constructor to return a list of Variance-Vars - ;; for the variances. - (define variance-vars-okay? (make-parameter #false)) - ;; with-variance-vars-okay : (-> A) -> A - (define (with-variance-vars-okay f) - (parameterize ([variance-vars-okay? #true]) - (f))) - ;; arg-variances : (Boxof (U False (List Variance ...))) - ;; If false, means that the arg variances have not been - ;; computed yet. Otherwise, stores the complete computed - ;; variances for the arguments to this type constructor. - (define arg-variances (box #f)) - ;; arg-variances-proc : Stx -> (U (Listof Variance) (Listof Variance-Var)) - (define (arg-variance-proc stx) - (or (unbox arg-variances) - (cond - [(variance-vars-okay?) - arg-variance-vars] - [else - (define inferred-variances - (infer-variances - with-variance-vars-okay - arg-variance-vars - Xs - τs)) - (cond [inferred-variances - (set-box! arg-variances inferred-variances) - inferred-variances] - [else - arg-variance-vars])]))) - arg-variance-proc) - - ;; compute unbound tyvars in one unexpanded type ty - (define (compute-tyvar1 ty) - (syntax-parse ty - [X:id #'(X)] - [() #'()] - [(C t ...) (stx-appendmap compute-tyvar1 #'(t ...))])) - ;; computes unbound ids in (unexpanded) tys, to be used as tyvars - (define (compute-tyvars tys) - (define Xs (stx-appendmap compute-tyvar1 tys)) - (filter - (lambda (X) - (with-handlers - ([exn:fail:syntax:unbound? (lambda (e) #t)] - [exn:fail:type:infer? (lambda (e) #t)]) - (let ([X+ ((current-type-eval) X)]) - (not (or (tyvar? X+) (type? X+)))))) - (stx-remove-dups Xs)))) - -;; define -------------------------------------------------- -;; for function defs, define infers type variables -;; - since the order of the inferred type variables depends on expansion order, -;; which is not known to programmers, to make the result slightly more -;; intuitive, we arbitrarily sort the inferred tyvars lexicographically -(define-typed-syntax define - [(define x:id e) ≫ - [⊢ [[e ≫ e-] ⇒ : τ]] - [#:with y (generate-temporary)] - -------- - [_ ≻ (begin- - (define-syntax x (make-rename-transformer (⊢ y : τ))) - (define- y e-))]] - ; explicit "forall" - [(define Ys (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) - e_body ... e) ≫ - [#:when (brace? #'Ys)] - ;; TODO; remove this code duplication - [#:with g (add-orig (generate-temporary #'f) #'f)] - [#:with e_ann #'(add-expected e τ_out)] - [#:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out))] - ;; TODO: check that specified return type is correct - ;; - currently cannot do it here; to do the check here, need all types of - ;; top-lvl fns, since they can call each other - [#:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) - ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...)))] - -------- - [_ ≻ (begin- - (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) - (define- g - (Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]] - ;; alternate type sig syntax, after parameter names - [(define (f:id x:id ...) (~datum :) ty ... (~or (~datum ->) (~datum →)) ty_out . b) ≫ - -------- - [_ ≻ (define (f [x : ty] ... -> ty_out) . b)]] - [(define (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) - e_body ... e) ≫ - [#:with Ys (compute-tyvars #'(τ ... τ_out))] - [#:with g (add-orig (generate-temporary #'f) #'f)] - [#:with e_ann (syntax/loc #'e (ann e : τ_out))] ; must be macro bc t_out may have unbound tvs - [#:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out))] - ;; TODO: check that specified return type is correct - ;; - currently cannot do it here; to do the check here, need all types of - ;; top-lvl fns, since they can call each other - [#:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) - (set-stx-prop/preserved - ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...))) - 'orig - (list #'(→ τ+orig ...)))] - -------- - [_ ≻ (begin- - (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) - (define- g - (?Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]]) - -;; define-type ----------------------------------------------- -;; TODO: should validate τ as part of define-type definition (before it's used) -;; - not completely possible, since some constructors may not be defined yet, -;; ie, mutually recursive datatypes -;; for now, validate types but punt if encountering unbound ids -(define-syntax (define-type stx) - (syntax-parse stx - [(define-type Name:id . rst) - #:with NewName (generate-temporary #'Name) - #:with Name2 (add-orig #'(NewName) #'Name) - #`(begin- - (define-type Name2 . #,(subst #'Name2 #'Name #'rst)) - (stlc+rec-iso:define-type-alias Name Name2))] - [(define-type (Name:id X:id ...) - ;; constructors must have the form (Cons τ ...) - ;; but the first ~or clause accepts 0-arg constructors as ids; - ;; the ~and is a workaround to bind the duplicate Cons ids (see Ryan's email) - (~and (~or (~and IdCons:id - (~parse (Cons [fld (~datum :) τ] ...) #'(IdCons))) - (Cons [fld (~datum :) τ] ...) - (~and (Cons τ ...) - (~parse (fld ...) (generate-temporaries #'(τ ...)))))) ...) - ;; validate tys - #:with (ty_flat ...) (stx-flatten #'((τ ...) ...)) - #:with (_ _ (_ _ (_ _ (_ _ ty+ ...)))) - (with-handlers - ([exn:fail:syntax:unbound? - (λ (e) - (define X (stx-car (exn:fail:syntax-exprs e))) - #`(lambda () (let-syntax () (let-syntax () (#%app void unbound)))))]) - (expand/df - #`(lambda (X ...) - (let-syntax - ([Name - (syntax-parser - [(_ X ...) (mk-type #'void)] - [stx - (type-error - #:src #'stx - #:msg - (format "Improper use of constructor ~a; expected ~a args, got ~a" - (syntax->datum #'Name) (stx-length #'(X ...)) - (stx-length (stx-cdr #'stx))))])] - [X (make-rename-transformer (⊢ X #%type))] ...) - (void ty_flat ...))))) - #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...))) - (stx-map - (lambda (t+ t) (unless (type? t+) - (type-error #:src t - #:msg "~a is not a valid type" t))) - #'(ty+ ...) #'(ty_flat ...))) - #:with NameExpander (format-id #'Name "~~~a" #'Name) - #:with NameExtraInfo (format-id #'Name "~a-extra-info" #'Name) - #:with (StructName ...) (generate-temporaries #'(Cons ...)) - #:with ((e_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) - #:with ((e_arg- ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) - #:with ((τ_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) - #:with ((exposed-acc ...) ...) - (stx-map - (λ (C fs) (stx-map (λ (f) (format-id C "~a-~a" C f)) fs)) - #'(Cons ...) #'((fld ...) ...)) - #:with ((acc ...) ...) (stx-map (λ (S fs) (stx-map (λ (f) (format-id S "~a-~a" S f)) fs)) - #'(StructName ...) #'((fld ...) ...)) - #:with (Cons? ...) (stx-map mk-? #'(StructName ...)) - #:with (exposed-Cons? ...) (stx-map mk-? #'(Cons ...)) - #`(begin- - (define-syntax (NameExtraInfo stx) - (syntax-parse stx - [(_ X ...) #'(('Cons 'StructName Cons? [acc τ] ...) ...)])) - (begin-for-syntax - ;; arg-variance-vars : (List Variance-Var ...) - (define arg-variance-vars - (list (variance-var (syntax-e (generate-temporary 'X))) ...))) - (define-type-constructor Name - #:arity = #,(stx-length #'(X ...)) - #:arg-variances (make-arg-variances-proc arg-variance-vars - (list #'X ...) - (list #'τ ... ...)) - #:extra-info 'NameExtraInfo - #:no-provide) - (struct- StructName (fld ...) #:reflection-name 'Cons #:transparent) ... - (define-syntax (exposed-acc stx) ; accessor for records - (syntax-parse stx - [_:id - (⊢ acc (?∀ (X ...) (ext-stlc:→ (Name X ...) τ)))] - [(o . rst) ; handle if used in fn position - #:with app (datum->syntax #'o '#%app) - #`(app - #,(assign-type #'acc #'(?∀ (X ...) (ext-stlc:→ (Name X ...) τ))) - . rst)])) ... ... - (define-syntax (exposed-Cons? stx) ; predicates for each variant - (syntax-parse stx - [_:id (⊢ Cons? (?∀ (X ...) (ext-stlc:→ (Name X ...) Bool)))] - [(o . rst) ; handle if used in fn position - #:with app (datum->syntax #'o '#%app) - #`(app - #,(assign-type #'Cons? #'(?∀ (X ...) (ext-stlc:→ (Name X ...) Bool))) - . rst)])) ... - (define-syntax (Cons stx) - (syntax-parse/typed-syntax stx - ; no args and not polymorphic - [C:id ≫ - [#:when (and (stx-null? #'(X ...)) (stx-null? #'(τ ...)))] - -------- - [_ ≻ (C)]] - ; no args but polymorphic, check expected type - [C:id ⇐ : (NameExpander τ-expected-arg (... ...)) ≫ - [#:when (stx-null? #'(τ ...))] - -------- - [⊢ [[_ ≫ (StructName)] ⇐ : _]]] - ; id with multiple expected args, HO fn - [C:id ≫ - [#:when (not (stx-null? #'(τ ...)))] - -------- - [⊢ [[_ ≫ StructName] ⇒ : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...)))]]] - [(C τs e_arg ...) ≫ - [#:when (brace? #'τs)] ; commit to this clause - [#:with [X* (... ...)] #'[X ...]] - [#:with [e_arg* (... ...)] #'[e_arg ...]] - [#:with {~! τ_X:type (... ...)} #'τs] - [#:with (τ_in:type (... ...)) ; instantiated types - (inst-types/cs #'(X ...) #'([X* τ_X.norm] (... ...)) #'(τ ...))] - [⊢ [[e_arg* ≫ e_arg*-] ⇐ : τ_in.norm] (... ...)] - [#:with [e_arg- ...] #'[e_arg*- (... ...)]] - -------- - [⊢ [[_ ≫ (StructName e_arg- ...)] ⇒ : (Name τ_X.norm (... ...))]]] - [(C . args) ≫ ; no type annotations, must infer instantiation - [#:with StructName/ty - (set-stx-prop/preserved - (⊢ StructName : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...)))) - 'orig - (list #'C))] - -------- - [_ ≻ (mlish:#%app StructName/ty . args)]])) - ...)])) - -;; match -------------------------------------------------- -(begin-for-syntax - (define (get-ctx pat ty) - (unify-pat+ty (list pat ty))) - (define (unify-pat+ty pat+ty) - (syntax-parse pat+ty - [(pat ty) #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) - (syntax-parse #'pat - [{(~datum _)} #'()] - [{(~literal stlc+cons:nil)} #'()] - [{A:id} ; disambiguate 0-arity constructors (that don't need parens) - #:when (get-extra-info #'ty) - #'()] - ;; comma tup syntax always has parens - [{(~and ps (p1 (unq p) ...))} - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - (unify-pat+ty #'(ps ty))] - [{p ...} - (unify-pat+ty #'((p ...) ty))])] ; pair - [((~datum _) ty) #'()] - [((~or (~literal stlc+cons:nil)) ty) #'()] - [(A:id ty) ; disambiguate 0-arity constructors (that don't need parens) - #:with (_ (_ (_ C) . _) ...) (get-extra-info #'ty) - #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) - #'()] - [(x:id ty) #'((x ty))] - [((p1 (unq p) ...) ty) ; comma tup stx - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - #:with (~× t ...) #'ty - #:with (pp ...) #'(p1 p ...) - (unifys #'([pp t] ...))] - [(((~literal stlc+tup:tup) p ...) ty) ; tup - #:with (~× t ...) #'ty - (unifys #'([p t] ...))] - [(((~literal stlc+cons:list) p ...) ty) ; known length list - #:with (~List t) #'ty - (unifys #'([p t] ...))] - [(((~seq p (~datum ::)) ... rst) ty) ; nicer cons stx - #:with (~List t) #'ty - (unifys #'([p t] ... [rst ty]))] - [(((~literal stlc+cons:cons) p ps) ty) ; arb length list - #:with (~List t) #'ty - (unifys #'([p t] [ps ty]))] - [((Name p ...) ty) - #:with (_ (_ Cons) _ _ [_ _ τ] ...) - (stx-findf - (syntax-parser - [(_ 'C . rst) - (equal? (syntax->datum #'Name) (syntax->datum #'C))]) - (stx-cdr (get-extra-info #'ty))) - (unifys #'([p τ] ...))] - [p+t #:fail-when #t (format "could not unify ~a" (syntax->datum #'p+t)) - #'()])) - (define (unifys p+tys) (stx-appendmap unify-pat+ty p+tys)) - - (define (compile-pat p ty) - (syntax-parse p - [pat #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) - (syntax-parse #'pat - [{(~datum _)} #'_] - [{(~literal stlc+cons:nil)} (syntax/loc p (list))] - [{A:id} ; disambiguate 0-arity constructors (that don't need parens) - #:when (get-extra-info ty) - (compile-pat #'(A) ty)] - ;; comma tup stx always has parens - [{(~and ps (p1 (unq p) ...))} - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - (compile-pat #'ps ty)] - [{pat ...} (compile-pat (syntax/loc p (pat ...)) ty)])] - [(~datum _) #'_] - [(~literal stlc+cons:nil) ; nil - #'(list)] - [A:id ; disambiguate 0-arity constructors (that don't need parens) - #:with (_ (_ (_ C) . _) ...) (get-extra-info ty) - #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) - (compile-pat #'(A) ty)] - [x:id p] - [(p1 (unq p) ...) ; comma tup stx - #:when (not (stx-null? #'(p ...))) - #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) - #:with (~× t ...) ty - #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'(p1 p ...) #'(t ...)) - #'(list p- ...)] - [((~literal stlc+tup:tup) . pats) - #:with (~× . tys) ty - #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'pats #'tys) - (syntax/loc p (list p- ...))] - [((~literal stlc+cons:list) . ps) - #:with (~List t) ty - #:with (p- ...) (stx-map (lambda (p) (compile-pat p #'t)) #'ps) - (syntax/loc p (list p- ...))] - [((~seq pat (~datum ::)) ... last) ; nicer cons stx - #:with (~List t) ty - #:with (p- ...) (stx-map (lambda (pp) (compile-pat pp #'t)) #'(pat ...)) - #:with last- (compile-pat #'last ty) - (syntax/loc p (list-rest p- ... last-))] - [((~literal stlc+cons:cons) p ps) - #:with (~List t) ty - #:with p- (compile-pat #'p #'t) - #:with ps- (compile-pat #'ps ty) - #'(cons p- ps-)] - [(Name . pats) - #:with (_ (_ Cons) (_ StructName) _ [_ _ τ] ...) - (stx-findf - (syntax-parser - [(_ 'C . rst) - (equal? (syntax->datum #'Name) (syntax->datum #'C))]) - (stx-cdr (get-extra-info ty))) - #:with (p- ...) (stx-map compile-pat #'pats #'(τ ...)) - (syntax/loc p (StructName p- ...))])) - - ;; pats = compiled pats = racket pats - (define (check-exhaust pats ty) - (define (else-pat? p) - (syntax-parse p [(~literal _) #t] [_ #f])) - (define (nil-pat? p) - (syntax-parse p - [((~literal list)) #t] - [_ #f])) - (define (non-nil-pat? p) - (syntax-parse p - [((~literal list-rest) . rst) #t] - [((~literal cons) . rst) #t] - [_ #f])) - (define (tup-pat? p) - (syntax-parse p - [((~literal list) . _) #t] [_ #f])) - (cond - [(or (stx-ormap else-pat? pats) (stx-ormap identifier? pats)) #t] - [(List? ty) ; lists - (unless (stx-ormap nil-pat? pats) - (error 'match2 (let ([last (car (stx-rev pats))]) - (format "(~a:~a) missing nil clause for list expression" - (syntax-line last) (syntax-column last))))) - (unless (stx-ormap non-nil-pat? pats) - (error 'match2 (let ([last (car (stx-rev pats))]) - (format "(~a:~a) missing clause for non-empty, arbitrary length list" - (syntax-line last) (syntax-column last))))) - #t] - [(×? ty) ; tuples - (unless (stx-ormap tup-pat? pats) - (error 'match2 (let ([last (car (stx-rev pats))]) - (format "(~a:~a) missing pattern for tuple expression" - (syntax-line last) (syntax-column last))))) - (syntax-parse pats - [((_ p ...) ...) - (syntax-parse ty - [(~× t ...) - (apply stx-andmap - (lambda (t . ps) (check-exhaust ps t)) - #'(t ...) - (syntax->list #'((p ...) ...)))])])] - [else ; algebraic datatypes - (syntax-parse (get-extra-info ty) - [(_ (_ (_ C) (_ Cstruct) . rst) ...) - (syntax-parse pats - [((Cpat _ ...) ...) - (define Cs (syntax->datum #'(C ...))) - (define Cstructs (syntax->datum #'(Cstruct ...))) - (define Cpats (syntax->datum #'(Cpat ...))) - (unless (set=? Cstructs Cpats) - (error 'match2 - (let ([last (car (stx-rev pats))]) - (format "(~a:~a) clauses not exhaustive; missing: ~a" - (syntax-line last) (syntax-column last) - (string-join - (for/list ([C Cs][Cstr Cstructs] #:unless (member Cstr Cpats)) - (symbol->string C)) - ", "))))) - #t])] - [_ #t])])) - - ;; TODO: do get-ctx and compile-pat in one pass - (define (compile-pats pats ty) - (stx-map (lambda (p) (list (get-ctx p ty) (compile-pat p ty))) pats)) - ) - -(define-typed-syntax match2 #:datum-literals (with ->) - [(match2 e with . clauses) ≫ - [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] - [⊢ [[e ≫ e-] ⇒ : τ_e]] - [#:with ([(~seq p ...) -> e_body] ...) #'clauses] - [#:with (pat ...) (stx-map ; use brace to indicate root pattern - (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc stx {pp ...})])) - #'((p ...) ...)) ] - [#:with ([(~and ctx ([x ty] ...)) pat-] ...) (compile-pats #'(pat ...) #'τ_e)] - [#:with ty-expected (get-expected-type stx)] - [() ([x : ty ≫ x-] ...) - ⊢ [[(add-expected e_body ty-expected) ≫ e_body-] ⇒ : ty_body]] - ... - [#:when (check-exhaust #'(pat- ...) #'τ_e)] - -------- - [⊢ [[_ ≫ (match- e- [pat- (let- ([x- x] ...) e_body-)] ...)] - ⇒ : (⊔ ty_body ...)]]]) - -(define-typed-syntax match #:datum-literals (with -> ::) - ;; e is a tuple - [(match e with . clauses) ≫ - [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] - [⊢ [[e ≫ e-] ⇒ : τ_e]] - [#:when (×? #'τ_e)] - [#:with t_expect (get-expected-type stx)] ; propagate inferred type - [#:with ([x ... -> e_body]) #'clauses] - [#:with (~× ty ...) #'τ_e] - [#:fail-unless (stx-length=? #'(ty ...) #'(x ...)) - "match clause pattern not compatible with given tuple"] - [() ([x : ty ≫ x-] ...) - ⊢ [[(add-expected e_body t_expect) ≫ e_body-] ⇒ : ty_body]] - [#:with (acc ...) (for/list ([(a i) (in-indexed (syntax->list #'(x ...)))]) - #`(lambda (s) (list-ref s #,(datum->syntax #'here i))))] - [#:with z (generate-temporary)] - -------- - [⊢ [[_ ≫ (let- ([z e-]) - (let- ([x- (acc z)] ...) e_body-))] - ⇒ : ty_body]]] - ;; e is a list - [(match e with . clauses) ≫ - [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] - [⊢ [[e ≫ e-] ⇒ : τ_e]] - [#:when (List? #'τ_e)] - [#:with t_expect (get-expected-type stx)] ; propagate inferred type - [#:with ([(~or (~and (~and xs [x ...]) (~parse rst (generate-temporary))) - (~and (~seq (~seq x ::) ... rst:id) (~parse xs #'()))) - -> e_body] ...+) - #'clauses] - [#:fail-unless (stx-ormap - (lambda (xx) (and (brack? xx) (zero? (stx-length xx)))) - #'(xs ...)) - "match: missing empty list case"] - [#:fail-unless (not (and (stx-andmap brack? #'(xs ...)) - (= 1 (stx-length #'(xs ...))))) - "match: missing non-empty list case"] - [#:with (~List ty) #'τ_e] - [() ([x : ty ≫ x-] ... [rst : (List ty) ≫ rst-]) - ⊢ [[(add-expected e_body t_expect) ≫ e_body-] ⇒ : ty_body]] - ... - [#:with (len ...) (stx-map (lambda (p) #`#,(stx-length p)) #'((x ...) ...))] - [#:with (lenop ...) (stx-map (lambda (p) (if (brack? p) #'=- #'>=-)) #'(xs ...))] - [#:with (pred? ...) (stx-map - (lambda (l lo) #`(λ- (lst) (#,lo (length lst) #,l))) - #'(len ...) #'(lenop ...))] - [#:with ((acc1 ...) ...) (stx-map - (lambda (xs) - (for/list ([(x i) (in-indexed (syntax->list xs))]) - #`(lambda- (lst) (list-ref- lst #,(datum->syntax #'here i))))) - #'((x ...) ...))] - [#:with (acc2 ...) (stx-map (lambda (l) #`(lambda- (lst) (list-tail- lst #,l))) #'(len ...))] - -------- - [⊢ [[_ ≫ (let- ([z e-]) - (cond- - [(pred? z) - (let- ([x- (acc1 z)] ... [rst- (acc2 z)]) e_body-)] ...))] - ⇒ : (⊔ ty_body ...)]]] - ;; e is a variant - [(match e with . clauses) ≫ - [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] - [⊢ [[e ≫ e-] ⇒ : τ_e]] - [#:when (and (not (×? #'τ_e)) (not (List? #'τ_e)))] - [#:with t_expect (get-expected-type stx)] ; propagate inferred type - [#:with ([Clause:id x:id ... - (~optional (~seq #:when e_guard) #:defaults ([e_guard #'(ext-stlc:#%datum . #t)])) - -> e_c_un] ...+) ; un = unannotated with expected ty - #'clauses] - ;; length #'clauses may be > length #'info, due to guards - [#:with info-body (get-extra-info #'τ_e)] - [#:with (_ (_ (_ ConsAll) . _) ...) #'info-body] - [#:fail-unless (set=? (syntax->datum #'(Clause ...)) - (syntax->datum #'(ConsAll ...))) - (type-error #:src stx - #:msg (string-append - "match: clauses not exhaustive; missing: " - (string-join - (map symbol->string - (set-subtract - (syntax->datum #'(ConsAll ...)) - (syntax->datum #'(Clause ...)))) - ", ")))] - [#:with ((_ _ _ Cons? [_ acc τ] ...) ...) - (map ; ok to compare symbols since clause names can't be rebound - (lambda (Cl) - (stx-findf - (syntax-parser - [(_ 'C . rst) (equal? Cl (syntax->datum #'C))]) - (stx-cdr #'info-body))) ; drop leading #%app - (syntax->datum #'(Clause ...)))] - ;; this commented block experiments with expanding to unsafe ops - ;; [#:with ((acc ...) ...) (stx-map - ;; (lambda (accs) - ;; (for/list ([(a i) (in-indexed (syntax->list accs))]) - ;; #`(lambda (s) (unsafe-struct*-ref s #,(datum->syntax #'here i))))) - ;; #'((acc-fn ...) ...))] - [#:with (e_c ...+) (stx-map (lambda (ec) (add-expected-ty ec #'t_expect)) #'(e_c_un ...))] - [() ([x : τ ≫ x-] ...) - ⊢ [[e_guard ≫ e_guard-] ⇐ : Bool] [[e_c ≫ e_c-] ⇒ : τ_ec]] - ... - [#:with z (generate-temporary)] ; dont duplicate eval of test expr - -------- - [⊢ [[_ ≫ (let- ([z e-]) - (cond- - [(and- (Cons? z) - (let- ([x- (acc z)] ...) e_guard-)) - (let- ([x- (acc z)] ...) e_c-)] ...))] - ⇒ : (⊔ τ_ec ...)]]]) - -; special arrow that computes free vars; for use with tests -; (because we can't write explicit forall -(define-syntax →/test - (syntax-parser - [(→/test (~and Xs (X:id ...)) . rst) - #:when (brace? #'Xs) - #'(?∀ (X ...) (ext-stlc:→ . rst))] - [(→/test . rst) - #:with Xs (compute-tyvars #'rst) - #'(?∀ Xs (ext-stlc:→ . rst))])) - -; redefine these to use lifted → -(define-primop + : (→ Int Int Int)) -(define-primop - : (→ Int Int Int)) -(define-primop * : (→ Int Int Int)) -(define-primop max : (→ Int Int Int)) -(define-primop min : (→ Int Int Int)) -(define-primop void : (→ Unit)) -(define-primop = : (→ Int Int Bool)) -(define-primop <= : (→ Int Int Bool)) -(define-primop < : (→ Int Int Bool)) -(define-primop > : (→ Int Int Bool)) -(define-primop modulo : (→ Int Int Int)) -(define-primop zero? : (→ Int Bool)) -(define-primop sub1 : (→ Int Int)) -(define-primop add1 : (→ Int Int)) -(define-primop not : (→ Bool Bool)) -(define-primop abs : (→ Int Int)) -(define-primop even? : (→ Int Bool)) -(define-primop odd? : (→ Int Bool)) - -; all λs have type (?∀ (X ...) (→ τ_in ... τ_out)) -(define-typed-syntax λ #:datum-literals (:) - [(λ (x:id ...) body) ⇐ : (~?∀ (X ...) (~ext-stlc:→ τ_in ... τ_out)) ≫ - [#:fail-unless (stx-length=? #'[x ...] #'[τ_in ...]) - (format "expected a function of ~a arguments, got one with ~a arguments" - (stx-length #'[τ_in ...]) (stx-length #'[x ...]))] - [([X : #%type ≫ X-] ...) ([x : τ_in ≫ x-] ...) - ⊢ [[body ≫ body-] ⇐ : τ_out]] - -------- - [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇐ : _]]] - [(λ ([x : τ_x] ...) body) ⇐ : (~?∀ (V ...) (~ext-stlc:→ τ_in ... τ_out)) ≫ - [#:with [X ...] (compute-tyvars #'(τ_x ...))] - [([X : #%type ≫ X-] ...) () - ⊢ [[τ_x ≫ τ_x-] ⇐ : #%type] ...] - [τ_in τ⊑ τ_x- #:for x] ... - ;; TODO is there a way to have λs that refer to ids defined after them? - [([V : #%type ≫ V-] ... [X- : #%type ≫ X--] ...) ([x : τ_x- ≫ x-] ...) - ⊢ [[body ≫ body-] ⇐ : τ_out]] - -------- - [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇐ : _]]] - [(λ ([x : τ_x] ...) body) ≫ - [#:with [X ...] (compute-tyvars #'(τ_x ...))] - ;; TODO is there a way to have λs that refer to ids defined after them? - [([X : #%type ≫ X-] ...) ([x : τ_x ≫ x-] ...) - ⊢ [[body ≫ body-] ⇒ : τ_body]] - [#:with [τ_x* ...] (inst-types/cs #'[X ...] #'([X X-] ...) #'[τ_x ...])] - [#:with τ_fn (add-orig #'(?∀ (X- ...) (ext-stlc:→ τ_x* ... τ_body)) - #`(→ #,@(stx-map get-orig #'[τ_x* ...]) #,(get-orig #'τ_body)))] - -------- - [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇒ : τ_fn]]]) - - -;; #%app -------------------------------------------------- -(define-typed-syntax mlish:#%app #:export-as #%app - [(_ e_fn e_arg ...) ≫ - ;; compute fn type (ie ∀ and →) - [⊢ [[e_fn ≫ e_fn-] ⇒ : (~?∀ Xs (~ext-stlc:→ . tyX_args))]] - ;; solve for type variables Xs - [#:with [[e_arg- ...] Xs* cs] (solve #'Xs #'tyX_args stx)] - ;; instantiate polymorphic function type - [#:with [τ_in ... τ_out] (inst-types/cs #'Xs* #'cs #'tyX_args)] - [#:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out)] - ;; arity check - [#:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...]) - (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])] - ;; compute argument types - [#:with (τ_arg ...) (stx-map typeof #'(e_arg- ...))] - ;; typecheck args - [τ_arg τ⊑ τ_in #:for e_arg] ... - [#:with τ_out* (if (stx-null? #'(unsolved-X ...)) - #'τ_out - (syntax-parse #'τ_out - [(~?∀ (Y ...) τ_out) - #:fail-unless (→? #'τ_out) - (mk-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn) - (for ([X (in-list (syntax->list #'(unsolved-X ...)))]) - (unless (covariant-X? X #'τ_out) - (raise-syntax-error - #f - (mk-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn) - stx))) - #'(∀ (unsolved-X ... Y ...) τ_out)]))] - -------- - [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)] ⇒ : τ_out*]]]) - - -;; cond and other conditionals -(define-typed-syntax cond - [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t))) - test) - b ... body] ...+) - ⇐ : τ_expected ≫ - [⊢ [[test ≫ test-] ⇐ : Bool] ...] - [⊢ [[(begin b ... body) ≫ body-] ⇐ : τ_expected] ...] - -------- - [⊢ [[_ ≫ (cond- [test- body-] ...)] ⇐ : _]]] - [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t))) - test) - b ... body] ...+) ≫ - [⊢ [[test ≫ test-] ⇐ : Bool] ...] - [⊢ [[(begin b ... body) ≫ body-] ⇒ : τ_body] ...] - -------- - [⊢ [[_ ≫ (cond- [test- body-] ...)] ⇒ : (⊔ τ_body ...)]]]) -(define-typed-syntax when - [(when test body ...) ≫ - [⊢ [[test ≫ test-] ⇒ : _]] - [⊢ [[body ≫ body-] ⇒ : _] ...] - -------- - [⊢ [[_ ≫ (when- test- body- ... (void-))] ⇒ : Unit]]]) -(define-typed-syntax unless - [(unless test body ...) ≫ - [⊢ [[test ≫ test-] ⇒ : _]] - [⊢ [[body ≫ body-] ⇒ : _] ...] - -------- - [⊢ [[_ ≫ (unless- test- body- ... (void-))] ⇒ : Unit]]]) - -;; sync channels and threads -(define-type-constructor Channel) - -(define-typed-syntax make-channel - [(make-channel (~and tys {ty})) ≫ - [#:when (brace? #'tys)] - -------- - [⊢ [[_ ≫ (make-channel-)] ⇒ : (Channel ty)]]]) -(define-typed-syntax channel-get - [(channel-get c) ⇐ : ty ≫ - [⊢ [[c ≫ c-] ⇐ : (Channel ty)]] - -------- - [⊢ [[_ ≫ (channel-get- c-)] ⇐ : _]]] - [(channel-get c) ≫ - [⊢ [[c ≫ c-] ⇒ : (~Channel ty)]] - -------- - [⊢ [[_ ≫ (channel-get- c-)] ⇒ : ty]]]) -(define-typed-syntax channel-put - [(channel-put c v) ≫ - [⊢ [[c ≫ c-] ⇒ : (~Channel ty)]] - [⊢ [[v ≫ v-] ⇐ : ty]] - -------- - [⊢ [[_ ≫ (channel-put- c- v-)] ⇒ : Unit]]]) - -(define-base-type Thread) - -;; threads -(define-typed-syntax thread - [(thread th) ≫ - [⊢ [[th ≫ th-] ⇒ : (~?∀ () (~ext-stlc:→ τ_out))]] - -------- - [⊢ [[_ ≫ (thread- th-)] ⇒ : Thread]]]) - -(define-primop random : (→ Int Int)) -(define-primop integer->char : (→ Int Char)) -(define-primop string->list : (→ String (List Char))) -(define-primop string->number : (→ String Int)) -;(define-primop number->string : (→ Int String)) -(define-typed-syntax number->string - [number->string:id ≫ - -------- - [⊢ [[_ ≫ number->string-] ⇒ : (→ Int String)]]] - [(number->string n) ≫ - -------- - [_ ≻ (number->string n (ext-stlc:#%datum . 10))]] - [(number->string n rad) ≫ - [⊢ [[n ≫ n-] ⇐ : Int]] - [⊢ [[rad ≫ rad-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (number->string- n rad)] ⇒ : String]]]) -(define-primop string : (→ Char String)) -(define-primop sleep : (→ Int Unit)) -(define-primop string=? : (→ String String Bool)) -(define-primop string<=? : (→ String String Bool)) - -(define-typed-syntax string-append - [(string-append str ...) ≫ - [⊢ [[str ≫ str-] ⇐ : String] ...] - -------- - [⊢ [[_ ≫ (string-append- str- ...)] ⇒ : String]]]) - -;; vectors -(define-type-constructor Vector) - -(define-typed-syntax vector - [(vector (~and tys {ty})) ≫ - [#:when (brace? #'tys)] - -------- - [⊢ [[_ ≫ (vector-)] ⇒ : (Vector ty)]]] - [(vector v ...) ⇐ : (Vector ty) ≫ - [⊢ [[v ≫ v-] ⇐ : ty] ...] - -------- - [⊢ [[_ ≫ (vector- v- ...)] ⇐ : _]]] - [(vector v ...) ≫ - [⊢ [[v ≫ v-] ⇒ : ty] ...] - [#:when (same-types? #'(ty ...))] - [#:with one-ty (stx-car #'(ty ...))] - -------- - [⊢ [[_ ≫ (vector- v- ...)] ⇒ : (Vector one-ty)]]]) -(define-typed-syntax make-vector - [(make-vector n) ≫ - -------- - [_ ≻ (make-vector n (ext-stlc:#%datum . 0))]] - [(make-vector n e) ≫ - [⊢ [[n ≫ n-] ⇐ : Int]] - [⊢ [[e ≫ e-] ⇒ : ty]] - -------- - [⊢ [[_ ≫ (make-vector- n- e-)] ⇒ : (Vector ty)]]]) -(define-typed-syntax vector-length - [(vector-length e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Vector _)]] - -------- - [⊢ [[_ ≫ (vector-length- e-)] ⇒ : Int]]]) -(define-typed-syntax vector-ref - [(vector-ref e n) ⇐ : ty ≫ - [⊢ [[e ≫ e-] ⇐ : (Vector ty)]] - [⊢ [[n ≫ n-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (vector-ref- e- n-)] ⇐ : _]]] - [(vector-ref e n) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]] - [⊢ [[n ≫ n-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (vector-ref- e- n-)] ⇒ : ty]]]) -(define-typed-syntax vector-set! - [(vector-set! e n v) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]] - [⊢ [[n ≫ n-] ⇐ : Int]] - [⊢ [[v ≫ v-] ⇐ : ty]] - -------- - [⊢ [[_ ≫ (vector-set!- e- n- v-)] ⇒ : Unit]]]) -(define-typed-syntax vector-copy! - [(vector-copy! dest start src) ≫ - [⊢ [[dest ≫ dest-] ⇒ : (~Vector ty)]] - [⊢ [[start ≫ start-] ⇐ : Int]] - [⊢ [[src ≫ src-] ⇐ : (Vector ty)]] - -------- - [⊢ [[_ ≫ (vector-copy!- dest- start- src-)] ⇒ : Unit]]]) - - -;; sequences and for loops - -(define-type-constructor Sequence) - -(define-typed-syntax in-range - [(in-range end) ≫ - -------- - [_ ≻ (in-range (ext-stlc:#%datum . 0) end (ext-stlc:#%datum . 1))]] - [(in-range start end) ≫ - -------- - [_ ≻ (in-range start end (ext-stlc:#%datum . 1))]] - [(in-range start end step) ≫ - [⊢ [[start ≫ start-] ⇐ : Int]] - [⊢ [[end ≫ end-] ⇐ : Int]] - [⊢ [[step ≫ step-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (in-range- start- end- step-)] ⇒ : (Sequence Int)]]]) - -(define-typed-syntax in-naturals - [(in-naturals) ≫ - -------- - [_ ≻ (in-naturals (ext-stlc:#%datum . 0))]] - [(in-naturals start) ≫ - [⊢ [[start ≫ start-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (in-naturals- start-)] ⇒ : (Sequence Int)]]]) - - -(define-typed-syntax in-vector - [(in-vector e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]] - -------- - [⊢ [[_ ≫ (in-vector- e-)] ⇒ : (Sequence ty)]]]) - -(define-typed-syntax in-list - [(in-list e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~List ty)]] - -------- - [⊢ [[_ ≫ (in-list- e-)] ⇒ : (Sequence ty)]]]) - -(define-typed-syntax in-lines - [(in-lines e) ≫ - [⊢ [[e ≫ e-] ⇐ : String]] - -------- - [⊢ [[_ ≫ (in-lines- (open-input-string- e-))] ⇒ : (Sequence String)]]]) - -(define-typed-syntax for - [(for ([x:id e]...) b ... body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) - ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇒ : _]] - -------- - [⊢ [[_ ≫ (for- ([x- e-] ...) b- ... body-)] ⇒ : Unit]]]) -(define-typed-syntax for* - [(for* ([x:id e]...) b ... body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) - ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇒ : _]] - -------- - [⊢ [[_ ≫ (for*- ([x- e-] ...) b- ... body-)] ⇒ : Unit]]]) - -(define-typed-syntax for/list - [(for/list ([x:id e]...) body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] - -------- - [⊢ [[_ ≫ (for/list- ([x- e-] ...) body-)] ⇒ : (List ty_body)]]]) -(define-typed-syntax for/vector - [(for/vector ([x:id e]...) body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] - -------- - [⊢ [[_ ≫ (for/vector- ([x- e-] ...) body-)] ⇒ : (Vector ty_body)]]]) -(define-typed-syntax for*/vector - [(for*/vector ([x:id e]...) body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] - -------- - [⊢ [[_ ≫ (for*/vector- ([x- e-] ...) body-)] ⇒ : (Vector ty_body)]]]) -(define-typed-syntax for*/list - [(for*/list ([x:id e]...) body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] - -------- - [⊢ [[_ ≫ (for*/list- ([x- e-] ...) body-)] ⇒ : (List ty_body)]]]) -(define-typed-syntax for/fold - [(for/fold ([acc init]) ([x:id e] ...) body) ⇐ : τ_expected ≫ - [⊢ [[init ≫ init-] ⇐ : τ_expected]] - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([acc : τ_expected ≫ acc-] [x : ty ≫ x-] ...) - ⊢ [[body ≫ body-] ⇐ : τ_expected]] - -------- - [⊢ [[_ ≫ (for/fold- ([acc- init-]) ([x- e-] ...) body-)] ⇐ : _]]] - [(for/fold ([acc init]) ([x:id e] ...) body) ≫ - [⊢ [[init ≫ init-] ⇒ : τ_init]] - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([acc : τ_init ≫ acc-] [x : ty ≫ x-] ...) - ⊢ [[body ≫ body-] ⇐ : τ_init]] - -------- - [⊢ [[_ ≫ (for/fold- ([acc- init-]) ([x- e-] ...) body-)] ⇒ : τ_init]]]) - -(define-typed-syntax for/hash - [(for/hash ([x:id e]...) body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : (~× ty_k ty_v)]] - -------- - [⊢ [[_ ≫ (for/hash- ([x- e-] ...) - (let- ([t body-]) - (values- (car- t) (cadr- t))))] - ⇒ : (Hash ty_k ty_v)]]]) - -(define-typed-syntax for/sum - [(for/sum ([x:id e]... - (~optional (~seq #:when guard) #:defaults ([guard #'#t]))) - body) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] - [() ([x : ty ≫ x-] ...) - ⊢ [[guard ≫ guard-] ⇒ : _] [[body ≫ body-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (for/sum- ([x- e-] ... #:when guard-) body-)] ⇒ : Int]]]) - -; printing and displaying -(define-typed-syntax printf - [(printf str e ...) ≫ - [⊢ [[str ≫ s-] ⇐ : String]] - [⊢ [[e ≫ e-] ⇒ : ty] ...] - -------- - [⊢ [[_ ≫ (printf- s- e- ...)] ⇒ : Unit]]]) -(define-typed-syntax format - [(format str e ...) ≫ - [⊢ [[str ≫ s-] ⇐ : String]] - [⊢ [[e ≫ e-] ⇒ : ty] ...] - -------- - [⊢ [[_ ≫ (format- s- e- ...)] ⇒ : String]]]) -(define-typed-syntax display - [(display e) ≫ - [⊢ [[e ≫ e-] ⇒ : _]] - -------- - [⊢ [[_ ≫ (display- e-)] ⇒ : Unit]]]) -(define-typed-syntax displayln - [(displayln e) ≫ - [⊢ [[e ≫ e-] ⇒ : _]] - -------- - [⊢ [[_ ≫ (displayln- e-)] ⇒ : Unit]]]) -(define-primop newline : (→ Unit)) - -(define-typed-syntax list->vector - [(list->vector e) ⇐ : (~Vector ty) ≫ - [⊢ [[e ≫ e-] ⇐ : (List ty)]] - -------- - [⊢ [[_ ≫ (list->vector- e-)] ⇐ : _]]] - [(list->vector e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~List ty)]] - -------- - [⊢ [[_ ≫ (list->vector- e-)] ⇒ : (Vector ty)]]]) - -(define-typed-syntax let - [(let name:id (~datum :) ty:type ~! ([x:id e] ...) b ... body) ≫ - [⊢ [[e ≫ e-] ⇒ : ty_e] ...] - [() ([name : (→ ty_e ... ty.norm) ≫ name-] [x : ty_e ≫ x-] ...) - ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇐ : ty.norm]] - -------- - [⊢ [[_ ≫ (letrec- ([name- (λ- (x- ...) b- ... body-)]) - (name- e- ...))] - ⇒ : ty.norm]]] - [(let ([x:id e] ...) body ...) ≫ - -------- - [_ ≻ (ext-stlc:let ([x e] ...) (begin body ...))]]) -(define-typed-syntax let* - [(let* ([x:id e] ...) body ...) ≫ - -------- - [_ ≻ (ext-stlc:let* ([x e] ...) (begin body ...))]]) - -(define-typed-syntax begin - [(begin body ... b) ⇐ : τ_expected ≫ - [⊢ [[body ≫ body-] ⇒ : _] ...] - [⊢ [[b ≫ b-] ⇐ : τ_expected]] - -------- - [⊢ [[_ ≫ (begin- body- ... b-)] ⇐ : _]]] - [(begin body ... b) ≫ - [⊢ [[body ≫ body-] ⇒ : _] ...] - [⊢ [[b ≫ b-] ⇒ : τ]] - -------- - [⊢ [[_ ≫ (begin- body- ... b-)] ⇒ : τ]]]) - -;; hash -(define-type-constructor Hash #:arity = 2) - -(define-typed-syntax in-hash - [(in-hash e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Hash ty_k ty_v)]] - -------- - [⊢ [[_ ≫ (hash-map- e- list-)] ⇒ : (Sequence (stlc+rec-iso:× ty_k ty_v))]]]) - -; mutable hashes -(define-typed-syntax hash - [(hash (~and tys {ty_key ty_val})) ≫ - [#:when (brace? #'tys)] - -------- - [⊢ [[_ ≫ (make-hash-)] ⇒ : (Hash ty_key ty_val)]]] - [(hash (~seq k v) ...) ≫ - [⊢ [[k ≫ k-] ⇒ : ty_k] ...] - [⊢ [[v ≫ v-] ⇒ : ty_v] ...] - [#:when (same-types? #'(ty_k ...))] - [#:when (same-types? #'(ty_v ...))] - [#:with ty_key (stx-car #'(ty_k ...))] - [#:with ty_val (stx-car #'(ty_v ...))] - -------- - [⊢ [[_ ≫ (make-hash- (list- (cons- k- v-) ...))] ⇒ : (Hash ty_key ty_val)]]]) -(define-typed-syntax hash-set! - [(hash-set! h k v) ≫ - [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]] - [⊢ [[k ≫ k-] ⇐ : ty_k]] - [⊢ [[v ≫ v-] ⇐ : ty_v]] - -------- - [⊢ [[_ ≫ (hash-set!- h- k- v-)] ⇒ : Unit]]]) -(define-typed-syntax hash-ref - [(hash-ref h k) ≫ - [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]] - [⊢ [[k ≫ k-] ⇐ : ty_k]] - -------- - [⊢ [[_ ≫ (hash-ref- h- k-)] ⇒ : ty_v]]] - [(hash-ref h k fail) ≫ - [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]] - [⊢ [[k ≫ k-] ⇐ : ty_k]] - [⊢ [[fail ≫ fail-] ⇐ : (→ ty_v)]] - -------- - [⊢ [[_ ≫ (hash-ref- h- k- fail-)] ⇒ : ty_val]]]) -(define-typed-syntax hash-has-key? - [(hash-has-key? h k) ≫ - [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k _)]] - [⊢ [[k ≫ k-] ⇐ : ty_k]] - -------- - [⊢ [[_ ≫ (hash-has-key?- h- k-)] ⇒ : Bool]]]) - -(define-typed-syntax hash-count - [(hash-count h) ≫ - [⊢ [[h ≫ h-] ⇒ : (~Hash _ _)]] - -------- - [⊢ [[_ ≫ (hash-count- h-)] ⇒ : Int]]]) - -(define-base-type String-Port) -(define-base-type Input-Port) -(define-primop open-output-string : (→ String-Port)) -(define-primop get-output-string : (→ String-Port String)) -(define-primop string-upcase : (→ String String)) - -(define-typed-syntax write-string - [(write-string str out) ≫ - -------- - [_ ≻ (write-string str out (ext-stlc:#%datum . 0) (string-length str))]] - [(write-string str out start end) ≫ - [⊢ [[str ≫ str-] ⇐ : String]] - [⊢ [[out ≫ out-] ⇐ : String-Port]] - [⊢ [[start ≫ start-] ⇐ : Int]] - [⊢ [[end ≫ end-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (begin- (write-string- str- out- start- end-) (void-))] ⇒ : Unit]]]) - -(define-typed-syntax string-length - [(string-length str) ≫ - [⊢ [[str ≫ str-] ⇐ : String]] - -------- - [⊢ [[_ ≫ (string-length- str-)] ⇒ : Int]]]) -(define-primop make-string : (→ Int String)) -(define-primop string-set! : (→ String Int Char Unit)) -(define-primop string-ref : (→ String Int Char)) -(define-typed-syntax string-copy! - [(string-copy! dest dest-start src) ≫ - -------- - [_ ≻ (string-copy! - dest dest-start src (ext-stlc:#%datum . 0) (string-length src))]] - [(string-copy! dest dest-start src src-start src-end) ≫ - [⊢ [[dest ≫ dest-] ⇐ : String]] - [⊢ [[src ≫ src-] ⇐ : String]] - [⊢ [[dest-start ≫ dest-start-] ⇐ : Int]] - [⊢ [[src-start ≫ src-start-] ⇐ : Int]] - [⊢ [[src-end ≫ src-end-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (string-copy!- dest- dest-start- src- src-start- src-end-)] ⇒ : Unit]]]) - -(define-primop fl+ : (→ Float Float Float)) -(define-primop fl- : (→ Float Float Float)) -(define-primop fl* : (→ Float Float Float)) -(define-primop fl/ : (→ Float Float Float)) -(define-primop flsqrt : (→ Float Float)) -(define-primop flceiling : (→ Float Float)) -(define-primop inexact->exact : (→ Float Int)) -(define-primop exact->inexact : (→ Int Float)) -(define-primop char->integer : (→ Char Int)) -(define-primop real->decimal-string : (→ Float Int String)) -(define-primop fx->fl : (→ Int Float)) -(define-typed-syntax quotient+remainder - [(quotient+remainder x y) ≫ - [⊢ [[x ≫ x-] ⇐ : Int]] - [⊢ [[y ≫ y-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (let-values- ([[a b] (quotient/remainder- x- y-)]) - (list- a b))] - ⇒ : (stlc+rec-iso:× Int Int)]]]) -(define-primop quotient : (→ Int Int Int)) - -(define-typed-syntax set! - [(set! x:id e) ≫ - [⊢ [[x ≫ x-] ⇒ : ty_x]] - [⊢ [[e ≫ e-] ⇐ : ty_x]] - -------- - [⊢ [[_ ≫ (set!- x e-)] ⇒ : Unit]]]) - -(define-typed-syntax provide-type - [(provide-type ty ...) ≫ - -------- - [_ ≻ (provide- ty ...)]]) - -(define-typed-syntax provide - [(provide x:id ...) ≫ - [⊢ [[x ≫ x-] ⇒ : ty_x] ...] - ; TODO: use hash-code to generate this tmp - [#:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...))] - -------- - [_ ≻ (begin- - (provide- x ...) - (stlc+rec-iso:define-type-alias x-ty ty_x) ... - (provide- x-ty ...))]]) -(define-typed-syntax require-typed - [(require-typed x:id ... #:from mod) ≫ - [#:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...))] - [#:with (y ...) (generate-temporaries #'(x ...))] - -------- - [_ ≻ (begin- - (require- (rename-in (only-in mod x ... x-ty ...) [x y] ...)) - (define-syntax x (make-rename-transformer (assign-type #'y #'x-ty))) ...)]]) - -(define-base-type Regexp) -(define-primop regexp-match : (→ Regexp String (List String))) -(define-primop regexp : (→ String Regexp)) - -(define-typed-syntax equal? - [(equal? e1 e2) ≫ - [⊢ [[e1 ≫ e1-] ⇒ : ty1]] - [⊢ [[e2 ≫ e2-] ⇐ : ty1]] - -------- - [⊢ [[_ ≫ (equal?- e1- e2-)] ⇒ : Bool]]]) - -(define-typed-syntax read-int - [(read-int) ≫ - -------- - [⊢ [[_ ≫ (let- ([x (read-)]) - (cond- [(exact-integer?- x) x] - [else (error- 'read-int "expected an int, given: ~v" x)]))] - ⇒ : Int]]]) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(module+ test - (begin-for-syntax - (check-true (covariant-Xs? #'Int)) - (check-true (covariant-Xs? #'(stlc+box:Ref Int))) - (check-true (covariant-Xs? #'(→ Int Int))) - (check-true (covariant-Xs? #'(∀ (X) X))) - (check-false (covariant-Xs? #'(∀ (X) (stlc+box:Ref X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ X X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ X Int)))) - (check-true (covariant-Xs? #'(∀ (X) (→ Int X)))) - (check-true (covariant-Xs? #'(∀ (X) (→ (→ X Int) X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ (→ (→ X Int) Int) X)))) - (check-false (covariant-Xs? #'(∀ (X) (→ (stlc+box:Ref X) Int)))) - (check-false (covariant-Xs? #'(∀ (X Y) (→ X Y)))) - (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) Y)))) - (check-false (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Y Int))))) - (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Int Y))))) - (check-false (covariant-Xs? #'(∀ (A B) (→ (→ Int (stlc+rec-iso:× A B)) - (→ String (stlc+rec-iso:× A B)) - (stlc+rec-iso:× A B))))) - (check-true (covariant-Xs? #'(∀ (A B) (→ (→ (stlc+rec-iso:× A B) Int) - (→ (stlc+rec-iso:× A B) String) - (stlc+rec-iso:× A B))))) - )) diff --git a/tapl/typed-lang-builder/stlc+box.rkt b/tapl/typed-lang-builder/stlc+box.rkt @@ -1,32 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+cons.rkt") - -;; Simply-Typed Lambda Calculus, plus mutable references -;; Types: -;; - types from stlc+cons.rkt -;; - Ref constructor -;; Terms: -;; - terms from stlc+cons.rkt -;; - ref deref := - -(define-type-constructor Ref) - -(define-typed-syntax ref - [(ref e) ≫ - [⊢ [[e ≫ e-] ⇒ : τ]] - -------- - [⊢ [[_ ≫ (box- e-)] ⇒ : (Ref τ)]]]) - -(define-typed-syntax deref - [(deref e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~Ref τ)]] - -------- - [⊢ [[_ ≫ (unbox- e-)] ⇒ : τ]]]) - -(define-typed-syntax := #:literals (:=) - [(:= e_ref e) ≫ - [⊢ [[e_ref ≫ e_ref-] ⇒ : (~Ref τ)]] - [⊢ [[e ≫ e-] ⇐ : τ]] - -------- - [⊢ [[_ ≫ (set-box!- e_ref- e-)] ⇒ : Unit]]]) - diff --git a/tapl/typed-lang-builder/stlc+cons.rkt b/tapl/typed-lang-builder/stlc+cons.rkt @@ -1,81 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+reco+var.rkt") - -;; Simply-Typed Lambda Calculus, plus cons -;; Types: -;; - types from stlc+reco+var.rkt -;; - List constructor -;; Terms: -;; - terms from stlc+reco+var.rkt - -;; TODO: enable HO use of list primitives - -(define-type-constructor List) - -(define-typed-syntax nil - [(nil ~! τi:type-ann) ≫ - -------- - [⊢ [[_ ≫ null-] ⇒ : (List τi.norm)]]] - ; minimal type inference - [nil:id ⇐ : (~List τ) ≫ - -------- - [⊢ [[_ ≫ null-] ⇐ : _]]]) -(define-typed-syntax cons - [(cons e1 e2) ≫ - [⊢ [[e1 ≫ e1-] ⇒ : τ1]] - [⊢ [[e2 ≫ e2-] ⇐ : (List τ1)]] - -------- - [⊢ [[_ ≫ (cons- e1- e2-)] ⇒ : (List τ1)]]]) -(define-typed-syntax isnil - [(isnil e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~List _)]] - -------- - [⊢ [[_ ≫ (null?- e-)] ⇒ : Bool]]]) -(define-typed-syntax head - [(head e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~List τ)]] - -------- - [⊢ [[_ ≫ (car- e-)] ⇒ : τ]]]) -(define-typed-syntax tail - [(tail e) ≫ - [⊢ [[e ≫ e-] ⇒ : τ-lst]] - [#:fail-unless (List? #'τ-lst) - (format "Expected a list type, got: ~a" (type->str #'τ-lst))] - -------- - [⊢ [[_ ≫ (cdr- e-)] ⇒ : τ-lst]]]) -(define-typed-syntax list - [(list) ≫ - -------- - [_ ≻ nil]] - [(list x . rst) ⇐ : (~List τ) ≫ ; has expected type - -------- - [⊢ [[_ ≫ (cons (add-expected x τ) (list . rst))] ⇐ : _]]] - [(list x . rst) ≫ ; no expected type - -------- - [_ ≻ (cons x (list . rst))]]) -(define-typed-syntax reverse - [(reverse e) ≫ - [⊢ [[e ≫ e-] ⇒ : τ-lst]] - [#:fail-unless (List? #'τ-lst) - (format "Expected a list type, got: ~a" (type->str #'τ-lst))] - -------- - [⊢ [[_ ≫ (reverse- e-)] ⇒ : τ-lst]]]) -(define-typed-syntax length - [(length e) ≫ - [⊢ [[e ≫ e-] ⇒ : τ-lst]] - [#:fail-unless (List? #'τ-lst) - (format "Expected a list type, got: ~a" (type->str #'τ-lst))] - -------- - [⊢ [[_ ≫ (length- e-)] ⇒ : Int]]]) -(define-typed-syntax list-ref - [(list-ref e n) ≫ - [⊢ [[e ≫ e-] ⇒ : (~List τ)]] - [⊢ [[n ≫ n-] ⇐ : Int]] - -------- - [⊢ [[_ ≫ (list-ref- e- n-)] ⇒ : τ]]]) -(define-typed-syntax member - [(member v e) ≫ - [⊢ [[e ≫ e-] ⇒ : (~List τ)]] - [⊢ [[v ≫ v-] ⇐ : τ]] - -------- - [⊢ [[_ ≫ (member- v- e-)] ⇒ : Bool]]]) diff --git a/tapl/typed-lang-builder/stlc+effect.rkt b/tapl/typed-lang-builder/stlc+effect.rkt @@ -1,117 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+box.rkt" #:except ref deref := #%app λ) - -;; Simply-Typed Lambda Calculus, plus mutable references -;; Types: -;; - types from stlc+cons.rkt -;; - Ref constructor -;; Terms: -;; - terms from stlc+cons.rkt -;; - ref deref := - -(define-syntax-rule (locs loc ...) - '(loc ...)) -(begin-for-syntax - (define-syntax ~locs - (pattern-expander - (syntax-parser - [(locs loc:id ...) - #:with tmp (generate-temporary 'locs) - #'(~and tmp - (~parse ((~literal quote) (loc ...)) - (stx-or #'tmp #'(quote ()))))]))) - - (define (stx-truth? a) - (and a (not (and (syntax? a) (false? (syntax-e a)))))) - (define (stx-or a b) - (cond [(stx-truth? a) a] - [else b]))) - - -(define-typed-syntax effect:#%app #:export-as #%app - [(_ efn e ...) ≫ - [⊢ [[efn ≫ e_fn-] - (⇒ : (~→ τ_in ... τ_out) - (⇒ ν (~locs tyns ...)) - (⇒ := (~locs tyas ...)) - (⇒ ! (~locs tyds ...))) - (⇒ ν (~locs fns ...)) - (⇒ := (~locs fas ...)) - (⇒ ! (~locs fds ...))]] - [#:fail-unless (stx-length=? #'[e ...] #'[τ_in ...]) - (num-args-fail-msg #'efn #'[τ_in ...] #'[e ...])] - [⊢ [[e ≫ e_arg-] - (⇐ : τ_in) - (⇒ ν (~locs ns ...)) - (⇒ := (~locs as ...)) - (⇒ ! (~locs ds ...))] - ...] - -------- - [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)] - (⇒ : τ_out) - (⇒ ν (locs fns ... tyns ... ns ... ...)) - (⇒ := (locs fas ... tyas ... as ... ...)) - (⇒ ! (locs fds ... tyds ... ds ... ...))]]]) - -(define-typed-syntax λ - [(λ bvs:type-ctx e) ≫ - [() ([bvs.x : bvs.type ≫ x-] ...) ⊢ - [[e ≫ e-] - (⇒ : τ_res) - (⇒ ν (~locs ns ...)) - (⇒ := (~locs as ...)) - (⇒ ! (~locs ds ...))]] - -------- - [⊢ [[_ ≫ (λ- (x- ...) e-)] - (⇒ : (→ bvs.type ... τ_res) - (⇒ ν (locs ns ...)) - (⇒ := (locs as ...)) - (⇒ ! (locs ds ...)))]]]) - -(define-type-constructor Ref) - -(define-typed-syntax ref - [(ref e) ≫ - [⊢ [[e ≫ e-] - (⇒ : τ) - (⇒ ν (~locs ns ...)) - (⇒ := (~locs as ...)) - (⇒ ! (~locs ds ...))]] - -------- - [⊢ [[_ ≫ (box- e-)] - (⇒ : (Ref τ)) - (⇒ ν (locs #,(syntax-position stx) ns ...)) - (⇒ := (locs as ...)) - (⇒ ! (locs ds ...))]]]) -(define-typed-syntax deref - [(deref e) ≫ - [⊢ [[e ≫ e-] - (⇒ : (~Ref ty)) - (⇒ ν (~locs ns ...)) - (⇒ := (~locs as ...)) - (⇒ ! (~locs ds ...))]] - -------- - [⊢ [[_ ≫ (unbox- e-)] - (⇒ : ty) - (⇒ ν (locs ns ...)) - (⇒ := (locs as ...)) - (⇒ ! (locs #,(syntax-position stx) ds ...))]]]) -(define-typed-syntax := #:literals (:=) - [(:= e_ref e) ≫ - [⊢ [[e_ref ≫ e_ref-] - (⇒ : (~Ref ty)) - (⇒ ν (~locs ns1 ...)) - (⇒ := (~locs as1 ...)) - (⇒ ! (~locs ds1 ...))]] - [⊢ [[e ≫ e-] - (⇐ : ty) - (⇒ ν (~locs ns2 ...)) - (⇒ := (~locs as2 ...)) - (⇒ ! (~locs ds2 ...))]] - -------- - [⊢ [[_ ≫ (set-box!- e_ref- e-)] - (⇒ : Unit) - (⇒ ν (locs ns1 ... ns2 ...)) - (⇒ := (locs #,(syntax-position stx) as1 ... as2 ...)) - (⇒ ! (locs ds1 ... ds2 ...))]]]) - diff --git a/tapl/typed-lang-builder/stlc+lit.rkt b/tapl/typed-lang-builder/stlc+lit.rkt @@ -1,40 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc.rkt") -(provide define-primop) - -;; Simply-Typed Lambda Calculus, plus numeric literals and primitives -;; Types: -;; - types from stlc.rkt -;; - Int -;; Terms: -;; - terms from stlc.rkt -;; - numeric literals -;; - prim + -;; Typechecking forms: -;; - define-primop - -(define-base-type Int) - -(define-syntax define-primop - (syntax-parser #:datum-literals (:) - [(define-primop op:id : τ:type) - #:with op/tc (generate-temporary #'op) - #'(begin- - (provide- (rename-out- [op/tc op])) - (define-primop op/tc op : τ))] - [(define-primop op/tc op : τ) - #'(begin- - ; rename transformer doesnt seem to expand at the right time - ; - op still has no type in #%app - (define-syntax op/tc - (make-variable-like-transformer (assign-type #'op #'τ))))])) - -(define-primop + : (→ Int Int Int)) - -(define-typed-syntax #%datum - [(#%datum . n:integer) ≫ - -------- - [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Int]]] - [(_ . x) ≫ - -------- - [_ #:error (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x)]]) diff --git a/tapl/typed-lang-builder/stlc+rec-iso.rkt b/tapl/typed-lang-builder/stlc+rec-iso.rkt @@ -1,51 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+tup.rkt") -(reuse ∨ var case define-type-alias define #:from "stlc+reco+var.rkt") - -;; stlc + (iso) recursive types -;; Types: -;; - types from stlc+tup.rkt -;; - also ∨ from stlc+reco+var -;; - μ -;; Terms: -;; - terms from stlc+tup.rkt -;; - also var and case from stlc+reco+var -;; - fld, unfld -;; Other: -;; - extend type=? to handle lambdas - -(define-type-constructor μ #:bvs = 1) - -(begin-for-syntax - (define stlc:type=? (current-type=?)) - ;; extend to handle μ, ie lambdas - (define (type=? τ1 τ2) -; (printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum τ1)) -; (printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum τ2)) - (syntax-parse (list τ1 τ2) - ;; alternative #4: use old type=? for everything except lambda - [(((~literal #%plain-lambda) (x:id ...) t1 ...) - ((~literal #%plain-lambda) (y:id ...) t2 ...)) - (and (stx-length=? #'(x ...) #'(y ...)) - (stx-length=? #'(t1 ...) #'(t2 ...)) - (stx-andmap - (λ (t1 t2) - ((current-type=?) (substs #'(y ...) #'(x ...) t1) t2)) - #'(t1 ...) #'(t2 ...)))] - [_ (stlc:type=? τ1 τ2)])) - (current-type=? type=?) - (current-typecheck-relation type=?)) - -(define-typed-syntax unfld - [(unfld τ:type-ann e) ≫ - [#:with (~μ* (tv) τ_body) #'τ.norm] - [⊢ [[e ≫ e-] ⇐ : τ.norm]] - -------- - [⊢ [[_ ≫ e-] ⇒ : #,(subst #'τ.norm #'tv #'τ_body)]]]) -(define-typed-syntax fld - [(fld τ:type-ann e) ≫ - [#:with (~μ* (tv) τ_body) #'τ.norm] - [#:with τ_e (subst #'τ.norm #'tv #'τ_body)] - [⊢ [[e ≫ e-] ⇐ : τ_e]] - -------- - [⊢ [[_ ≫ e-] ⇒ : τ.norm]]]) diff --git a/tapl/typed-lang-builder/stlc+reco+sub.rkt b/tapl/typed-lang-builder/stlc+reco+sub.rkt @@ -1,52 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+sub.rkt" #:except #%app #%datum) -(extends "stlc+reco+var.rkt" #:except #%datum +) -;;use type=? and eval-type from stlc+reco+var.rkt, not stlc+sub.rkt -;; but extend sub? from stlc+sub.rkt - -;; Simply-Typed Lambda Calculus, plus subtyping, plus records -;; Types: -;; - types from stlc+sub.rkt -;; Type relations: -;; - sub? extended to records -;; Terms: -;; - terms from stlc+sub.rkt -;; - records and variants from stlc+reco+var - -(define-typed-syntax #%datum - [(#%datum . n:number) ≫ - -------- - [_ ≻ (stlc+sub:#%datum . n)]] - [(#%datum . x) ≫ - -------- - [_ ≻ (stlc+reco+var:#%datum . x)]]) - -(begin-for-syntax - (define old-sub? (current-sub?)) - (define (sub? τ1 τ2) -; (printf "t1 = ~a\n" (syntax->datum τ1)) -; (printf "t2 = ~a\n" (syntax->datum τ2)) - (or - (old-sub? τ1 τ2) - (syntax-parse (list τ1 τ2) - [((~× [k : τk] ...) (~× [l : τl] ...)) - #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) - (stx-map syntax-e (syntax->list #'(k ...)))) - (stx-andmap - (syntax-parser - [(label τlabel) - #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) - ((current-sub?) #'τk_match #'τlabel)]) - #'([l τl] ...))] - [((~∨ [k : τk] ...) (~∨ [l : τl] ...)) - #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) - (stx-map syntax-e (syntax->list #'(k ...)))) - (stx-andmap - (syntax-parser - [(label τlabel) - #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) - ((current-sub?) #'τk_match #'τlabel)]) - #'([l τl] ...))] - [_ #f]))) - (current-sub? sub?) - (current-typecheck-relation (current-sub?))) diff --git a/tapl/typed-lang-builder/stlc+reco+var.rkt b/tapl/typed-lang-builder/stlc+reco+var.rkt @@ -1,175 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+tup.rkt" #:except × ×? tup proj - #:rename [~× ~stlc:×]) -(provide × ∨ (for-syntax ~× ~×* ~∨ ~∨*)) - - -;; Simply-Typed Lambda Calculus, plus records and variants -;; Types: -;; - types from stlc+tup.rkt -;; - redefine tuple type × to records -;; - sum type constructor ∨ -;; Terms: -;; - terms from stlc+tup.rkt -;; - redefine tup to records -;; - sums (var) -;; TopLevel: -;; - define (values only) -;; - define-type-alias - -(provide define-type-alias) -(define-syntax define-type-alias - (syntax-parser - [(define-type-alias alias:id τ:type) - #'(define-syntax alias (make-variable-like-transformer #'τ.norm))] - [(define-type-alias (f:id x:id ...) ty) - #'(define-syntax (f stx) - (syntax-parse stx - [(_ x ...) #'ty]))])) - -(define-typed-syntax define - [(define x:id : τ:type e:expr) ≫ - ;This wouldn't work with mutually recursive definitions - ;[⊢ [[e ≫ e-] ⇐ τ.norm]] - ;So expand to an ann form instead. - -------- - [_ ≻ (begin- - (define-syntax x (make-rename-transformer (⊢ y : τ.norm))) - (define- y (ann e : τ.norm)))]] - [(define x:id e) ≫ - [⊢ [[e ≫ e-] ⇒ : τ]] - [#:with y (generate-temporary #'x)] - -------- - [_ ≻ (begin- - (define-syntax x (make-rename-transformer (⊢ y : τ))) - (define- y e-))]]) - - -; re-define tuples as records -; dont use define-type-constructor because I want the : literal syntax -(define-syntax × - (syntax-parser #:datum-literals (:) - [(_ [label:id : τ:type] ...) - #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) - #`(stlc+tup:× valid-τ ...)])) -(begin-for-syntax - (define-syntax ~× - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~stlc:× ((~literal #%plain-app) (quote l) τ_l) ddd)] - [(_ . args) - #'(~and (~stlc:× ((~literal #%plain-app) (quote l) τ_l) (... ...)) - (~parse args #'((l τ_l) (... ...))))]))) - (define ×? stlc+tup:×?) - (define-syntax ~×* - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~or (~× [l : τ_l] ddd) - (~and any (~do (type-error - #:src #'any - #:msg "Expected × type, got: ~a" #'any))))])))) - -(begin-for-syntax - (define (stx-assoc-ref stx-lst lookup-k #:else [fail (λ () #f)]) - (define match_res (stx-assoc lookup-k stx-lst)) - (cond [match_res - (stx-cadr match_res)] - [else - (fail)])) - (define (×-ref ×-type l) - (syntax-parse ×-type - [(~× [l_τ : τ] ...) - (define res - (stx-assoc-ref #'([l_τ τ] ...) l #:else (λ () (error 'X-ref "bad!")))) - (add-orig res (get-orig res))]))) - -;; records -(define-typed-syntax tup #:datum-literals (=) - [(tup [l:id = e] ...) ≫ - [⊢ [[e ≫ e-] ⇒ : τ] ...] - -------- - [⊢ [[_ ≫ (list- (list- 'l e-) ...)] ⇒ : (× [l : τ] ...)]]]) -(define-typed-syntax proj #:literals (quote) - [(proj e_rec l:id) ≫ - [⊢ [[e_rec ≫ e_rec-] ⇒ : τ_e]] - [#:fail-unless (×? #'τ_e) - (format "Expected expression ~s to have × type, got: ~a" - (syntax->datum #'e_rec) (type->str #'τ_e))] - [#:with τ_l (×-ref #'τ_e #'l)] - -------- - [⊢ [[_ ≫ (cadr- (assoc- 'l e_rec-))] ⇒ : τ_l]]]) - -(define-type-constructor ∨/internal #:arity >= 0) - -;; variants -(define-syntax ∨ - (syntax-parser #:datum-literals (:) - [(∨ (~and [label:id : τ:type] x) ...) - #:when (> (stx-length #'(x ...)) 0) - #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) - #'(∨/internal valid-τ ...)] - [any - (type-error #:src #'any - #:msg (string-append - "Improper usage of type constructor ∨: ~a, " - "expected (∨ [label:id : τ:type] ...+)") - #'any)])) -(begin-for-syntax - (define ∨? ∨/internal?) - (define-syntax ~∨ - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~∨/internal ((~literal #%plain-app) (quote l) τ_l) ddd)] - [(_ . args) - #'(~and (~∨/internal ((~literal #%plain-app) (quote l) τ_l) (... ...)) - (~parse args #'((l τ_l) (... ...))))]))) - (define-syntax ~∨* - (pattern-expander - (syntax-parser #:datum-literals (:) - [(_ [l : τ_l] (~and ddd (~literal ...))) - #'(~and (~or (~∨ [l : τ_l] ddd) - (~and any (~do (type-error - #:src #'any - #:msg "Expected ∨ type, got: ~a" #'any)))) - ~!)])))) ; dont backtrack here - -(begin-for-syntax - (define (∨-ref ∨-type l #:else [fail (λ () #f)]) - (syntax-parse ∨-type - [(~∨ [l_τ : τ] ...) - (define res - (stx-assoc-ref #'([l_τ τ] ...) l #:else fail)) - (add-orig res (get-orig res))]))) - -(define-typed-syntax var #:datum-literals (as =) - [(var l:id = e as τ:type) ≫ - -------- - [_ ≻ (ann (var l = e) : τ.norm)]] - [(var l:id = e) ⇐ : τ ≫ - [#:fail-unless (∨? #'τ) - (format "Expected the expected type to be a ∨ type, got: ~a" (type->str #'τ))] - [#:with τ_e - (∨-ref #'τ #'l #:else - (λ () (raise-syntax-error #f - (format "~a field does not exist" (syntax->datum #'l)) - stx)))] - [⊢ [[e ≫ e-] ⇐ : τ_e]] - -------- - [⊢ [[_ ≫ (list- 'l e)] ⇐ : _]]]) - -(define-typed-syntax case - #:datum-literals (of =>) - [(case e [l:id x:id => e_l] ...) ≫ - [#:fail-unless (not (null? (syntax->list #'(l ...)))) "no clauses"] - [⊢ [[e ≫ e-] ⇒ : (~∨* [l_x : τ_x] ...)]] - [#:fail-unless (stx-length=? #'(l ...) #'(l_x ...)) "wrong number of case clauses"] - [#:fail-unless (typechecks? #'(l ...) #'(l_x ...)) "case clauses not exhaustive"] - [() ([x : τ_x ≫ x-]) ⊢ [[e_l ≫ e_l-] ⇒ : τ_el]] ... - -------- - [⊢ [[_ ≫ - (let- ([l_e (car- e-)]) - (cond- [(symbol=?- l_e 'l) (let- ([x- (cadr- e-)]) e_l-)] ...))] - ⇒ : (⊔ τ_el ...)]]]) diff --git a/tapl/typed-lang-builder/stlc+sub.rkt b/tapl/typed-lang-builder/stlc+sub.rkt @@ -1,107 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+lit.rkt" #:except #%datum +) -(reuse Bool String add1 #:from "ext-stlc.rkt") -(require (prefix-in ext: (only-in "ext-stlc.rkt" #%datum)) - (only-in "ext-stlc.rkt" current-join)) -(provide (for-syntax subs? current-sub?)) - -;; Simply-Typed Lambda Calculus, plus subtyping -;; Types: -;; - types from and stlc+lit.rkt -;; - Top, Num, Nat -;; Type relations: -;; - sub? -;; - Any <: Top -;; - Nat <: Int -;; - Int <: Num -;; - → -;; Terms: -;; - terms from stlc+lit.rkt, except redefined: datum and + -;; - also * -;; Other: sub? current-sub? - -(define-base-type Top) -(define-base-type Num) -(define-base-type Nat) - -(define-primop + : (→ Num Num Num)) -(define-primop * : (→ Num Num Num)) - -(define-typed-syntax #%datum - [(#%datum . n:nat) ≫ - -------- - [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Nat]]] - [(#%datum . n:integer) ≫ - -------- - [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Int]]] - [(#%datum . n:number) ≫ - -------- - [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Num]]] - [(#%datum . x) ≫ - -------- - [_ ≻ (ext:#%datum . x)]]) - -(begin-for-syntax - (define (sub? t1 t2) - ; need this because recursive calls made with unexpanded types - (define τ1 ((current-type-eval) t1)) - (define τ2 ((current-type-eval) t2)) -; (printf "t1 = ~a\n" (syntax->datum τ1)) -; (printf "t2 = ~a\n" (syntax->datum τ2)) - (or ((current-type=?) τ1 τ2) - (Top? τ2))) - (define current-sub? (make-parameter sub?)) - (current-typecheck-relation sub?) - (define (subs? τs1 τs2) - (and (stx-length=? τs1 τs2) - (stx-andmap (current-sub?) τs1 τs2))) - - (define-syntax (define-sub-relation stx) - (syntax-parse stx #:datum-literals (<: =>) - [(_ τ1:id <: τ2:id) - #:with τ1-expander (format-id #'τ1 "~~~a" #'τ1) - #:with τ2-expander (format-id #'τ2 "~~~a" #'τ2) - #:with fn (generate-temporary) - #:with old-sub? (generate-temporary) - #'(begin - (define old-sub? (current-sub?)) - (define (fn t1 t2) - (define τ1 ((current-type-eval) t1)) - (define τ2 ((current-type-eval) t2)) - (syntax-parse (list τ1 τ2) - [(τ1-expander τ) ((current-sub?) #'τ2 #'τ)] - [(τ τ2-expander) ((current-sub?) #'τ #'τ1)] - [_ #f])) - (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) - (current-typecheck-relation (current-sub?)))] - [(_ (~seq τ1:id <: τ2:id (~and (~literal ...) ddd)) - (~seq τ3:id <: τ4:id) - => - (tycon1 . rst1) <: (tycon2 . rst2)) - #:with tycon1-expander (format-id #'tycon1 "~~~a" #'tycon1) - #:with tycon2-expander (format-id #'tycon2 "~~~a" #'tycon2) - #:with fn (generate-temporary) - #:with old-sub? (generate-temporary) - #'(begin - (define old-sub? (current-sub?)) - (define (fn t1 t2) - (define τ1 ((current-type-eval) t1)) - (define τ2 ((current-type-eval) t2)) - (syntax-parse (list τ1 τ2) - [((tycon1-expander . rst1) (tycon2-expander . rst2)) - (and (subs? #'(τ1 ddd) #'(τ2 ddd)) - ((current-sub?) #'τ3 #'τ4))] - [_ #f])) - (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) - (current-typecheck-relation (current-sub?)))])) - - (define-sub-relation Nat <: Int) - (define-sub-relation Int <: Num) - (define-sub-relation t1 <: s1 ... s2 <: t2 => (→ s1 ... s2) <: (→ t1 ... t2)) - - (define (join t1 t2) - (cond - [((current-sub?) t1 t2) t2] - [((current-sub?) t2 t1) t1] - [else #'Top])) - (current-join join)) diff --git a/tapl/typed-lang-builder/stlc+tup.rkt b/tapl/typed-lang-builder/stlc+tup.rkt @@ -1,35 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "ext-stlc.rkt") - -(require (for-syntax racket/list)) - -;; Simply-Typed Lambda Calculus, plus tuples -;; Types: -;; - types from ext-stlc.rkt -;; - × -;; Terms: -;; - terms from ext-stlc.rkt -;; - tup and proj - -(define-type-constructor × #:arity >= 0 - #:arg-variances (λ (stx) - (make-list (stx-length (stx-cdr stx)) covariant))) - -(define-typed-syntax tup - [(tup e ...) ⇐ : (~× τ ...) ≫ - [#:when (stx-length=? #'[e ...] #'[τ ...])] - [⊢ [[e ≫ e-] ⇐ : τ] ...] - -------- - [⊢ [[_ ≫ (list- e- ...)] ⇐ : _]]] - [(tup e ...) ≫ - [⊢ [[e ≫ e-] ⇒ : τ] ...] - -------- - [⊢ [[_ ≫ (list- e- ...)] ⇒ : (× τ ...)]]]) - -(define-typed-syntax proj - [(proj e_tup n:nat) ≫ - [⊢ [[e_tup ≫ e_tup-] ⇒ : (~× τ ...)]] - [#:fail-unless (< (syntax-e #'n) (stx-length #'[τ ...])) "index too large"] - -------- - [⊢ [[_ ≫ (list-ref- e_tup- n)] ⇒ : #,(stx-list-ref #'[τ ...] (syntax-e #'n))]]]) - diff --git a/tapl/typed-lang-builder/stlc.rkt b/tapl/typed-lang-builder/stlc.rkt @@ -1,53 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(provide only-in (for-syntax current-type=? types=?)) - -(begin-for-syntax - ;; type eval - ;; - type-eval == full expansion == canonical type representation - ;; - must expand because: - ;; - checks for unbound identifiers (ie, undefined types) - ;; - checks for valid types, ow can't distinguish types and terms - ;; - could parse types but separate parser leads to duplicate code - ;; - later, expanding enables reuse of same mechanisms for kind checking - ;; and type application - (define (type-eval τ) - ; TODO: optimization: don't expand if expanded - ; currently, this causes problems when - ; combining unexpanded and expanded types to create new types - (add-orig (expand/df τ) τ)) - - (current-type-eval type-eval)) - -(define-syntax-category type) -(define-type-constructor → #:arity >= 1 - #:arg-variances (λ (stx) - (syntax-parse stx - [(_ τ_in ... τ_out) - (append - (make-list (stx-length #'[τ_in ...]) contravariant) - (list covariant))]))) - -(define-typed-syntax λ #:datum-literals (:) - [(λ ([x:id : τ_in:type] ...) e) ≫ - [() ([x : τ_in.norm ≫ x-] ...) ⊢ [[e ≫ e-] ⇒ : τ_out]] - -------- - [⊢ [[_ ≫ (λ- (x- ...) e-)] ⇒ : (→ τ_in.norm ... τ_out)]]] - [(λ (x:id ...) e) ⇐ : (~→ τ_in ... τ_out) ≫ - [() ([x : τ_in ≫ x-] ...) ⊢ [[e ≫ e-] ⇐ : τ_out]] - -------- - [⊢ [[_ ≫ (λ- (x- ...) e-)] ⇐ : _]]]) - -(define-typed-syntax #%app - [(_ e_fn e_arg ...) ≫ - [⊢ [[e_fn ≫ e_fn-] ⇒ : (~→ τ_in ... τ_out)]] - [#:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...]) - (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])] - [⊢ [[e_arg ≫ e_arg-] ⇐ : τ_in] ...] - -------- - [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)] ⇒ : τ_out]]]) - -(define-typed-syntax ann #:datum-literals (:) - [(ann e : τ:type) ≫ - [⊢ [[e ≫ e-] ⇐ : τ.norm]] - -------- - [⊢ [[_ ≫ e-] ⇒ : τ.norm]]]) diff --git a/tapl/typed-lang-builder/sysf.rkt b/tapl/typed-lang-builder/sysf.rkt @@ -1,32 +0,0 @@ -#lang macrotypes/tapl/typed-lang-builder -(extends "stlc+lit.rkt") -(reuse #:from "stlc+rec-iso.rkt") ; want this type=? - -;; System F -;; Type relation: -;; - extend type=? with ∀ -;; Types: -;; - types from stlc+lit.rkt -;; - ∀ -;; Terms: -;; - terms from stlc+lit.rkt -;; - Λ and inst - -(define-type-constructor ∀ #:bvs >= 0) - -(define-typed-syntax Λ - [(Λ (tv:id ...) e) ≫ - [([tv : #%type ≫ tv-] ...) () ⊢ [[e ≫ e-] ⇒ : τ]] - -------- - [⊢ [[_ ≫ e-] ⇒ : (∀ (tv- ...) τ)]]]) - -(define-typed-syntax inst - [(inst e τ:type ...) ≫ - [⊢ [[e ≫ e-] ⇒ : (~∀ tvs τ_body)]] - [#:with τ_inst (substs #'(τ.norm ...) #'tvs #'τ_body)] - -------- - [⊢ [[_ ≫ e-] ⇒ : τ_inst]]] - [(inst e) ≫ - -------- - [_ ≻ e]]) - diff --git a/tapl/typed-lang-builder/typed-lang-builder.rkt b/tapl/typed-lang-builder/typed-lang-builder.rkt @@ -1,297 +0,0 @@ -#lang racket/base - -(provide (except-out (all-from-out "../typecheck.rkt") -define-typed-syntax) - define-typed-syntax - (for-syntax syntax-parse/typed-syntax)) - -(require (rename-in - "../typecheck.rkt" - [define-typed-syntax -define-typed-syntax] - )) - -(module typecheck+ racket/base - (provide (all-defined-out)) - (require (for-meta -1 (except-in "../typecheck.rkt" #%module-begin))) - (define (raise-⇐-expected-type-error ⇐-stx body expected-type existing-type) - (raise-syntax-error - '⇐ - (format (string-append "body already has a type other than the expected type\n" - " body: ~s\n" - " expected-type: ~a\n" - " existing-type: ~a\n") - (syntax->datum body) - (type->str expected-type) - (type->str existing-type)) - ⇐-stx - body))) -(module syntax-classes racket/base - (provide (all-defined-out)) - (require (for-meta 0 (submod ".." typecheck+)) - (for-meta -1 (submod ".." typecheck+) (except-in "../typecheck.rkt" #%module-begin)) - (for-meta -2 (except-in "../typecheck.rkt" #%module-begin))) - (define-syntax-class --- - [pattern (~datum --------)]) - (define-syntax-class elipsis - [pattern (~literal ...)]) - (define-splicing-syntax-class props - [pattern (~and (~seq stuff ...) (~seq (~seq k:id v) ...))]) - (define-splicing-syntax-class ⇒-prop - #:datum-literals (⇒) - #:attributes (e-pat) - [pattern (~seq ⇒ tag:id tag-pat (tag-prop:⇒-prop) ...) - #:with e-tmp (generate-temporary) - #:with e-pat - #'(~and e-tmp - (~parse - (~and tag-prop.e-pat ... tag-pat) - (typeof #'e-tmp #:tag 'tag)))]) - (define-splicing-syntax-class ⇒-prop/conclusion - #:datum-literals (⇒) - #:attributes (tag tag-expr) - [pattern (~seq ⇒ tag:id tag-stx (tag-prop:⇒-prop/conclusion) ...) - #:with tag-expr - (for/fold ([tag-expr #'#`tag-stx]) - ([k (in-list (syntax->list #'[tag-prop.tag ...]))] - [v (in-list (syntax->list #'[tag-prop.tag-expr ...]))]) - (with-syntax ([tag-expr tag-expr] [k k] [v v]) - #'(assign-type tag-expr #:tag 'k v)))]) - (define-splicing-syntax-class ⇐-prop - #:datum-literals (⇐ :) - [pattern (~seq ⇐ : τ-stx) - #:with e-tmp (generate-temporary) - #:with τ-tmp (generate-temporary) - #:with τ-exp (generate-temporary) - #:with e-pat - #'(~and e-tmp - (~parse τ-exp (get-expected-type #'e-tmp)) - (~parse τ-tmp (typeof #'e-tmp)) - (~parse - (~post - (~fail #:when (and (not (typecheck? #'τ-tmp #'τ-exp)) - (get-orig #'e-tmp)) - (typecheck-fail-msg/1 #'τ-exp #'τ-tmp #'e-tmp))) - (get-orig #'e-tmp)))]) - (define-splicing-syntax-class ⇒-props - #:attributes (e-pat) - [pattern (~seq :⇒-prop)] - [pattern (~seq (p:⇒-prop) ...) - #:with e-pat #'(~and p.e-pat ...)]) - (define-splicing-syntax-class ⇐-props - #:attributes (τ-stx e-pat) - [pattern (~seq :⇐-prop)] - [pattern (~seq (p:⇐-prop) (p2:⇒-prop) ...) - #:with τ-stx #'p.τ-stx - #:with e-pat #'(~and p.e-pat p2.e-pat ...)]) - (define-splicing-syntax-class ⇒-props/conclusion - #:attributes ([tag 1] [tag-expr 1]) - [pattern (~seq p:⇒-prop/conclusion) - #:with [tag ...] #'[p.tag] - #:with [tag-expr ...] #'[p.tag-expr]] - [pattern (~seq (:⇒-prop/conclusion) ...)]) - (define-splicing-syntax-class id+props+≫ - #:datum-literals (≫) - #:attributes ([x- 1] [ctx 1]) - [pattern (~seq [x:id props:props ≫ x--:id]) - #:with [x- ...] #'[x--] - #:with [ctx ...] #'[[x props.stuff ...]]] - [pattern (~seq [x:id props:props ≫ x--:id] ooo:elipsis) - #:with [x- ...] #'[x-- ooo] - #:with [ctx ...] #'[[x props.stuff ...] ooo]]) - (define-splicing-syntax-class id-props+≫* - #:attributes ([x- 1] [ctx 1]) - [pattern (~seq ctx1:id+props+≫ ...) - #:with [x- ...] #'[ctx1.x- ... ...] - #:with [ctx ...] #'[ctx1.ctx ... ...]]) - (define-splicing-syntax-class inf - #:datum-literals (⊢ ⇒ ⇐ ≫ :) - #:attributes ([e-stx 1] [e-stx-orig 1] [e-pat 1]) - [pattern (~seq [[e-stx* ≫ e-pat*] props:⇒-props] ooo:elipsis ...) - #:with e-tmp (generate-temporary #'e-pat*) - #:with τ-tmp (generate-temporary 'τ) - #:with [e-stx ...] #'[e-stx* ooo ...] - #:with [e-stx-orig ...] #'[e-stx* ooo ...] - #:with [e-pat ...] - #'[(~post - (~seq - (~and props.e-pat - e-pat*) - ooo ...))]] - [pattern (~seq [[e-stx* ≫ e-pat*] props:⇐-props] ooo:elipsis ...) - #:with e-tmp (generate-temporary #'e-pat*) - #:with τ-tmp (generate-temporary 'τ) - #:with τ-exp-tmp (generate-temporary 'τ_expected) - #:with [e-stx ...] #'[(add-expected e-stx* props.τ-stx) ooo ...] - #:with [e-stx-orig ...] #'[e-stx* ooo ...] - #:with [e-pat ...] - #'[(~post - (~seq - (~and props.e-pat - e-pat*) - ooo ...))]] - ) - (define-splicing-syntax-class inf* - [pattern (~seq inf:inf ...) - #:with [e-stx ...] #'[inf.e-stx ... ...] - #:with [e-stx-orig ...] #'[inf.e-stx-orig ... ...] - #:with [e-pat ...] #'[inf.e-pat ... ...]]) - (define-splicing-syntax-class clause - #:attributes ([pat 1]) - #:datum-literals (⊢ ⇒ ⇐ ≫ τ⊑ :) - [pattern [⊢ (~and (~seq inf-stuff ...) (~seq inf:inf ...))] - #:with [:clause] #'[[() () ⊢ inf-stuff ...]]] - [pattern (~seq [⊢ (~and (~seq inf-stuff ...) (~seq inf:inf ...))] ooo:elipsis) - #:with [:clause] #'[[() () ⊢ inf-stuff ...] ooo]] - [pattern (~seq [(tvctx:id-props+≫*) (ctx:id-props+≫*) ⊢ inf:inf*] ooo:elipsis ...) - #:with tvctxss (cond [(stx-null? #'[tvctx.ctx ...]) #'(in-cycle (in-value '()))] - [else #'(in-list (syntax->list #'[(tvctx.ctx ...) ooo ...]))]) - #:with ctxss (cond [(stx-null? #'[ctx.ctx ...]) #'(in-cycle (in-value '()))] - [else #'(in-list (syntax->list #'[(ctx.ctx ...) ooo ...]))]) - #:with [pat ...] - #'[(~post - (~post - (~parse - [[(tvctx.x- ...) (ctx.x- ...) (inf.e-pat ...) _] ooo ...] - (for/list ([tvctxs tvctxss] - [ctxs ctxss] - [es (in-list (syntax->list #'[(inf.e-stx ...) ooo ...]))] - [origs (in-list (syntax->list #'[(inf.e-stx-orig ...) ooo ...]))]) - (infer #:tvctx tvctxs #:ctx ctxs (stx-map pass-orig es origs))))))]] - [pattern [a τ⊑ b] - #:with [pat ...] - #'[(~post - (~fail #:unless (typecheck? #'a #'b) - (typecheck-fail-msg/1/no-expr #'b #'a)))]] - [pattern [a τ⊑ b #:for e] - #:with [pat ...] - #'[(~post - (~fail #:unless (typecheck? #'a #'b) - (typecheck-fail-msg/1 #'b #'a #'e)))]] - [pattern (~seq [a τ⊑ b] ooo:elipsis) - #:with [pat ...] - #'[(~post - (~fail #:unless (typechecks? #'[a ooo] #'[b ooo]) - (typecheck-fail-msg/multi/no-exprs #'[b ooo] #'[a ooo])))]] - [pattern (~seq [a τ⊑ b #:for e] ooo:elipsis) - #:with [pat ...] - #'[(~post - (~fail #:unless (typechecks? #'[a ooo] #'[b ooo]) - (typecheck-fail-msg/multi #'[b ooo] #'[a ooo] #'[e ooo])))]] - [pattern [#:when condition:expr] - #:with [pat ...] - #'[(~fail #:unless condition)]] - [pattern [#:with pat*:expr expr:expr] - #:with [pat ...] - #'[(~post (~parse pat* expr))]] - [pattern [#:fail-unless condition:expr message:expr] - #:with [pat ...] - #'[(~post (~fail #:unless condition message))]] - ) - (define-syntax-class last-clause - #:datum-literals (⊢ ≫ ≻ ⇒ ⇐ :) - #:attributes ([pat 0] [stuff 1] [body 0]) - [pattern [⊢ [[pat ≫ e-stx] props:⇒-props/conclusion]] - #:with [stuff ...] #'[] - #:with body:expr - (for/fold ([body #'(quasisyntax/loc this-syntax e-stx)]) - ([k (in-list (syntax->list #'[props.tag ...]))] - [v (in-list (syntax->list #'[props.tag-expr ...]))]) - (with-syntax ([body body] [k k] [v v]) - #'(assign-type body #:tag 'k v)))] - [pattern [⊢ [[e-stx]]] - #:with :last-clause #'[⊢ [[_ ≫ e-stx] ⇐ : _]]] - [pattern [⊢ [[pat* ≫ e-stx] ⇐ : τ-pat]] - #:with stx (generate-temporary 'stx) - #:with τ (generate-temporary #'τ-pat) - #:with pat - #'(~and stx - pat* - (~parse τ (get-expected-type #'stx)) - (~post (~post (~fail #:unless (syntax-e #'τ) - (no-expected-type-fail-msg)))) - (~parse τ-pat #'τ)) - #:with [stuff ...] #'[] - #:with body:expr - #'(assign-type (quasisyntax/loc this-syntax e-stx) #`τ)] - [pattern [≻ e-stx] - #:with :last-clause #'[_ ≻ e-stx]] - [pattern [pat ≻ e-stx] - #:with [stuff ...] #'[] - #:with body:expr - #'(quasisyntax/loc this-syntax e-stx)] - [pattern [#:error msg:expr] - #:with :last-clause #'[_ #:error msg]] - [pattern [pat #:error msg:expr] - #:with [stuff ...] - #'[#:fail-unless #f msg] - #:with body:expr - ;; should never get here - #'(error msg)]) - (define-splicing-syntax-class pat #:datum-literals (⇐ :) - [pattern (~seq pat) - #:attr transform-body identity] - [pattern (~seq pat* left:⇐ : τ-pat) - #:with stx (generate-temporary 'stx) - #:with τ (generate-temporary #'τ-pat) - #:with b (generate-temporary 'body) - #:with pat - #'(~and stx - pat* - (~parse τ (get-expected-type #'stx)) - (~post (~post (~fail #:unless (syntax-e #'τ) - (no-expected-type-fail-msg)))) - (~parse τ-pat #'τ)) - #:attr transform-body - (lambda (body) - #`(let ([b #,body]) - (when (and (typeof b) - (not (typecheck? (typeof b) #'τ))) - (raise-⇐-expected-type-error #'left b #'τ (typeof b))) - (assign-type b #'τ)))]) - (define-syntax-class rule #:datum-literals (≫) - [pattern [pat:pat ≫ - clause:clause ... - :--- - last-clause:last-clause] - #:with body:expr ((attribute pat.transform-body) #'last-clause.body) - #:with norm - #'[(~and pat.pat - last-clause.pat - clause.pat ... ...) - last-clause.stuff ... - body]]) - (define-splicing-syntax-class stxparse-kws - [pattern (~seq (~or (~seq :keyword _) - (~seq :keyword)) - ...)]) - ) -(require (for-meta 1 'syntax-classes) - (for-meta 2 'syntax-classes)) - -(define-syntax define-typed-syntax - (lambda (stx) - (syntax-parse stx - [(def name:id - (~and (~seq kw-stuff ...) :stxparse-kws) - rule:rule - ...) - #'(-define-typed-syntax - name - kw-stuff ... - rule.norm - ...)]))) - -(begin-for-syntax - (define-syntax syntax-parse/typed-syntax - (lambda (stx) - (syntax-parse stx - [(stxparse - stx-id:id - (~and (~seq kw-stuff ...) :stxparse-kws) - rule:rule - ...) - #'(syntax-parse - stx-id - kw-stuff ... - rule.norm - ...)])))) - diff --git a/typed-lang-builder/examples/exist.rkt b/typed-lang-builder/examples/exist.rkt @@ -0,0 +1,75 @@ +#lang typed-lang-builder +(extends "stlc+reco+var.rkt") +(reuse #:from "stlc+rec-iso.rkt") ; want type=?, but only need to load current-type=? + +;; existential types +;; Types: +;; - types from stlc+reco+var.rkt +;; - ∃ +;; Terms: +;; - terms from stlc+reco+var.rkt +;; - pack and open +;; Other: type=? from stlc+rec-iso.rkt + + +(define-type-constructor ∃ #:bvs = 1) + +(define-typed-syntax pack + [(pack (τ:type e) as ∃τ:type) ≫ + [#:with (~∃* (τ_abstract) τ_body) #'∃τ.norm] + [#:with τ_e (subst #'τ.norm #'τ_abstract #'τ_body)] + [⊢ [[e ≫ e-] ⇐ : τ_e]] + -------- + [⊢ [[_ ≫ e-] ⇒ : ∃τ.norm]]]) + +(define-typed-syntax open #:datum-literals (<= with) + [(open [x:id <= e_packed with X:id] e) + ≫ + ;; The subst below appears to be a hack, but it's not really. + ;; It's the (TaPL) type rule itself that is fast and loose. + ;; Leveraging the macro system's management of binding reveals this. + ;; + ;; Specifically, here is the TaPL Unpack type rule, fig24-1, p366: + ;; Γ ⊢ e_packed : {∃X,τ_body} + ;; Γ,X,x:τ_body ⊢ e : τ_e + ;; ------------------------------ + ;; Γ ⊢ (open [x <= e_packed with X] e) : τ_e + ;; + ;; There's *two* separate binders, the ∃ and the let, + ;; which the rule conflates. + ;; + ;; Here's the rule rewritten to distinguish the two binding positions: + ;; Γ ⊢ e_packed : {∃X_1,τ_body} + ;; Γ,X_???,x:τ_body ⊢ e : τ_e + ;; ------------------------------ + ;; Γ ⊢ (open [x <= e_packed with X_2] e) : τ_e + ;; + ;; The X_1 binds references to X in T_12. + ;; The X_2 binds references to X in t_2. + ;; What should the X_??? be? + ;; + ;; A first guess might be to replace X_??? with both X_1 and X_2, + ;; so all the potentially referenced type vars are bound. + ;; Γ ⊢ e_packed : {∃X_1,τ_body} + ;; Γ,X_1,X_2,x:τ_body ⊢ e : τ_e + ;; ------------------------------ + ;; Γ ⊢ (open [x <= e_packed with X_2] e) : τ_e + ;; + ;; But this example demonstrates that the rule above doesnt work: + ;; (open [x <= (pack (Int 0) as (∃ (X_1) X_1)) with X_2] + ;; ((λ ([y : X_2]) y) x) + ;; Here, x has type X_1, y has type X_2, but they should be the same thing, + ;; so we need to replace all X_1's with X_2 + ;; + ;; Here's the fixed rule, which is implemented here + ;; + ;; Γ ⊢ e_packed : {∃X_1,τ_body} + ;; Γ,X_2:#%type,x:[X_2/X_1]τ_body ⊢ e : τ_e + ;; ------------------------------ + ;; Γ ⊢ (open [x <= e_packed with X_2] e) : τ_e + ;; + [⊢ [[e_packed ≫ e_packed-] ⇒ : (~∃ (Y) τ_body)]] + [#:with τ_x (subst #'X #'Y #'τ_body)] + [([X : #%type ≫ X-]) ([x : τ_x ≫ x-]) ⊢ [[e ≫ e-] ⇒ : τ_e]] + -------- + [⊢ [[_ ≫ (let- ([x- e_packed-]) e-)] ⇒ : τ_e]]]) diff --git a/typed-lang-builder/examples/ext-stlc.rkt b/typed-lang-builder/examples/ext-stlc.rkt @@ -0,0 +1,145 @@ +#lang typed-lang-builder +(extends "stlc+lit.rkt" #:except #%datum) +(provide ⊔ (for-syntax current-join)) + +;; Simply-Typed Lambda Calculus, plus extensions (TAPL ch11) +;; Types: +;; - types from stlc+lit.rkt +;; - Bool, String +;; - Unit +;; Terms: +;; - terms from stlc+lit.rkt +;; - literals: bool, string +;; - boolean prims, numeric prims +;; - if +;; - prim void : (→ Unit) +;; - begin +;; - ascription (ann) +;; - let, let*, letrec + +(define-base-type Bool) +(define-base-type String) +(define-base-type Float) +(define-base-type Char) + +(define-typed-syntax #%datum + [(#%datum . b:boolean) ≫ + -------- + [⊢ [[_ ≫ (#%datum- . b)] ⇒ : Bool]]] + [(#%datum . s:str) ≫ + -------- + [⊢ [[_ ≫ (#%datum- . s)] ⇒ : String]]] + [(#%datum . f) ≫ + [#:when (flonum? (syntax-e #'f))] + -------- + [⊢ [[_ ≫ (#%datum- . f)] ⇒ : Float]]] + [(#%datum . c:char) ≫ + -------- + [⊢ [[_ ≫ (#%datum- . c)] ⇒ : Char]]] + [(#%datum . x) ≫ + -------- + [_ ≻ (stlc+lit:#%datum . x)]]) + +(define-primop zero? : (→ Int Bool)) +(define-primop = : (→ Int Int Bool)) +(define-primop - : (→ Int Int Int)) +(define-primop add1 : (→ Int Int)) +(define-primop sub1 : (→ Int Int)) +(define-primop not : (→ Bool Bool)) + +(define-typed-syntax and + [(and e1 e2) ≫ + [⊢ [[e1 ≫ e1-] ⇐ : Bool]] + [⊢ [[e2 ≫ e2-] ⇐ : Bool]] + -------- + [⊢ [[_ ≫ (and- e1- e2-)] ⇒ : Bool]]]) + +(define-typed-syntax or + [(or e ...) ≫ + [⊢ [[e ≫ e-] ⇐ : Bool] ...] + -------- + [⊢ [[_ ≫ (or- e- ...)] ⇒ : Bool]]]) + +(begin-for-syntax + (define current-join + (make-parameter + (λ (x y) + (unless (typecheck? x y) + (type-error + #:src x + #:msg "branches have incompatible types: ~a and ~a" x y)) + x)))) + +(define-syntax ⊔ + (syntax-parser + [(⊔ τ1 τ2 ...) + (for/fold ([τ ((current-type-eval) #'τ1)]) + ([τ2 (in-list (stx-map (current-type-eval) #'[τ2 ...]))]) + ((current-join) τ τ2))])) + +(define-typed-syntax if + [(if e_tst e1 e2) ⇐ : τ-expected ≫ + [⊢ [[e_tst ≫ e_tst-] ⇒ : _]] ; Any non-false value is truthy. + [⊢ [[e1 ≫ e1-] ⇐ : τ-expected]] + [⊢ [[e2 ≫ e2-] ⇐ : τ-expected]] + -------- + [⊢ [[_ ≫ (if- e_tst- e1- e2-)] ⇐ : _]]] + [(if e_tst e1 e2) ≫ + [⊢ [[e_tst ≫ e_tst-] ⇒ : _]] ; Any non-false value is truthy. + [⊢ [[e1 ≫ e1-] ⇒ : τ1]] + [⊢ [[e2 ≫ e2-] ⇒ : τ2]] + -------- + [⊢ [[_ ≫ (if- e_tst- e1- e2-)] ⇒ : (⊔ τ1 τ2)]]]) + +(define-base-type Unit) +(define-primop void : (→ Unit)) + +(define-typed-syntax begin + [(begin e_unit ... e) ⇐ : τ_expected ≫ + [⊢ [[e_unit ≫ e_unit-] ⇒ : _] ...] + [⊢ [[e ≫ e-] ⇐ : τ_expected]] + -------- + [⊢ [[_ ≫ (begin- e_unit- ... e-)] ⇐ : _]]] + [(begin e_unit ... e) ≫ + [⊢ [[e_unit ≫ e_unit-] ⇒ : _] ...] + [⊢ [[e ≫ e-] ⇒ : τ_e]] + -------- + [⊢ [[_ ≫ (begin- e_unit- ... e-)] ⇒ : τ_e]]]) + +(define-typed-syntax let + [(let ([x e] ...) e_body) ⇐ : τ_expected ≫ + [⊢ [[e ≫ e-] ⇒ : τ_x] ...] + [() ([x : τ_x ≫ x-] ...) ⊢ [[e_body ≫ e_body-] ⇐ : τ_expected]] + -------- + [⊢ [[_ ≫ (let- ([x- e-] ...) e_body-)] ⇐ : _]]] + [(let ([x e] ...) e_body) ≫ + [⊢ [[e ≫ e-] ⇒ : τ_x] ...] + [() ([x : τ_x ≫ x-] ...) ⊢ [[e_body ≫ e_body-] ⇒ : τ_body]] + -------- + [⊢ [[_ ≫ (let- ([x- e-] ...) e_body-)] ⇒ : τ_body]]]) + +; dont need to manually transfer expected type +; result template automatically propagates properties +; - only need to transfer expected type when local expanding an expression +; - see let/tc +(define-typed-syntax let* + [(let* () e_body) ≫ + -------- + [_ ≻ e_body]] + [(let* ([x e] [x_rst e_rst] ...) e_body) ≫ + -------- + [_ ≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body))]]) + +(define-typed-syntax letrec + [(letrec ([b:type-bind e] ...) e_body) ⇐ : τ_expected ≫ + [() ([b.x : b.type ≫ x-] ...) + ⊢ [[e ≫ e-] ⇐ : b.type] ... [[e_body ≫ e_body-] ⇐ : τ_expected]] + -------- + [⊢ [[_ ≫ (letrec- ([x- e-] ...) e_body-)] ⇐ : _]]] + [(letrec ([b:type-bind e] ...) e_body) ≫ + [() ([b.x : b.type ≫ x-] ...) + ⊢ [[e ≫ e-] ⇐ : b.type] ... [[e_body ≫ e_body-] ⇒ : τ_body]] + -------- + [⊢ [[_ ≫ (letrec- ([x- e-] ...) e_body-)] ⇒ : τ_body]]]) + + diff --git a/typed-lang-builder/examples/fomega.rkt b/typed-lang-builder/examples/fomega.rkt @@ -0,0 +1,116 @@ +#lang typed-lang-builder +(extends "sysf.rkt" #:except #%datum ∀ Λ inst) +(reuse String #%datum #:from "stlc+reco+var.rkt") + +;; System F_omega +;; Type relation: +;; Types: +;; - types from sysf.rkt +;; - String from stlc+reco+var +;; Terms: +;; - extend ∀ Λ inst from sysf +;; - add tyλ and tyapp +;; - #%datum from stlc+reco+var + +(define-syntax-category kind) + +; want #%type to be equiv to★ +; => edit current-kind? so existing #%type annotations (with no #%kind tag) +; are treated as kinds +; <= define ★ as rename-transformer expanding to #%type +(begin-for-syntax + (current-kind? (λ (k) (or (#%type? k) (kind? k)))) + ;; Try to keep "type?" backward compatible with its uses so far, + ;; eg in the definition of λ or previous type constuctors. + ;; (However, this is not completely possible, eg define-type-alias) + ;; So now "type?" no longer validates types, rather it's a subset. + ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) + (current-type? (λ (t) + (define k (typeof t)) + #;(or (type? t) (★? (typeof t)) (∀★? (typeof t))) + (and ((current-kind?) k) (not (⇒? k)))))) + +; must override, to handle kinds +(provide define-type-alias) +(define-syntax define-type-alias + (syntax-parser + [(define-type-alias alias:id τ) + #:with (τ- k_τ) (infer+erase #'τ) + #:fail-unless ((current-kind?) #'k_τ) (format "not a valid type: ~a\n" (type->str #'τ)) + #'(define-syntax alias (syntax-parser [x:id #'τ-] [(_ . rst) #'(τ- . rst)]))])) + +(provide ★ (for-syntax ★?)) +(define-for-syntax ★? #%type?) +(define-syntax ★ (make-rename-transformer #'#%type)) +(define-kind-constructor ⇒ #:arity >= 1) +(define-kind-constructor ∀★ #:arity >= 0) + +(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) + +;; alternative: normalize before type=? +; but then also need to normalize in current-promote +(begin-for-syntax + (define (normalize τ) + (syntax-parse τ #:literals (#%plain-app #%plain-lambda) + [x:id #'x] + [(#%plain-app + (#%plain-lambda (tv ...) τ_body) τ_arg ...) + (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] + [(#%plain-lambda (x ...) . bodys) + #:with bodys_norm (stx-map normalize #'bodys) + (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] + [(#%plain-app x:id . args) + #:with args_norm (stx-map normalize #'args) + (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] + [(#%plain-app . args) + #:with args_norm (stx-map normalize #'args) + #:with res (normalize #'(#%plain-app . args_norm)) + (transfer-stx-props #'res τ #:ctx τ)] + [_ τ])) + + (define old-eval (current-type-eval)) + (define (type-eval τ) (normalize (old-eval τ))) + (current-type-eval type-eval) + + (define old-type=? (current-type=?)) + ; ty=? == syntax eq and syntax prop eq + (define (type=? t1 t2) + (let ([k1 (typeof t1)][k2 (typeof t2)]) + (and (or (and (not k1) (not k2)) + (and k1 k2 ((current-type=?) k1 k2))) + (old-type=? t1 t2)))) + (current-type=? type=?) + (current-typecheck-relation (current-type=?))) + +(define-typed-syntax Λ + [(Λ bvs:kind-ctx e) ≫ + [([bvs.x : bvs.kind ≫ tv-] ...) () ⊢ [[e ≫ e-] ⇒ : τ_e]] + -------- + [⊢ [[_ ≫ e-] ⇒ : (∀ ([tv- : bvs.kind] ...) τ_e)]]]) + +(define-typed-syntax inst + [(inst e τ ...) ≫ + [⊢ [[e ≫ e-] ⇒ : (~∀ (tv ...) τ_body) (⇒ : (~∀★ k ...))]] + [⊢ [[τ ≫ τ-] ⇐ : k] ...] + [#:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)] + -------- + [⊢ [[_ ≫ e-] ⇒ : τ-inst]]]) + +;; TODO: merge with regular λ and app? +;; - see fomega2.rkt +(define-typed-syntax tyλ + [(tyλ bvs:kind-ctx τ_body) ≫ + [() ([bvs.x : bvs.kind ≫ tv-] ...) ⊢ [[τ_body ≫ τ_body-] ⇒ : k_body]] + [#:fail-unless ((current-kind?) #'k_body) + (format "not a valid type: ~a\n" (type->str #'τ_body))] + -------- + [⊢ [[_ ≫ (λ- (tv- ...) τ_body-)] ⇒ : (⇒ bvs.kind ... k_body)]]]) + +(define-typed-syntax tyapp + [(tyapp τ_fn τ_arg ...) ≫ + [⊢ [[τ_fn ≫ τ_fn-] ⇒ : (~⇒ k_in ... k_out)]] + [#:fail-unless (stx-length=? #'[k_in ...] #'[τ_arg ...]) + (num-args-fail-msg #'τ_fn #'[k_in ...] #'[τ_arg ...])] + [⊢ [[τ_arg ≫ τ_arg-] ⇐ : k_in] ...] + -------- + [⊢ [[_ ≫ (#%app- τ_fn- τ_arg- ...)] ⇒ : k_out]]]) diff --git a/typed-lang-builder/examples/fomega2.rkt b/typed-lang-builder/examples/fomega2.rkt @@ -0,0 +1,94 @@ +#lang typed-lang-builder +(extends "sysf.rkt" #:except #%datum ∀ Λ inst);#:rename [~∀ ~sysf:∀]) +(reuse String #%datum #:from "stlc+reco+var.rkt") + +; same as fomega.rkt except here λ and #%app works as both type and terms +; - uses definition from stlc, but tweaks type? and kind? predicates +;; → is also both type and kind + +;; System F_omega +;; Type relation: +;; Types: +;; - types from sysf.rkt +;; - String from stlc+reco+var +;; Terms: +;; - extend ∀ Λ inst from sysf +;; - #%datum from stlc+reco+var + +(define-syntax-category kind) + +(begin-for-syntax + (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) + ;; Try to keep "type?" backward compatible with its uses so far, + ;; eg in the definition of λ or previous type constuctors. + ;; (However, this is not completely possible, eg define-type-alias) + ;; So now "type?" no longer validates types, rather it's a subset. + ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) + (current-type? (λ (t) (or (type? t) + (let ([k (typeof t)]) + (or (★? k) (∀★? k))) + ((current-kind?) t))))) + +; must override +(provide define-type-alias) +(define-syntax define-type-alias + (syntax-parser + [(_ alias:id τ) + #:with (τ- k_τ) (infer+erase #'τ) + #'(define-syntax alias (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))])) + +(define-base-kind ★) +(define-kind-constructor ∀★ #:arity >= 0) +(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★) + +;; alternative: normalize before type=? +; but then also need to normalize in current-promote +(begin-for-syntax + (define (normalize τ) + (syntax-parse τ #:literals (#%plain-app #%plain-lambda) + [x:id #'x] + [(#%plain-app + (#%plain-lambda (tv ...) τ_body) τ_arg ...) + (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))] + [(#%plain-lambda (x ...) . bodys) + #:with bodys_norm (stx-map normalize #'bodys) + (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)] + [(#%plain-app x:id . args) + #:with args_norm (stx-map normalize #'args) + (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)] + [(#%plain-app . args) + #:with args_norm (stx-map normalize #'args) + (transfer-stx-props (normalize #'(#%plain-app . args_norm)) τ #:ctx τ)] + [_ τ])) + + (define old-eval (current-type-eval)) + (define (type-eval τ) (normalize (old-eval τ))) + (current-type-eval type-eval) + + (define old-type=? (current-type=?)) + (define (type=? t1 t2) + (or (and (★? t1) (#%type? t2)) + (and (#%type? t1) (★? t2)) + (and (syntax-parse (list t1 t2) #:datum-literals (:) + [((~∀ ([tv1 : k1]) tbody1) + (~∀ ([tv2 : k2]) tbody2)) + ((current-type=?) #'k1 #'k2)] + [_ #t]) + (old-type=? t1 t2)))) + (current-type=? type=?) + (current-typecheck-relation (current-type=?))) + +(define-typed-syntax Λ + [(Λ bvs:kind-ctx e) ≫ + [() ([bvs.x : bvs.kind ≫ tv-] ...) ⊢ [[e ≫ e-] ⇒ : τ_e]] + -------- + [⊢ [[_ ≫ e-] ⇒ : (∀ ([tv- : bvs.kind] ...) τ_e)]]]) + +(define-typed-syntax inst + [(inst e τ ...) ≫ + [⊢ [[e ≫ e-] ⇒ : (~∀ (tv ...) τ_body) (⇒ : (~∀★ k ...))]] + [⊢ [[τ ≫ τ-] ⇐ : k] ...] + [#:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)] + -------- + [⊢ [[_ ≫ e-] ⇒ : τ-inst]]]) + diff --git a/typed-lang-builder/examples/fomega3.rkt b/typed-lang-builder/examples/fomega3.rkt @@ -0,0 +1,33 @@ +#lang typed-lang-builder +(extends "sysf.rkt" #:except #%datum ∀ Λ inst) +(reuse String #%datum #:from "stlc+reco+var.rkt") +(require (only-in "fomega.rkt" current-kind? ∀★? ★? kind?)) +(reuse ★ ∀ Λ inst define-type-alias ∀★ #:from "fomega.rkt") + +; same as fomega2.rkt --- λ and #%app works as both regular and type versions, +; → is both type and kind --- but reuses parts of fomega.rkt, +; ie removes the duplication in fomega2.rkt + +;; System F_omega +;; Type relation: +;; - redefine current-kind? and current-type so #%app and λ +;; work for both terms and types +;; Types: +;; - types from fomega.rkt +;; - String from stlc+reco+var +;; Terms: +;; - extend ∀ Λ inst from fomega.rkt +;; - #%datum from stlc+reco+var + +;; types and kinds are now mixed, due to #%app and λ +(begin-for-syntax + (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k))))) + ;; Try to keep "type?" backward compatible with its uses so far, + ;; eg in the definition of λ or previous type constuctors. + ;; (However, this is not completely possible, eg define-type-alias) + ;; So now "type?" no longer validates types, rather it's a subset. + ;; But we no longer need type? to validate types, instead we can use (kind? (typeof t)) + (current-type? (λ (t) (or (type? t) + (let ([k (typeof t)]) + (or (★? k) (∀★? k))) + ((current-kind?) t))))) diff --git a/typed-lang-builder/examples/fsub.rkt b/typed-lang-builder/examples/fsub.rkt @@ -0,0 +1,92 @@ +#lang typed-lang-builder +(extends "stlc+reco+sub.rkt" #:except +) +(require (rename-in (only-in "sysf.rkt" ∀? ∀ ~∀) [~∀ ~sysf:∀] [∀ sysf:∀])) + +;; System F<: +;; Types: +;; - types from sysf.rkt and stlc+reco+sub +;; - extend ∀ with bounds +;; Terms: +;; - terms from sysf.rkt and stlc+reco+sub +;; - extend Λ and inst +;; - redefine + with Nat +;; Other +;; - current-promote, expose +;; - extend current-sub? to call current-promote + +(define-primop + : (→ Nat Nat Nat)) + +; can't just call expose in type-eval, +; otherwise typevars will have bound as type, rather than instantiated type +; only need expose during +; 1) subtype checking +; 2) pattern matching -- including base types +(begin-for-syntax + (define (expose t) + (cond [(identifier? t) + (define sub (typeof t #:tag '<:)) + (if sub (expose sub) t)] + [else t])) + (current-promote expose) + (define stlc:sub? (current-sub?)) + (define (sub? t1 t2) + (stlc:sub? ((current-promote) t1) t2)) + (current-sub? sub?) + (current-typecheck-relation (current-sub?))) + +; quasi-kind, but must be type constructor because its arguments are types +(define-type-constructor <: #:arity >= 0) +(begin-for-syntax + (current-type? (λ (t) (or (type? t) (<:? (typeof t)))))) + +;; Type annotations used in two places: +;; 1) typechecking the body of +;; 2) instantiation of ∀ +;; Problem: need type annotations, even in expanded form +;; Solution: store type annotations in a (quasi) kind <: +(define-typed-syntax ∀ #:datum-literals (<:) + [(∀ ([tv:id <: τ:type] ...) τ_body) ≫ + -------- + ; eval first to overwrite the old #%type + [⊢ [[_ ≫ #,((current-type-eval) #'(sysf:∀ (tv ...) τ_body))] ⇒ : (<: τ.norm ...)]]]) +(begin-for-syntax + (define-syntax ~∀ + (pattern-expander + (syntax-parser #:datum-literals (<:) #:literals (...) + [(_ ([tv:id <: τ_sub] ooo:...) τ) + #'(~and ∀τ + (~parse (~sysf:∀ (tv ooo) τ) #'∀τ) + (~parse (~<: τ_sub ooo) (typeof #'∀τ)))] + [(_ . args) + #'(~and ∀τ + (~parse (~sysf:∀ (tv (... ...)) τ) #'∀τ) + (~parse (~<: τ_sub (... ...)) (typeof #'∀τ)) + (~parse args #'(([tv τ_sub] (... ...)) τ)))]))) + (define-syntax ~∀* + (pattern-expander + (syntax-parser #:datum-literals (<:) + [(_ . args) + #'(~or + (~∀ . args) + (~and any (~do + (type-error + #:src #'any + #:msg "Expected ∀ type, got: ~a" #'any))))])))) + +(define-typed-syntax Λ #:datum-literals (<:) + [(Λ ([tv:id <: τsub:type] ...) e) ≫ + ;; NOTE: store the subtyping relation of tv and τsub in the + ;; environment with a syntax property using another tag: '<: + ;; The "expose" function looks for this tag to enforce the bound, + ;; as in TaPL (fig 28-1) + [([tv : #%type <: τsub ≫ tv-] ...) () ⊢ [[e ≫ e-] ⇒ : τ_e]] + -------- + [⊢ [[_ ≫ e-] ⇒ : (∀ ([tv- <: τsub] ...) τ_e)]]]) +(define-typed-syntax inst + [(inst e τ:type ...) ≫ + [⊢ [[e ≫ e-] ⇒ : (~∀ ([tv <: τ_sub] ...) τ_body)]] + [τ.norm τ⊑ τ_sub #:for τ] ... + [#:with τ_inst (substs #'(τ.norm ...) #'(tv ...) #'τ_body)] + -------- + [⊢ [[_ ≫ e-] ⇒ : τ_inst]]]) + diff --git a/tapl/typed-lang-builder/mlish-do.rkt b/typed-lang-builder/examples/mlish-do.rkt diff --git a/typed-lang-builder/examples/mlish.rkt b/typed-lang-builder/examples/mlish.rkt @@ -0,0 +1,1430 @@ +#lang typed-lang-builder +(require racket/fixnum racket/flonum + (for-syntax macrotypes/type-constraints macrotypes/variance-constraints)) + +(extends "ext-stlc.rkt" #:except #%app λ → + - void = zero? sub1 add1 not let let* and #%datum begin + #:rename [~→ ~ext-stlc:→]) +(reuse inst #:from "sysf.rkt") +(require (only-in "ext-stlc.rkt" → →?)) +(require (only-in "sysf.rkt" ~∀ ∀ ∀? Λ)) +(reuse × tup proj define-type-alias #:from "stlc+rec-iso.rkt") +(require (only-in "stlc+rec-iso.rkt" ~× ×?)) ; using current-type=? from here +(provide (rename-out [ext-stlc:and and] [ext-stlc:#%datum #%datum])) +(reuse member length reverse list-ref cons nil isnil head tail list #:from "stlc+cons.rkt") +(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list cons nil))) +(require (only-in "stlc+cons.rkt" ~List List? List)) +(provide List) +(reuse ref deref := Ref #:from "stlc+box.rkt") +(require (rename-in (only-in "stlc+reco+var.rkt" tup proj ×) + [tup rec] [proj get] [× ××])) +(provide rec get ××) +;; for pattern matching +(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list))) +(require (prefix-in stlc+tup: (only-in "stlc+tup.rkt" tup))) + +(module+ test + (require (for-syntax rackunit))) + +(provide → →/test match2 define-type) + +;; ML-like language +;; - top level recursive functions +;; - user-definable algebraic datatypes +;; - pattern matching +;; - (local) type inference + +;; creating possibly polymorphic types +;; ?∀ only wraps a type in a forall if there's at least one type variable +(define-syntax ?∀ + (lambda (stx) + (syntax-case stx () + [(?∀ () body) + #'body] + [(?∀ (X ...) body) + #'(∀ (X ...) body)]))) + +;; ?Λ only wraps an expression in a Λ if there's at least one type variable +(define-syntax ?Λ + (lambda (stx) + (syntax-case stx () + [(?Λ () body) + #'body] + [(?Λ (X ...) body) + #'(Λ (X ...) body)]))) + +(begin-for-syntax + ;; matching possibly polymorphic types + (define-syntax ~?∀ + (pattern-expander + (lambda (stx) + (syntax-case stx () + [(?∀ vars-pat body-pat) + #'(~or (~∀ vars-pat body-pat) + (~and (~not (~∀ _ _)) + (~parse vars-pat #'()) + body-pat))])))) + + ;; find-free-Xs : (Stx-Listof Id) Type -> (Listof Id) + ;; finds the free Xs in the type + (define (find-free-Xs Xs ty) + (for/list ([X (in-list (stx->list Xs))] + #:when (stx-contains-id? ty X)) + X)) + + ;; solve for Xs by unifying quantified fn type with the concrete types of stx's args + ;; stx = the application stx = (#%app e_fn e_arg ...) + ;; tyXs = input and output types from fn type + ;; ie (typeof e_fn) = (-> . tyXs) + ;; It infers the types of arguments from left-to-right, + ;; and it expands and returns all of the arguments. + ;; It returns list of 3 values if successful, else throws a type error + ;; - a list of all the arguments, expanded + ;; - a list of all the type variables + ;; - the constraints for substituting the types + (define (solve Xs tyXs stx) + (syntax-parse tyXs + [(τ_inX ... τ_outX) + ;; generate initial constraints with expected type and τ_outX + #:with (~?∀ Vs expected-ty) (and (get-expected-type stx) + ((current-type-eval) (get-expected-type stx))) + (define initial-cs + (if (and (syntax-e #'expected-ty) (stx-null? #'Vs)) + (add-constraints Xs '() (list (list #'expected-ty #'τ_outX))) + #'())) + (syntax-parse stx + [(_ e_fn . args) + (define-values (as- cs) + (for/fold ([as- null] [cs initial-cs]) + ([a (in-list (syntax->list #'args))] + [tyXin (in-list (syntax->list #'(τ_inX ...)))]) + (define ty_in (inst-type/cs Xs cs tyXin)) + (define/with-syntax [a- ty_a] + (infer+erase (if (empty? (find-free-Xs Xs ty_in)) + (add-expected-ty a ty_in) + a))) + (values + (cons #'a- as-) + (add-constraints Xs cs (list (list ty_in #'ty_a)) + (list (list (inst-type/cs/orig + Xs cs ty_in + (λ (id1 id2) + (equal? (syntax->datum id1) + (syntax->datum id2)))) + #'ty_a)))))) + + (list (reverse as-) Xs cs)])])) + + (define (mk-app-poly-infer-error stx expected-tys given-tys e_fn) + (format (string-append + "Could not infer instantiation of polymorphic function ~s.\n" + " expected: ~a\n" + " given: ~a") + (syntax->datum (get-orig e_fn)) + (string-join (stx-map type->str expected-tys) ", ") + (string-join (stx-map type->str given-tys) ", "))) + + ;; covariant-Xs? : Type -> Bool + ;; Takes a possibly polymorphic type, and returns true if all of the + ;; type variables are in covariant positions within the type, false + ;; otherwise. + (define (covariant-Xs? ty) + (syntax-parse ((current-type-eval) ty) + [(~?∀ Xs ty) + (for/and ([X (in-list (syntax->list #'Xs))]) + (covariant-X? X #'ty))])) + + ;; find-X-variance : Id Type [Variance] -> Variance + ;; Returns the variance of X within the type ty + (define (find-X-variance X ty [ctxt-variance covariant]) + (match (find-variances (list X) ty ctxt-variance) + [(list variance) variance])) + + ;; covariant-X? : Id Type -> Bool + ;; Returns true if every place X appears in ty is a covariant position, false otherwise. + (define (covariant-X? X ty) + (variance-covariant? (find-X-variance X ty covariant))) + + ;; contravariant-X? : Id Type -> Bool + ;; Returns true if every place X appears in ty is a contravariant position, false otherwise. + (define (contravariant-X? X ty) + (variance-contravariant? (find-X-variance X ty covariant))) + + ;; find-variances : (Listof Id) Type [Variance] -> (Listof Variance) + ;; Returns the variances of each of the Xs within the type ty, + ;; where it's already within a context represented by ctxt-variance. + (define (find-variances Xs ty [ctxt-variance covariant]) + (syntax-parse ty + [A:id + (for/list ([X (in-list Xs)]) + (cond [(free-identifier=? X #'A) ctxt-variance] + [else irrelevant]))] + [(~Any tycons) + (make-list (length Xs) irrelevant)] + [(~?∀ () (~Any tycons τ ...)) + #:when (get-arg-variances #'tycons) + #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) + (define τ-ctxt-variances + (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) + (variance-compose ctxt-variance arg-variance))) + (for/fold ([acc (make-list (length Xs) irrelevant)]) + ([τ (in-list (syntax->list #'[τ ...]))] + [τ-ctxt-variance (in-list τ-ctxt-variances)]) + (map variance-join + acc + (find-variances Xs τ τ-ctxt-variance)))] + [ty + #:when (not (for/or ([X (in-list Xs)]) + (stx-contains-id? #'ty X))) + (make-list (length Xs) irrelevant)] + [_ (make-list (length Xs) invariant)])) + + ;; find-variances/exprs : (Listof Id) Type [Variance-Expr] -> (Listof Variance-Expr) + ;; Like find-variances, but works with Variance-Exprs instead of + ;; concrete variance values. + (define (find-variances/exprs Xs ty [ctxt-variance covariant]) + (syntax-parse ty + [A:id + (for/list ([X (in-list Xs)]) + (cond [(free-identifier=? X #'A) ctxt-variance] + [else irrelevant]))] + [(~Any tycons) + (make-list (length Xs) irrelevant)] + [(~?∀ () (~Any tycons τ ...)) + #:when (get-arg-variances #'tycons) + #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons)) + (define τ-ctxt-variances + (for/list ([arg-variance (in-list (get-arg-variances #'tycons))]) + (variance-compose/expr ctxt-variance arg-variance))) + (for/fold ([acc (make-list (length Xs) irrelevant)]) + ([τ (in-list (syntax->list #'[τ ...]))] + [τ-ctxt-variance (in-list τ-ctxt-variances)]) + (map variance-join/expr + acc + (find-variances/exprs Xs τ τ-ctxt-variance)))] + [ty + #:when (not (for/or ([X (in-list Xs)]) + (stx-contains-id? #'ty X))) + (make-list (length Xs) irrelevant)] + [_ (make-list (length Xs) invariant)])) + + ;; current-variance-constraints : (U False (Mutable-Setof Variance-Constraint)) + ;; If this is false, that means that infer-variances should return concrete Variance values. + ;; If it's a mutable set, that means that infer-variances should mutate it and return false, + ;; and type constructors should return the list of variance vars. + (define current-variance-constraints (make-parameter #false)) + + ;; infer-variances : + ;; ((-> Stx) -> Stx) (Listof Variance-Var) (Listof Id) (Listof Type-Stx) + ;; -> (U False (Listof Variance)) + (define (infer-variances with-variance-vars-okay variance-vars Xs τs) + (cond + [(current-variance-constraints) + (define variance-constraints (current-variance-constraints)) + (define variance-exprs + (for/fold ([exprs (make-list (length variance-vars) irrelevant)]) + ([τ (in-list τs)]) + (define/syntax-parse (~?∀ Xs* τ*) + ;; This can mutate variance-constraints! + ;; This avoids causing an infinite loop by having the type + ;; constructors provide with-variance-vars-okay so that within + ;; this call they declare variance-vars for their variances. + (with-variance-vars-okay + (λ () ((current-type-eval) #`(∀ #,Xs #,τ))))) + (map variance-join/expr + exprs + (find-variances/exprs (syntax->list #'Xs*) #'τ* covariant)))) + (for ([var (in-list variance-vars)] + [expr (in-list variance-exprs)]) + (set-add! variance-constraints (variance= var expr))) + #f] + [else + (define variance-constraints (mutable-set)) + ;; This will mutate variance-constraints! + (parameterize ([current-variance-constraints variance-constraints]) + (infer-variances with-variance-vars-okay variance-vars Xs τs)) + (define mapping + (solve-variance-constraints variance-vars + (set->list variance-constraints) + (variance-mapping))) + (for/list ([var (in-list variance-vars)]) + (variance-mapping-ref mapping var))])) + + ;; make-arg-variances-proc : + ;; (Listof Variance-Var) (Listof Id) (Listof Type-Stx) -> (Stx -> (U (Listof Variance) + ;; (Listof Variance-Var))) + (define (make-arg-variances-proc arg-variance-vars Xs τs) + ;; variance-vars-okay? : (Parameterof Boolean) + ;; A parameter that determines whether or not it's okay for + ;; this type constructor to return a list of Variance-Vars + ;; for the variances. + (define variance-vars-okay? (make-parameter #false)) + ;; with-variance-vars-okay : (-> A) -> A + (define (with-variance-vars-okay f) + (parameterize ([variance-vars-okay? #true]) + (f))) + ;; arg-variances : (Boxof (U False (List Variance ...))) + ;; If false, means that the arg variances have not been + ;; computed yet. Otherwise, stores the complete computed + ;; variances for the arguments to this type constructor. + (define arg-variances (box #f)) + ;; arg-variances-proc : Stx -> (U (Listof Variance) (Listof Variance-Var)) + (define (arg-variance-proc stx) + (or (unbox arg-variances) + (cond + [(variance-vars-okay?) + arg-variance-vars] + [else + (define inferred-variances + (infer-variances + with-variance-vars-okay + arg-variance-vars + Xs + τs)) + (cond [inferred-variances + (set-box! arg-variances inferred-variances) + inferred-variances] + [else + arg-variance-vars])]))) + arg-variance-proc) + + ;; compute unbound tyvars in one unexpanded type ty + (define (compute-tyvar1 ty) + (syntax-parse ty + [X:id #'(X)] + [() #'()] + [(C t ...) (stx-appendmap compute-tyvar1 #'(t ...))])) + ;; computes unbound ids in (unexpanded) tys, to be used as tyvars + (define (compute-tyvars tys) + (define Xs (stx-appendmap compute-tyvar1 tys)) + (filter + (lambda (X) + (with-handlers + ([exn:fail:syntax:unbound? (lambda (e) #t)] + [exn:fail:type:infer? (lambda (e) #t)]) + (let ([X+ ((current-type-eval) X)]) + (not (or (tyvar? X+) (type? X+)))))) + (stx-remove-dups Xs)))) + +;; define -------------------------------------------------- +;; for function defs, define infers type variables +;; - since the order of the inferred type variables depends on expansion order, +;; which is not known to programmers, to make the result slightly more +;; intuitive, we arbitrarily sort the inferred tyvars lexicographically +(define-typed-syntax define + [(define x:id e) ≫ + [⊢ [[e ≫ e-] ⇒ : τ]] + [#:with y (generate-temporary)] + -------- + [_ ≻ (begin- + (define-syntax x (make-rename-transformer (⊢ y : τ))) + (define- y e-))]] + ; explicit "forall" + [(define Ys (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) + e_body ... e) ≫ + [#:when (brace? #'Ys)] + ;; TODO; remove this code duplication + [#:with g (add-orig (generate-temporary #'f) #'f)] + [#:with e_ann #'(add-expected e τ_out)] + [#:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out))] + ;; TODO: check that specified return type is correct + ;; - currently cannot do it here; to do the check here, need all types of + ;; top-lvl fns, since they can call each other + [#:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) + ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...)))] + -------- + [_ ≻ (begin- + (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) + (define- g + (Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]] + ;; alternate type sig syntax, after parameter names + [(define (f:id x:id ...) (~datum :) ty ... (~or (~datum ->) (~datum →)) ty_out . b) ≫ + -------- + [_ ≻ (define (f [x : ty] ... -> ty_out) . b)]] + [(define (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) + e_body ... e) ≫ + [#:with Ys (compute-tyvars #'(τ ... τ_out))] + [#:with g (add-orig (generate-temporary #'f) #'f)] + [#:with e_ann (syntax/loc #'e (ann e : τ_out))] ; must be macro bc t_out may have unbound tvs + [#:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out))] + ;; TODO: check that specified return type is correct + ;; - currently cannot do it here; to do the check here, need all types of + ;; top-lvl fns, since they can call each other + [#:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) + (set-stx-prop/preserved + ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...))) + 'orig + (list #'(→ τ+orig ...)))] + -------- + [_ ≻ (begin- + (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected))) + (define- g + (?Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]]) + +;; define-type ----------------------------------------------- +;; TODO: should validate τ as part of define-type definition (before it's used) +;; - not completely possible, since some constructors may not be defined yet, +;; ie, mutually recursive datatypes +;; for now, validate types but punt if encountering unbound ids +(define-syntax (define-type stx) + (syntax-parse stx + [(define-type Name:id . rst) + #:with NewName (generate-temporary #'Name) + #:with Name2 (add-orig #'(NewName) #'Name) + #`(begin- + (define-type Name2 . #,(subst #'Name2 #'Name #'rst)) + (stlc+rec-iso:define-type-alias Name Name2))] + [(define-type (Name:id X:id ...) + ;; constructors must have the form (Cons τ ...) + ;; but the first ~or clause accepts 0-arg constructors as ids; + ;; the ~and is a workaround to bind the duplicate Cons ids (see Ryan's email) + (~and (~or (~and IdCons:id + (~parse (Cons [fld (~datum :) τ] ...) #'(IdCons))) + (Cons [fld (~datum :) τ] ...) + (~and (Cons τ ...) + (~parse (fld ...) (generate-temporaries #'(τ ...)))))) ...) + ;; validate tys + #:with (ty_flat ...) (stx-flatten #'((τ ...) ...)) + #:with (_ _ (_ _ (_ _ (_ _ ty+ ...)))) + (with-handlers + ([exn:fail:syntax:unbound? + (λ (e) + (define X (stx-car (exn:fail:syntax-exprs e))) + #`(lambda () (let-syntax () (let-syntax () (#%app void unbound)))))]) + (expand/df + #`(lambda (X ...) + (let-syntax + ([Name + (syntax-parser + [(_ X ...) (mk-type #'void)] + [stx + (type-error + #:src #'stx + #:msg + (format "Improper use of constructor ~a; expected ~a args, got ~a" + (syntax->datum #'Name) (stx-length #'(X ...)) + (stx-length (stx-cdr #'stx))))])] + [X (make-rename-transformer (⊢ X #%type))] ...) + (void ty_flat ...))))) + #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...))) + (stx-map + (lambda (t+ t) (unless (type? t+) + (type-error #:src t + #:msg "~a is not a valid type" t))) + #'(ty+ ...) #'(ty_flat ...))) + #:with NameExpander (format-id #'Name "~~~a" #'Name) + #:with NameExtraInfo (format-id #'Name "~a-extra-info" #'Name) + #:with (StructName ...) (generate-temporaries #'(Cons ...)) + #:with ((e_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) + #:with ((e_arg- ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) + #:with ((τ_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...)) + #:with ((exposed-acc ...) ...) + (stx-map + (λ (C fs) (stx-map (λ (f) (format-id C "~a-~a" C f)) fs)) + #'(Cons ...) #'((fld ...) ...)) + #:with ((acc ...) ...) (stx-map (λ (S fs) (stx-map (λ (f) (format-id S "~a-~a" S f)) fs)) + #'(StructName ...) #'((fld ...) ...)) + #:with (Cons? ...) (stx-map mk-? #'(StructName ...)) + #:with (exposed-Cons? ...) (stx-map mk-? #'(Cons ...)) + #`(begin- + (define-syntax (NameExtraInfo stx) + (syntax-parse stx + [(_ X ...) #'(('Cons 'StructName Cons? [acc τ] ...) ...)])) + (begin-for-syntax + ;; arg-variance-vars : (List Variance-Var ...) + (define arg-variance-vars + (list (variance-var (syntax-e (generate-temporary 'X))) ...))) + (define-type-constructor Name + #:arity = #,(stx-length #'(X ...)) + #:arg-variances (make-arg-variances-proc arg-variance-vars + (list #'X ...) + (list #'τ ... ...)) + #:extra-info 'NameExtraInfo + #:no-provide) + (struct- StructName (fld ...) #:reflection-name 'Cons #:transparent) ... + (define-syntax (exposed-acc stx) ; accessor for records + (syntax-parse stx + [_:id + (⊢ acc (?∀ (X ...) (ext-stlc:→ (Name X ...) τ)))] + [(o . rst) ; handle if used in fn position + #:with app (datum->syntax #'o '#%app) + #`(app + #,(assign-type #'acc #'(?∀ (X ...) (ext-stlc:→ (Name X ...) τ))) + . rst)])) ... ... + (define-syntax (exposed-Cons? stx) ; predicates for each variant + (syntax-parse stx + [_:id (⊢ Cons? (?∀ (X ...) (ext-stlc:→ (Name X ...) Bool)))] + [(o . rst) ; handle if used in fn position + #:with app (datum->syntax #'o '#%app) + #`(app + #,(assign-type #'Cons? #'(?∀ (X ...) (ext-stlc:→ (Name X ...) Bool))) + . rst)])) ... + (define-syntax (Cons stx) + (syntax-parse/typed-syntax stx + ; no args and not polymorphic + [C:id ≫ + [#:when (and (stx-null? #'(X ...)) (stx-null? #'(τ ...)))] + -------- + [_ ≻ (C)]] + ; no args but polymorphic, check expected type + [C:id ⇐ : (NameExpander τ-expected-arg (... ...)) ≫ + [#:when (stx-null? #'(τ ...))] + -------- + [⊢ [[_ ≫ (StructName)] ⇐ : _]]] + ; id with multiple expected args, HO fn + [C:id ≫ + [#:when (not (stx-null? #'(τ ...)))] + -------- + [⊢ [[_ ≫ StructName] ⇒ : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...)))]]] + [(C τs e_arg ...) ≫ + [#:when (brace? #'τs)] ; commit to this clause + [#:with [X* (... ...)] #'[X ...]] + [#:with [e_arg* (... ...)] #'[e_arg ...]] + [#:with {~! τ_X:type (... ...)} #'τs] + [#:with (τ_in:type (... ...)) ; instantiated types + (inst-types/cs #'(X ...) #'([X* τ_X.norm] (... ...)) #'(τ ...))] + [⊢ [[e_arg* ≫ e_arg*-] ⇐ : τ_in.norm] (... ...)] + [#:with [e_arg- ...] #'[e_arg*- (... ...)]] + -------- + [⊢ [[_ ≫ (StructName e_arg- ...)] ⇒ : (Name τ_X.norm (... ...))]]] + [(C . args) ≫ ; no type annotations, must infer instantiation + [#:with StructName/ty + (set-stx-prop/preserved + (⊢ StructName : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...)))) + 'orig + (list #'C))] + -------- + [_ ≻ (mlish:#%app StructName/ty . args)]])) + ...)])) + +;; match -------------------------------------------------- +(begin-for-syntax + (define (get-ctx pat ty) + (unify-pat+ty (list pat ty))) + (define (unify-pat+ty pat+ty) + (syntax-parse pat+ty + [(pat ty) #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) + (syntax-parse #'pat + [{(~datum _)} #'()] + [{(~literal stlc+cons:nil)} #'()] + [{A:id} ; disambiguate 0-arity constructors (that don't need parens) + #:when (get-extra-info #'ty) + #'()] + ;; comma tup syntax always has parens + [{(~and ps (p1 (unq p) ...))} + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + (unify-pat+ty #'(ps ty))] + [{p ...} + (unify-pat+ty #'((p ...) ty))])] ; pair + [((~datum _) ty) #'()] + [((~or (~literal stlc+cons:nil)) ty) #'()] + [(A:id ty) ; disambiguate 0-arity constructors (that don't need parens) + #:with (_ (_ (_ C) . _) ...) (get-extra-info #'ty) + #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) + #'()] + [(x:id ty) #'((x ty))] + [((p1 (unq p) ...) ty) ; comma tup stx + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + #:with (~× t ...) #'ty + #:with (pp ...) #'(p1 p ...) + (unifys #'([pp t] ...))] + [(((~literal stlc+tup:tup) p ...) ty) ; tup + #:with (~× t ...) #'ty + (unifys #'([p t] ...))] + [(((~literal stlc+cons:list) p ...) ty) ; known length list + #:with (~List t) #'ty + (unifys #'([p t] ...))] + [(((~seq p (~datum ::)) ... rst) ty) ; nicer cons stx + #:with (~List t) #'ty + (unifys #'([p t] ... [rst ty]))] + [(((~literal stlc+cons:cons) p ps) ty) ; arb length list + #:with (~List t) #'ty + (unifys #'([p t] [ps ty]))] + [((Name p ...) ty) + #:with (_ (_ Cons) _ _ [_ _ τ] ...) + (stx-findf + (syntax-parser + [(_ 'C . rst) + (equal? (syntax->datum #'Name) (syntax->datum #'C))]) + (stx-cdr (get-extra-info #'ty))) + (unifys #'([p τ] ...))] + [p+t #:fail-when #t (format "could not unify ~a" (syntax->datum #'p+t)) + #'()])) + (define (unifys p+tys) (stx-appendmap unify-pat+ty p+tys)) + + (define (compile-pat p ty) + (syntax-parse p + [pat #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens) + (syntax-parse #'pat + [{(~datum _)} #'_] + [{(~literal stlc+cons:nil)} (syntax/loc p (list))] + [{A:id} ; disambiguate 0-arity constructors (that don't need parens) + #:when (get-extra-info ty) + (compile-pat #'(A) ty)] + ;; comma tup stx always has parens + [{(~and ps (p1 (unq p) ...))} + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + (compile-pat #'ps ty)] + [{pat ...} (compile-pat (syntax/loc p (pat ...)) ty)])] + [(~datum _) #'_] + [(~literal stlc+cons:nil) ; nil + #'(list)] + [A:id ; disambiguate 0-arity constructors (that don't need parens) + #:with (_ (_ (_ C) . _) ...) (get-extra-info ty) + #:when (member (syntax->datum #'A) (syntax->datum #'(C ...))) + (compile-pat #'(A) ty)] + [x:id p] + [(p1 (unq p) ...) ; comma tup stx + #:when (not (stx-null? #'(p ...))) + #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...))) + #:with (~× t ...) ty + #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'(p1 p ...) #'(t ...)) + #'(list p- ...)] + [((~literal stlc+tup:tup) . pats) + #:with (~× . tys) ty + #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'pats #'tys) + (syntax/loc p (list p- ...))] + [((~literal stlc+cons:list) . ps) + #:with (~List t) ty + #:with (p- ...) (stx-map (lambda (p) (compile-pat p #'t)) #'ps) + (syntax/loc p (list p- ...))] + [((~seq pat (~datum ::)) ... last) ; nicer cons stx + #:with (~List t) ty + #:with (p- ...) (stx-map (lambda (pp) (compile-pat pp #'t)) #'(pat ...)) + #:with last- (compile-pat #'last ty) + (syntax/loc p (list-rest p- ... last-))] + [((~literal stlc+cons:cons) p ps) + #:with (~List t) ty + #:with p- (compile-pat #'p #'t) + #:with ps- (compile-pat #'ps ty) + #'(cons p- ps-)] + [(Name . pats) + #:with (_ (_ Cons) (_ StructName) _ [_ _ τ] ...) + (stx-findf + (syntax-parser + [(_ 'C . rst) + (equal? (syntax->datum #'Name) (syntax->datum #'C))]) + (stx-cdr (get-extra-info ty))) + #:with (p- ...) (stx-map compile-pat #'pats #'(τ ...)) + (syntax/loc p (StructName p- ...))])) + + ;; pats = compiled pats = racket pats + (define (check-exhaust pats ty) + (define (else-pat? p) + (syntax-parse p [(~literal _) #t] [_ #f])) + (define (nil-pat? p) + (syntax-parse p + [((~literal list)) #t] + [_ #f])) + (define (non-nil-pat? p) + (syntax-parse p + [((~literal list-rest) . rst) #t] + [((~literal cons) . rst) #t] + [_ #f])) + (define (tup-pat? p) + (syntax-parse p + [((~literal list) . _) #t] [_ #f])) + (cond + [(or (stx-ormap else-pat? pats) (stx-ormap identifier? pats)) #t] + [(List? ty) ; lists + (unless (stx-ormap nil-pat? pats) + (error 'match2 (let ([last (car (stx-rev pats))]) + (format "(~a:~a) missing nil clause for list expression" + (syntax-line last) (syntax-column last))))) + (unless (stx-ormap non-nil-pat? pats) + (error 'match2 (let ([last (car (stx-rev pats))]) + (format "(~a:~a) missing clause for non-empty, arbitrary length list" + (syntax-line last) (syntax-column last))))) + #t] + [(×? ty) ; tuples + (unless (stx-ormap tup-pat? pats) + (error 'match2 (let ([last (car (stx-rev pats))]) + (format "(~a:~a) missing pattern for tuple expression" + (syntax-line last) (syntax-column last))))) + (syntax-parse pats + [((_ p ...) ...) + (syntax-parse ty + [(~× t ...) + (apply stx-andmap + (lambda (t . ps) (check-exhaust ps t)) + #'(t ...) + (syntax->list #'((p ...) ...)))])])] + [else ; algebraic datatypes + (syntax-parse (get-extra-info ty) + [(_ (_ (_ C) (_ Cstruct) . rst) ...) + (syntax-parse pats + [((Cpat _ ...) ...) + (define Cs (syntax->datum #'(C ...))) + (define Cstructs (syntax->datum #'(Cstruct ...))) + (define Cpats (syntax->datum #'(Cpat ...))) + (unless (set=? Cstructs Cpats) + (error 'match2 + (let ([last (car (stx-rev pats))]) + (format "(~a:~a) clauses not exhaustive; missing: ~a" + (syntax-line last) (syntax-column last) + (string-join + (for/list ([C Cs][Cstr Cstructs] #:unless (member Cstr Cpats)) + (symbol->string C)) + ", "))))) + #t])] + [_ #t])])) + + ;; TODO: do get-ctx and compile-pat in one pass + (define (compile-pats pats ty) + (stx-map (lambda (p) (list (get-ctx p ty) (compile-pat p ty))) pats)) + ) + +(define-typed-syntax match2 #:datum-literals (with ->) + [(match2 e with . clauses) ≫ + [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] + [⊢ [[e ≫ e-] ⇒ : τ_e]] + [#:with ([(~seq p ...) -> e_body] ...) #'clauses] + [#:with (pat ...) (stx-map ; use brace to indicate root pattern + (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc stx {pp ...})])) + #'((p ...) ...)) ] + [#:with ([(~and ctx ([x ty] ...)) pat-] ...) (compile-pats #'(pat ...) #'τ_e)] + [#:with ty-expected (get-expected-type stx)] + [() ([x : ty ≫ x-] ...) + ⊢ [[(add-expected e_body ty-expected) ≫ e_body-] ⇒ : ty_body]] + ... + [#:when (check-exhaust #'(pat- ...) #'τ_e)] + -------- + [⊢ [[_ ≫ (match- e- [pat- (let- ([x- x] ...) e_body-)] ...)] + ⇒ : (⊔ ty_body ...)]]]) + +(define-typed-syntax match #:datum-literals (with -> ::) + ;; e is a tuple + [(match e with . clauses) ≫ + [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] + [⊢ [[e ≫ e-] ⇒ : τ_e]] + [#:when (×? #'τ_e)] + [#:with t_expect (get-expected-type stx)] ; propagate inferred type + [#:with ([x ... -> e_body]) #'clauses] + [#:with (~× ty ...) #'τ_e] + [#:fail-unless (stx-length=? #'(ty ...) #'(x ...)) + "match clause pattern not compatible with given tuple"] + [() ([x : ty ≫ x-] ...) + ⊢ [[(add-expected e_body t_expect) ≫ e_body-] ⇒ : ty_body]] + [#:with (acc ...) (for/list ([(a i) (in-indexed (syntax->list #'(x ...)))]) + #`(lambda (s) (list-ref s #,(datum->syntax #'here i))))] + [#:with z (generate-temporary)] + -------- + [⊢ [[_ ≫ (let- ([z e-]) + (let- ([x- (acc z)] ...) e_body-))] + ⇒ : ty_body]]] + ;; e is a list + [(match e with . clauses) ≫ + [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] + [⊢ [[e ≫ e-] ⇒ : τ_e]] + [#:when (List? #'τ_e)] + [#:with t_expect (get-expected-type stx)] ; propagate inferred type + [#:with ([(~or (~and (~and xs [x ...]) (~parse rst (generate-temporary))) + (~and (~seq (~seq x ::) ... rst:id) (~parse xs #'()))) + -> e_body] ...+) + #'clauses] + [#:fail-unless (stx-ormap + (lambda (xx) (and (brack? xx) (zero? (stx-length xx)))) + #'(xs ...)) + "match: missing empty list case"] + [#:fail-unless (not (and (stx-andmap brack? #'(xs ...)) + (= 1 (stx-length #'(xs ...))))) + "match: missing non-empty list case"] + [#:with (~List ty) #'τ_e] + [() ([x : ty ≫ x-] ... [rst : (List ty) ≫ rst-]) + ⊢ [[(add-expected e_body t_expect) ≫ e_body-] ⇒ : ty_body]] + ... + [#:with (len ...) (stx-map (lambda (p) #`#,(stx-length p)) #'((x ...) ...))] + [#:with (lenop ...) (stx-map (lambda (p) (if (brack? p) #'=- #'>=-)) #'(xs ...))] + [#:with (pred? ...) (stx-map + (lambda (l lo) #`(λ- (lst) (#,lo (length lst) #,l))) + #'(len ...) #'(lenop ...))] + [#:with ((acc1 ...) ...) (stx-map + (lambda (xs) + (for/list ([(x i) (in-indexed (syntax->list xs))]) + #`(lambda- (lst) (list-ref- lst #,(datum->syntax #'here i))))) + #'((x ...) ...))] + [#:with (acc2 ...) (stx-map (lambda (l) #`(lambda- (lst) (list-tail- lst #,l))) #'(len ...))] + -------- + [⊢ [[_ ≫ (let- ([z e-]) + (cond- + [(pred? z) + (let- ([x- (acc1 z)] ... [rst- (acc2 z)]) e_body-)] ...))] + ⇒ : (⊔ ty_body ...)]]] + ;; e is a variant + [(match e with . clauses) ≫ + [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"] + [⊢ [[e ≫ e-] ⇒ : τ_e]] + [#:when (and (not (×? #'τ_e)) (not (List? #'τ_e)))] + [#:with t_expect (get-expected-type stx)] ; propagate inferred type + [#:with ([Clause:id x:id ... + (~optional (~seq #:when e_guard) #:defaults ([e_guard #'(ext-stlc:#%datum . #t)])) + -> e_c_un] ...+) ; un = unannotated with expected ty + #'clauses] + ;; length #'clauses may be > length #'info, due to guards + [#:with info-body (get-extra-info #'τ_e)] + [#:with (_ (_ (_ ConsAll) . _) ...) #'info-body] + [#:fail-unless (set=? (syntax->datum #'(Clause ...)) + (syntax->datum #'(ConsAll ...))) + (type-error #:src stx + #:msg (string-append + "match: clauses not exhaustive; missing: " + (string-join + (map symbol->string + (set-subtract + (syntax->datum #'(ConsAll ...)) + (syntax->datum #'(Clause ...)))) + ", ")))] + [#:with ((_ _ _ Cons? [_ acc τ] ...) ...) + (map ; ok to compare symbols since clause names can't be rebound + (lambda (Cl) + (stx-findf + (syntax-parser + [(_ 'C . rst) (equal? Cl (syntax->datum #'C))]) + (stx-cdr #'info-body))) ; drop leading #%app + (syntax->datum #'(Clause ...)))] + ;; this commented block experiments with expanding to unsafe ops + ;; [#:with ((acc ...) ...) (stx-map + ;; (lambda (accs) + ;; (for/list ([(a i) (in-indexed (syntax->list accs))]) + ;; #`(lambda (s) (unsafe-struct*-ref s #,(datum->syntax #'here i))))) + ;; #'((acc-fn ...) ...))] + [#:with (e_c ...+) (stx-map (lambda (ec) (add-expected-ty ec #'t_expect)) #'(e_c_un ...))] + [() ([x : τ ≫ x-] ...) + ⊢ [[e_guard ≫ e_guard-] ⇐ : Bool] [[e_c ≫ e_c-] ⇒ : τ_ec]] + ... + [#:with z (generate-temporary)] ; dont duplicate eval of test expr + -------- + [⊢ [[_ ≫ (let- ([z e-]) + (cond- + [(and- (Cons? z) + (let- ([x- (acc z)] ...) e_guard-)) + (let- ([x- (acc z)] ...) e_c-)] ...))] + ⇒ : (⊔ τ_ec ...)]]]) + +; special arrow that computes free vars; for use with tests +; (because we can't write explicit forall +(define-syntax →/test + (syntax-parser + [(→/test (~and Xs (X:id ...)) . rst) + #:when (brace? #'Xs) + #'(?∀ (X ...) (ext-stlc:→ . rst))] + [(→/test . rst) + #:with Xs (compute-tyvars #'rst) + #'(?∀ Xs (ext-stlc:→ . rst))])) + +; redefine these to use lifted → +(define-primop + : (→ Int Int Int)) +(define-primop - : (→ Int Int Int)) +(define-primop * : (→ Int Int Int)) +(define-primop max : (→ Int Int Int)) +(define-primop min : (→ Int Int Int)) +(define-primop void : (→ Unit)) +(define-primop = : (→ Int Int Bool)) +(define-primop <= : (→ Int Int Bool)) +(define-primop < : (→ Int Int Bool)) +(define-primop > : (→ Int Int Bool)) +(define-primop modulo : (→ Int Int Int)) +(define-primop zero? : (→ Int Bool)) +(define-primop sub1 : (→ Int Int)) +(define-primop add1 : (→ Int Int)) +(define-primop not : (→ Bool Bool)) +(define-primop abs : (→ Int Int)) +(define-primop even? : (→ Int Bool)) +(define-primop odd? : (→ Int Bool)) + +; all λs have type (?∀ (X ...) (→ τ_in ... τ_out)) +(define-typed-syntax λ #:datum-literals (:) + [(λ (x:id ...) body) ⇐ : (~?∀ (X ...) (~ext-stlc:→ τ_in ... τ_out)) ≫ + [#:fail-unless (stx-length=? #'[x ...] #'[τ_in ...]) + (format "expected a function of ~a arguments, got one with ~a arguments" + (stx-length #'[τ_in ...]) (stx-length #'[x ...]))] + [([X : #%type ≫ X-] ...) ([x : τ_in ≫ x-] ...) + ⊢ [[body ≫ body-] ⇐ : τ_out]] + -------- + [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇐ : _]]] + [(λ ([x : τ_x] ...) body) ⇐ : (~?∀ (V ...) (~ext-stlc:→ τ_in ... τ_out)) ≫ + [#:with [X ...] (compute-tyvars #'(τ_x ...))] + [([X : #%type ≫ X-] ...) () + ⊢ [[τ_x ≫ τ_x-] ⇐ : #%type] ...] + [τ_in τ⊑ τ_x- #:for x] ... + ;; TODO is there a way to have λs that refer to ids defined after them? + [([V : #%type ≫ V-] ... [X- : #%type ≫ X--] ...) ([x : τ_x- ≫ x-] ...) + ⊢ [[body ≫ body-] ⇐ : τ_out]] + -------- + [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇐ : _]]] + [(λ ([x : τ_x] ...) body) ≫ + [#:with [X ...] (compute-tyvars #'(τ_x ...))] + ;; TODO is there a way to have λs that refer to ids defined after them? + [([X : #%type ≫ X-] ...) ([x : τ_x ≫ x-] ...) + ⊢ [[body ≫ body-] ⇒ : τ_body]] + [#:with [τ_x* ...] (inst-types/cs #'[X ...] #'([X X-] ...) #'[τ_x ...])] + [#:with τ_fn (add-orig #'(?∀ (X- ...) (ext-stlc:→ τ_x* ... τ_body)) + #`(→ #,@(stx-map get-orig #'[τ_x* ...]) #,(get-orig #'τ_body)))] + -------- + [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇒ : τ_fn]]]) + + +;; #%app -------------------------------------------------- +(define-typed-syntax mlish:#%app #:export-as #%app + [(_ e_fn e_arg ...) ≫ + ;; compute fn type (ie ∀ and →) + [⊢ [[e_fn ≫ e_fn-] ⇒ : (~?∀ Xs (~ext-stlc:→ . tyX_args))]] + ;; solve for type variables Xs + [#:with [[e_arg- ...] Xs* cs] (solve #'Xs #'tyX_args stx)] + ;; instantiate polymorphic function type + [#:with [τ_in ... τ_out] (inst-types/cs #'Xs* #'cs #'tyX_args)] + [#:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out)] + ;; arity check + [#:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...]) + (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])] + ;; compute argument types + [#:with (τ_arg ...) (stx-map typeof #'(e_arg- ...))] + ;; typecheck args + [τ_arg τ⊑ τ_in #:for e_arg] ... + [#:with τ_out* (if (stx-null? #'(unsolved-X ...)) + #'τ_out + (syntax-parse #'τ_out + [(~?∀ (Y ...) τ_out) + #:fail-unless (→? #'τ_out) + (mk-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn) + (for ([X (in-list (syntax->list #'(unsolved-X ...)))]) + (unless (covariant-X? X #'τ_out) + (raise-syntax-error + #f + (mk-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn) + stx))) + #'(∀ (unsolved-X ... Y ...) τ_out)]))] + -------- + [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)] ⇒ : τ_out*]]]) + + +;; cond and other conditionals +(define-typed-syntax cond + [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t))) + test) + b ... body] ...+) + ⇐ : τ_expected ≫ + [⊢ [[test ≫ test-] ⇐ : Bool] ...] + [⊢ [[(begin b ... body) ≫ body-] ⇐ : τ_expected] ...] + -------- + [⊢ [[_ ≫ (cond- [test- body-] ...)] ⇐ : _]]] + [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t))) + test) + b ... body] ...+) ≫ + [⊢ [[test ≫ test-] ⇐ : Bool] ...] + [⊢ [[(begin b ... body) ≫ body-] ⇒ : τ_body] ...] + -------- + [⊢ [[_ ≫ (cond- [test- body-] ...)] ⇒ : (⊔ τ_body ...)]]]) +(define-typed-syntax when + [(when test body ...) ≫ + [⊢ [[test ≫ test-] ⇒ : _]] + [⊢ [[body ≫ body-] ⇒ : _] ...] + -------- + [⊢ [[_ ≫ (when- test- body- ... (void-))] ⇒ : Unit]]]) +(define-typed-syntax unless + [(unless test body ...) ≫ + [⊢ [[test ≫ test-] ⇒ : _]] + [⊢ [[body ≫ body-] ⇒ : _] ...] + -------- + [⊢ [[_ ≫ (unless- test- body- ... (void-))] ⇒ : Unit]]]) + +;; sync channels and threads +(define-type-constructor Channel) + +(define-typed-syntax make-channel + [(make-channel (~and tys {ty})) ≫ + [#:when (brace? #'tys)] + -------- + [⊢ [[_ ≫ (make-channel-)] ⇒ : (Channel ty)]]]) +(define-typed-syntax channel-get + [(channel-get c) ⇐ : ty ≫ + [⊢ [[c ≫ c-] ⇐ : (Channel ty)]] + -------- + [⊢ [[_ ≫ (channel-get- c-)] ⇐ : _]]] + [(channel-get c) ≫ + [⊢ [[c ≫ c-] ⇒ : (~Channel ty)]] + -------- + [⊢ [[_ ≫ (channel-get- c-)] ⇒ : ty]]]) +(define-typed-syntax channel-put + [(channel-put c v) ≫ + [⊢ [[c ≫ c-] ⇒ : (~Channel ty)]] + [⊢ [[v ≫ v-] ⇐ : ty]] + -------- + [⊢ [[_ ≫ (channel-put- c- v-)] ⇒ : Unit]]]) + +(define-base-type Thread) + +;; threads +(define-typed-syntax thread + [(thread th) ≫ + [⊢ [[th ≫ th-] ⇒ : (~?∀ () (~ext-stlc:→ τ_out))]] + -------- + [⊢ [[_ ≫ (thread- th-)] ⇒ : Thread]]]) + +(define-primop random : (→ Int Int)) +(define-primop integer->char : (→ Int Char)) +(define-primop string->list : (→ String (List Char))) +(define-primop string->number : (→ String Int)) +;(define-primop number->string : (→ Int String)) +(define-typed-syntax number->string + [number->string:id ≫ + -------- + [⊢ [[_ ≫ number->string-] ⇒ : (→ Int String)]]] + [(number->string n) ≫ + -------- + [_ ≻ (number->string n (ext-stlc:#%datum . 10))]] + [(number->string n rad) ≫ + [⊢ [[n ≫ n-] ⇐ : Int]] + [⊢ [[rad ≫ rad-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (number->string- n rad)] ⇒ : String]]]) +(define-primop string : (→ Char String)) +(define-primop sleep : (→ Int Unit)) +(define-primop string=? : (→ String String Bool)) +(define-primop string<=? : (→ String String Bool)) + +(define-typed-syntax string-append + [(string-append str ...) ≫ + [⊢ [[str ≫ str-] ⇐ : String] ...] + -------- + [⊢ [[_ ≫ (string-append- str- ...)] ⇒ : String]]]) + +;; vectors +(define-type-constructor Vector) + +(define-typed-syntax vector + [(vector (~and tys {ty})) ≫ + [#:when (brace? #'tys)] + -------- + [⊢ [[_ ≫ (vector-)] ⇒ : (Vector ty)]]] + [(vector v ...) ⇐ : (Vector ty) ≫ + [⊢ [[v ≫ v-] ⇐ : ty] ...] + -------- + [⊢ [[_ ≫ (vector- v- ...)] ⇐ : _]]] + [(vector v ...) ≫ + [⊢ [[v ≫ v-] ⇒ : ty] ...] + [#:when (same-types? #'(ty ...))] + [#:with one-ty (stx-car #'(ty ...))] + -------- + [⊢ [[_ ≫ (vector- v- ...)] ⇒ : (Vector one-ty)]]]) +(define-typed-syntax make-vector + [(make-vector n) ≫ + -------- + [_ ≻ (make-vector n (ext-stlc:#%datum . 0))]] + [(make-vector n e) ≫ + [⊢ [[n ≫ n-] ⇐ : Int]] + [⊢ [[e ≫ e-] ⇒ : ty]] + -------- + [⊢ [[_ ≫ (make-vector- n- e-)] ⇒ : (Vector ty)]]]) +(define-typed-syntax vector-length + [(vector-length e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Vector _)]] + -------- + [⊢ [[_ ≫ (vector-length- e-)] ⇒ : Int]]]) +(define-typed-syntax vector-ref + [(vector-ref e n) ⇐ : ty ≫ + [⊢ [[e ≫ e-] ⇐ : (Vector ty)]] + [⊢ [[n ≫ n-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (vector-ref- e- n-)] ⇐ : _]]] + [(vector-ref e n) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]] + [⊢ [[n ≫ n-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (vector-ref- e- n-)] ⇒ : ty]]]) +(define-typed-syntax vector-set! + [(vector-set! e n v) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]] + [⊢ [[n ≫ n-] ⇐ : Int]] + [⊢ [[v ≫ v-] ⇐ : ty]] + -------- + [⊢ [[_ ≫ (vector-set!- e- n- v-)] ⇒ : Unit]]]) +(define-typed-syntax vector-copy! + [(vector-copy! dest start src) ≫ + [⊢ [[dest ≫ dest-] ⇒ : (~Vector ty)]] + [⊢ [[start ≫ start-] ⇐ : Int]] + [⊢ [[src ≫ src-] ⇐ : (Vector ty)]] + -------- + [⊢ [[_ ≫ (vector-copy!- dest- start- src-)] ⇒ : Unit]]]) + + +;; sequences and for loops + +(define-type-constructor Sequence) + +(define-typed-syntax in-range + [(in-range end) ≫ + -------- + [_ ≻ (in-range (ext-stlc:#%datum . 0) end (ext-stlc:#%datum . 1))]] + [(in-range start end) ≫ + -------- + [_ ≻ (in-range start end (ext-stlc:#%datum . 1))]] + [(in-range start end step) ≫ + [⊢ [[start ≫ start-] ⇐ : Int]] + [⊢ [[end ≫ end-] ⇐ : Int]] + [⊢ [[step ≫ step-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (in-range- start- end- step-)] ⇒ : (Sequence Int)]]]) + +(define-typed-syntax in-naturals + [(in-naturals) ≫ + -------- + [_ ≻ (in-naturals (ext-stlc:#%datum . 0))]] + [(in-naturals start) ≫ + [⊢ [[start ≫ start-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (in-naturals- start-)] ⇒ : (Sequence Int)]]]) + + +(define-typed-syntax in-vector + [(in-vector e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]] + -------- + [⊢ [[_ ≫ (in-vector- e-)] ⇒ : (Sequence ty)]]]) + +(define-typed-syntax in-list + [(in-list e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~List ty)]] + -------- + [⊢ [[_ ≫ (in-list- e-)] ⇒ : (Sequence ty)]]]) + +(define-typed-syntax in-lines + [(in-lines e) ≫ + [⊢ [[e ≫ e-] ⇐ : String]] + -------- + [⊢ [[_ ≫ (in-lines- (open-input-string- e-))] ⇒ : (Sequence String)]]]) + +(define-typed-syntax for + [(for ([x:id e]...) b ... body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) + ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇒ : _]] + -------- + [⊢ [[_ ≫ (for- ([x- e-] ...) b- ... body-)] ⇒ : Unit]]]) +(define-typed-syntax for* + [(for* ([x:id e]...) b ... body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) + ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇒ : _]] + -------- + [⊢ [[_ ≫ (for*- ([x- e-] ...) b- ... body-)] ⇒ : Unit]]]) + +(define-typed-syntax for/list + [(for/list ([x:id e]...) body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] + -------- + [⊢ [[_ ≫ (for/list- ([x- e-] ...) body-)] ⇒ : (List ty_body)]]]) +(define-typed-syntax for/vector + [(for/vector ([x:id e]...) body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] + -------- + [⊢ [[_ ≫ (for/vector- ([x- e-] ...) body-)] ⇒ : (Vector ty_body)]]]) +(define-typed-syntax for*/vector + [(for*/vector ([x:id e]...) body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] + -------- + [⊢ [[_ ≫ (for*/vector- ([x- e-] ...) body-)] ⇒ : (Vector ty_body)]]]) +(define-typed-syntax for*/list + [(for*/list ([x:id e]...) body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]] + -------- + [⊢ [[_ ≫ (for*/list- ([x- e-] ...) body-)] ⇒ : (List ty_body)]]]) +(define-typed-syntax for/fold + [(for/fold ([acc init]) ([x:id e] ...) body) ⇐ : τ_expected ≫ + [⊢ [[init ≫ init-] ⇐ : τ_expected]] + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([acc : τ_expected ≫ acc-] [x : ty ≫ x-] ...) + ⊢ [[body ≫ body-] ⇐ : τ_expected]] + -------- + [⊢ [[_ ≫ (for/fold- ([acc- init-]) ([x- e-] ...) body-)] ⇐ : _]]] + [(for/fold ([acc init]) ([x:id e] ...) body) ≫ + [⊢ [[init ≫ init-] ⇒ : τ_init]] + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([acc : τ_init ≫ acc-] [x : ty ≫ x-] ...) + ⊢ [[body ≫ body-] ⇐ : τ_init]] + -------- + [⊢ [[_ ≫ (for/fold- ([acc- init-]) ([x- e-] ...) body-)] ⇒ : τ_init]]]) + +(define-typed-syntax for/hash + [(for/hash ([x:id e]...) body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : (~× ty_k ty_v)]] + -------- + [⊢ [[_ ≫ (for/hash- ([x- e-] ...) + (let- ([t body-]) + (values- (car- t) (cadr- t))))] + ⇒ : (Hash ty_k ty_v)]]]) + +(define-typed-syntax for/sum + [(for/sum ([x:id e]... + (~optional (~seq #:when guard) #:defaults ([guard #'#t]))) + body) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...] + [() ([x : ty ≫ x-] ...) + ⊢ [[guard ≫ guard-] ⇒ : _] [[body ≫ body-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (for/sum- ([x- e-] ... #:when guard-) body-)] ⇒ : Int]]]) + +; printing and displaying +(define-typed-syntax printf + [(printf str e ...) ≫ + [⊢ [[str ≫ s-] ⇐ : String]] + [⊢ [[e ≫ e-] ⇒ : ty] ...] + -------- + [⊢ [[_ ≫ (printf- s- e- ...)] ⇒ : Unit]]]) +(define-typed-syntax format + [(format str e ...) ≫ + [⊢ [[str ≫ s-] ⇐ : String]] + [⊢ [[e ≫ e-] ⇒ : ty] ...] + -------- + [⊢ [[_ ≫ (format- s- e- ...)] ⇒ : String]]]) +(define-typed-syntax display + [(display e) ≫ + [⊢ [[e ≫ e-] ⇒ : _]] + -------- + [⊢ [[_ ≫ (display- e-)] ⇒ : Unit]]]) +(define-typed-syntax displayln + [(displayln e) ≫ + [⊢ [[e ≫ e-] ⇒ : _]] + -------- + [⊢ [[_ ≫ (displayln- e-)] ⇒ : Unit]]]) +(define-primop newline : (→ Unit)) + +(define-typed-syntax list->vector + [(list->vector e) ⇐ : (~Vector ty) ≫ + [⊢ [[e ≫ e-] ⇐ : (List ty)]] + -------- + [⊢ [[_ ≫ (list->vector- e-)] ⇐ : _]]] + [(list->vector e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~List ty)]] + -------- + [⊢ [[_ ≫ (list->vector- e-)] ⇒ : (Vector ty)]]]) + +(define-typed-syntax let + [(let name:id (~datum :) ty:type ~! ([x:id e] ...) b ... body) ≫ + [⊢ [[e ≫ e-] ⇒ : ty_e] ...] + [() ([name : (→ ty_e ... ty.norm) ≫ name-] [x : ty_e ≫ x-] ...) + ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇐ : ty.norm]] + -------- + [⊢ [[_ ≫ (letrec- ([name- (λ- (x- ...) b- ... body-)]) + (name- e- ...))] + ⇒ : ty.norm]]] + [(let ([x:id e] ...) body ...) ≫ + -------- + [_ ≻ (ext-stlc:let ([x e] ...) (begin body ...))]]) +(define-typed-syntax let* + [(let* ([x:id e] ...) body ...) ≫ + -------- + [_ ≻ (ext-stlc:let* ([x e] ...) (begin body ...))]]) + +(define-typed-syntax begin + [(begin body ... b) ⇐ : τ_expected ≫ + [⊢ [[body ≫ body-] ⇒ : _] ...] + [⊢ [[b ≫ b-] ⇐ : τ_expected]] + -------- + [⊢ [[_ ≫ (begin- body- ... b-)] ⇐ : _]]] + [(begin body ... b) ≫ + [⊢ [[body ≫ body-] ⇒ : _] ...] + [⊢ [[b ≫ b-] ⇒ : τ]] + -------- + [⊢ [[_ ≫ (begin- body- ... b-)] ⇒ : τ]]]) + +;; hash +(define-type-constructor Hash #:arity = 2) + +(define-typed-syntax in-hash + [(in-hash e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Hash ty_k ty_v)]] + -------- + [⊢ [[_ ≫ (hash-map- e- list-)] ⇒ : (Sequence (stlc+rec-iso:× ty_k ty_v))]]]) + +; mutable hashes +(define-typed-syntax hash + [(hash (~and tys {ty_key ty_val})) ≫ + [#:when (brace? #'tys)] + -------- + [⊢ [[_ ≫ (make-hash-)] ⇒ : (Hash ty_key ty_val)]]] + [(hash (~seq k v) ...) ≫ + [⊢ [[k ≫ k-] ⇒ : ty_k] ...] + [⊢ [[v ≫ v-] ⇒ : ty_v] ...] + [#:when (same-types? #'(ty_k ...))] + [#:when (same-types? #'(ty_v ...))] + [#:with ty_key (stx-car #'(ty_k ...))] + [#:with ty_val (stx-car #'(ty_v ...))] + -------- + [⊢ [[_ ≫ (make-hash- (list- (cons- k- v-) ...))] ⇒ : (Hash ty_key ty_val)]]]) +(define-typed-syntax hash-set! + [(hash-set! h k v) ≫ + [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]] + [⊢ [[k ≫ k-] ⇐ : ty_k]] + [⊢ [[v ≫ v-] ⇐ : ty_v]] + -------- + [⊢ [[_ ≫ (hash-set!- h- k- v-)] ⇒ : Unit]]]) +(define-typed-syntax hash-ref + [(hash-ref h k) ≫ + [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]] + [⊢ [[k ≫ k-] ⇐ : ty_k]] + -------- + [⊢ [[_ ≫ (hash-ref- h- k-)] ⇒ : ty_v]]] + [(hash-ref h k fail) ≫ + [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]] + [⊢ [[k ≫ k-] ⇐ : ty_k]] + [⊢ [[fail ≫ fail-] ⇐ : (→ ty_v)]] + -------- + [⊢ [[_ ≫ (hash-ref- h- k- fail-)] ⇒ : ty_val]]]) +(define-typed-syntax hash-has-key? + [(hash-has-key? h k) ≫ + [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k _)]] + [⊢ [[k ≫ k-] ⇐ : ty_k]] + -------- + [⊢ [[_ ≫ (hash-has-key?- h- k-)] ⇒ : Bool]]]) + +(define-typed-syntax hash-count + [(hash-count h) ≫ + [⊢ [[h ≫ h-] ⇒ : (~Hash _ _)]] + -------- + [⊢ [[_ ≫ (hash-count- h-)] ⇒ : Int]]]) + +(define-base-type String-Port) +(define-base-type Input-Port) +(define-primop open-output-string : (→ String-Port)) +(define-primop get-output-string : (→ String-Port String)) +(define-primop string-upcase : (→ String String)) + +(define-typed-syntax write-string + [(write-string str out) ≫ + -------- + [_ ≻ (write-string str out (ext-stlc:#%datum . 0) (string-length str))]] + [(write-string str out start end) ≫ + [⊢ [[str ≫ str-] ⇐ : String]] + [⊢ [[out ≫ out-] ⇐ : String-Port]] + [⊢ [[start ≫ start-] ⇐ : Int]] + [⊢ [[end ≫ end-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (begin- (write-string- str- out- start- end-) (void-))] ⇒ : Unit]]]) + +(define-typed-syntax string-length + [(string-length str) ≫ + [⊢ [[str ≫ str-] ⇐ : String]] + -------- + [⊢ [[_ ≫ (string-length- str-)] ⇒ : Int]]]) +(define-primop make-string : (→ Int String)) +(define-primop string-set! : (→ String Int Char Unit)) +(define-primop string-ref : (→ String Int Char)) +(define-typed-syntax string-copy! + [(string-copy! dest dest-start src) ≫ + -------- + [_ ≻ (string-copy! + dest dest-start src (ext-stlc:#%datum . 0) (string-length src))]] + [(string-copy! dest dest-start src src-start src-end) ≫ + [⊢ [[dest ≫ dest-] ⇐ : String]] + [⊢ [[src ≫ src-] ⇐ : String]] + [⊢ [[dest-start ≫ dest-start-] ⇐ : Int]] + [⊢ [[src-start ≫ src-start-] ⇐ : Int]] + [⊢ [[src-end ≫ src-end-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (string-copy!- dest- dest-start- src- src-start- src-end-)] ⇒ : Unit]]]) + +(define-primop fl+ : (→ Float Float Float)) +(define-primop fl- : (→ Float Float Float)) +(define-primop fl* : (→ Float Float Float)) +(define-primop fl/ : (→ Float Float Float)) +(define-primop flsqrt : (→ Float Float)) +(define-primop flceiling : (→ Float Float)) +(define-primop inexact->exact : (→ Float Int)) +(define-primop exact->inexact : (→ Int Float)) +(define-primop char->integer : (→ Char Int)) +(define-primop real->decimal-string : (→ Float Int String)) +(define-primop fx->fl : (→ Int Float)) +(define-typed-syntax quotient+remainder + [(quotient+remainder x y) ≫ + [⊢ [[x ≫ x-] ⇐ : Int]] + [⊢ [[y ≫ y-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (let-values- ([[a b] (quotient/remainder- x- y-)]) + (list- a b))] + ⇒ : (stlc+rec-iso:× Int Int)]]]) +(define-primop quotient : (→ Int Int Int)) + +(define-typed-syntax set! + [(set! x:id e) ≫ + [⊢ [[x ≫ x-] ⇒ : ty_x]] + [⊢ [[e ≫ e-] ⇐ : ty_x]] + -------- + [⊢ [[_ ≫ (set!- x e-)] ⇒ : Unit]]]) + +(define-typed-syntax provide-type + [(provide-type ty ...) ≫ + -------- + [_ ≻ (provide- ty ...)]]) + +(define-typed-syntax provide + [(provide x:id ...) ≫ + [⊢ [[x ≫ x-] ⇒ : ty_x] ...] + ; TODO: use hash-code to generate this tmp + [#:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...))] + -------- + [_ ≻ (begin- + (provide- x ...) + (stlc+rec-iso:define-type-alias x-ty ty_x) ... + (provide- x-ty ...))]]) +(define-typed-syntax require-typed + [(require-typed x:id ... #:from mod) ≫ + [#:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...))] + [#:with (y ...) (generate-temporaries #'(x ...))] + -------- + [_ ≻ (begin- + (require- (rename-in (only-in mod x ... x-ty ...) [x y] ...)) + (define-syntax x (make-rename-transformer (assign-type #'y #'x-ty))) ...)]]) + +(define-base-type Regexp) +(define-primop regexp-match : (→ Regexp String (List String))) +(define-primop regexp : (→ String Regexp)) + +(define-typed-syntax equal? + [(equal? e1 e2) ≫ + [⊢ [[e1 ≫ e1-] ⇒ : ty1]] + [⊢ [[e2 ≫ e2-] ⇐ : ty1]] + -------- + [⊢ [[_ ≫ (equal?- e1- e2-)] ⇒ : Bool]]]) + +(define-typed-syntax read-int + [(read-int) ≫ + -------- + [⊢ [[_ ≫ (let- ([x (read-)]) + (cond- [(exact-integer?- x) x] + [else (error- 'read-int "expected an int, given: ~v" x)]))] + ⇒ : Int]]]) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module+ test + (begin-for-syntax + (check-true (covariant-Xs? #'Int)) + (check-true (covariant-Xs? #'(stlc+box:Ref Int))) + (check-true (covariant-Xs? #'(→ Int Int))) + (check-true (covariant-Xs? #'(∀ (X) X))) + (check-false (covariant-Xs? #'(∀ (X) (stlc+box:Ref X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ X X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ X Int)))) + (check-true (covariant-Xs? #'(∀ (X) (→ Int X)))) + (check-true (covariant-Xs? #'(∀ (X) (→ (→ X Int) X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ (→ (→ X Int) Int) X)))) + (check-false (covariant-Xs? #'(∀ (X) (→ (stlc+box:Ref X) Int)))) + (check-false (covariant-Xs? #'(∀ (X Y) (→ X Y)))) + (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) Y)))) + (check-false (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Y Int))))) + (check-true (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Int Y))))) + (check-false (covariant-Xs? #'(∀ (A B) (→ (→ Int (stlc+rec-iso:× A B)) + (→ String (stlc+rec-iso:× A B)) + (stlc+rec-iso:× A B))))) + (check-true (covariant-Xs? #'(∀ (A B) (→ (→ (stlc+rec-iso:× A B) Int) + (→ (stlc+rec-iso:× A B) String) + (stlc+rec-iso:× A B))))) + )) diff --git a/typed-lang-builder/examples/stlc+box.rkt b/typed-lang-builder/examples/stlc+box.rkt @@ -0,0 +1,32 @@ +#lang typed-lang-builder +(extends "stlc+cons.rkt") + +;; Simply-Typed Lambda Calculus, plus mutable references +;; Types: +;; - types from stlc+cons.rkt +;; - Ref constructor +;; Terms: +;; - terms from stlc+cons.rkt +;; - ref deref := + +(define-type-constructor Ref) + +(define-typed-syntax ref + [(ref e) ≫ + [⊢ [[e ≫ e-] ⇒ : τ]] + -------- + [⊢ [[_ ≫ (box- e-)] ⇒ : (Ref τ)]]]) + +(define-typed-syntax deref + [(deref e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~Ref τ)]] + -------- + [⊢ [[_ ≫ (unbox- e-)] ⇒ : τ]]]) + +(define-typed-syntax := #:literals (:=) + [(:= e_ref e) ≫ + [⊢ [[e_ref ≫ e_ref-] ⇒ : (~Ref τ)]] + [⊢ [[e ≫ e-] ⇐ : τ]] + -------- + [⊢ [[_ ≫ (set-box!- e_ref- e-)] ⇒ : Unit]]]) + diff --git a/typed-lang-builder/examples/stlc+cons.rkt b/typed-lang-builder/examples/stlc+cons.rkt @@ -0,0 +1,81 @@ +#lang typed-lang-builder +(extends "stlc+reco+var.rkt") + +;; Simply-Typed Lambda Calculus, plus cons +;; Types: +;; - types from stlc+reco+var.rkt +;; - List constructor +;; Terms: +;; - terms from stlc+reco+var.rkt + +;; TODO: enable HO use of list primitives + +(define-type-constructor List) + +(define-typed-syntax nil + [(nil ~! τi:type-ann) ≫ + -------- + [⊢ [[_ ≫ null-] ⇒ : (List τi.norm)]]] + ; minimal type inference + [nil:id ⇐ : (~List τ) ≫ + -------- + [⊢ [[_ ≫ null-] ⇐ : _]]]) +(define-typed-syntax cons + [(cons e1 e2) ≫ + [⊢ [[e1 ≫ e1-] ⇒ : τ1]] + [⊢ [[e2 ≫ e2-] ⇐ : (List τ1)]] + -------- + [⊢ [[_ ≫ (cons- e1- e2-)] ⇒ : (List τ1)]]]) +(define-typed-syntax isnil + [(isnil e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~List _)]] + -------- + [⊢ [[_ ≫ (null?- e-)] ⇒ : Bool]]]) +(define-typed-syntax head + [(head e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~List τ)]] + -------- + [⊢ [[_ ≫ (car- e-)] ⇒ : τ]]]) +(define-typed-syntax tail + [(tail e) ≫ + [⊢ [[e ≫ e-] ⇒ : τ-lst]] + [#:fail-unless (List? #'τ-lst) + (format "Expected a list type, got: ~a" (type->str #'τ-lst))] + -------- + [⊢ [[_ ≫ (cdr- e-)] ⇒ : τ-lst]]]) +(define-typed-syntax list + [(list) ≫ + -------- + [_ ≻ nil]] + [(list x . rst) ⇐ : (~List τ) ≫ ; has expected type + -------- + [⊢ [[_ ≫ (cons (add-expected x τ) (list . rst))] ⇐ : _]]] + [(list x . rst) ≫ ; no expected type + -------- + [_ ≻ (cons x (list . rst))]]) +(define-typed-syntax reverse + [(reverse e) ≫ + [⊢ [[e ≫ e-] ⇒ : τ-lst]] + [#:fail-unless (List? #'τ-lst) + (format "Expected a list type, got: ~a" (type->str #'τ-lst))] + -------- + [⊢ [[_ ≫ (reverse- e-)] ⇒ : τ-lst]]]) +(define-typed-syntax length + [(length e) ≫ + [⊢ [[e ≫ e-] ⇒ : τ-lst]] + [#:fail-unless (List? #'τ-lst) + (format "Expected a list type, got: ~a" (type->str #'τ-lst))] + -------- + [⊢ [[_ ≫ (length- e-)] ⇒ : Int]]]) +(define-typed-syntax list-ref + [(list-ref e n) ≫ + [⊢ [[e ≫ e-] ⇒ : (~List τ)]] + [⊢ [[n ≫ n-] ⇐ : Int]] + -------- + [⊢ [[_ ≫ (list-ref- e- n-)] ⇒ : τ]]]) +(define-typed-syntax member + [(member v e) ≫ + [⊢ [[e ≫ e-] ⇒ : (~List τ)]] + [⊢ [[v ≫ v-] ⇐ : τ]] + -------- + [⊢ [[_ ≫ (member- v- e-)] ⇒ : Bool]]]) diff --git a/typed-lang-builder/examples/stlc+effect.rkt b/typed-lang-builder/examples/stlc+effect.rkt @@ -0,0 +1,117 @@ +#lang typed-lang-builder +(extends "stlc+box.rkt" #:except ref deref := #%app λ) + +;; Simply-Typed Lambda Calculus, plus mutable references +;; Types: +;; - types from stlc+cons.rkt +;; - Ref constructor +;; Terms: +;; - terms from stlc+cons.rkt +;; - ref deref := + +(define-syntax-rule (locs loc ...) + '(loc ...)) +(begin-for-syntax + (define-syntax ~locs + (pattern-expander + (syntax-parser + [(locs loc:id ...) + #:with tmp (generate-temporary 'locs) + #'(~and tmp + (~parse ((~literal quote) (loc ...)) + (stx-or #'tmp #'(quote ()))))]))) + + (define (stx-truth? a) + (and a (not (and (syntax? a) (false? (syntax-e a)))))) + (define (stx-or a b) + (cond [(stx-truth? a) a] + [else b]))) + + +(define-typed-syntax effect:#%app #:export-as #%app + [(_ efn e ...) ≫ + [⊢ [[efn ≫ e_fn-] + (⇒ : (~→ τ_in ... τ_out) + (⇒ ν (~locs tyns ...)) + (⇒ := (~locs tyas ...)) + (⇒ ! (~locs tyds ...))) + (⇒ ν (~locs fns ...)) + (⇒ := (~locs fas ...)) + (⇒ ! (~locs fds ...))]] + [#:fail-unless (stx-length=? #'[e ...] #'[τ_in ...]) + (num-args-fail-msg #'efn #'[τ_in ...] #'[e ...])] + [⊢ [[e ≫ e_arg-] + (⇐ : τ_in) + (⇒ ν (~locs ns ...)) + (⇒ := (~locs as ...)) + (⇒ ! (~locs ds ...))] + ...] + -------- + [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)] + (⇒ : τ_out) + (⇒ ν (locs fns ... tyns ... ns ... ...)) + (⇒ := (locs fas ... tyas ... as ... ...)) + (⇒ ! (locs fds ... tyds ... ds ... ...))]]]) + +(define-typed-syntax λ + [(λ bvs:type-ctx e) ≫ + [() ([bvs.x : bvs.type ≫ x-] ...) ⊢ + [[e ≫ e-] + (⇒ : τ_res) + (⇒ ν (~locs ns ...)) + (⇒ := (~locs as ...)) + (⇒ ! (~locs ds ...))]] + -------- + [⊢ [[_ ≫ (λ- (x- ...) e-)] + (⇒ : (→ bvs.type ... τ_res) + (⇒ ν (locs ns ...)) + (⇒ := (locs as ...)) + (⇒ ! (locs ds ...)))]]]) + +(define-type-constructor Ref) + +(define-typed-syntax ref + [(ref e) ≫ + [⊢ [[e ≫ e-] + (⇒ : τ) + (⇒ ν (~locs ns ...)) + (⇒ := (~locs as ...)) + (⇒ ! (~locs ds ...))]] + -------- + [⊢ [[_ ≫ (box- e-)] + (⇒ : (Ref τ)) + (⇒ ν (locs #,(syntax-position stx) ns ...)) + (⇒ := (locs as ...)) + (⇒ ! (locs ds ...))]]]) +(define-typed-syntax deref + [(deref e) ≫ + [⊢ [[e ≫ e-] + (⇒ : (~Ref ty)) + (⇒ ν (~locs ns ...)) + (⇒ := (~locs as ...)) + (⇒ ! (~locs ds ...))]] + -------- + [⊢ [[_ ≫ (unbox- e-)] + (⇒ : ty) + (⇒ ν (locs ns ...)) + (⇒ := (locs as ...)) + (⇒ ! (locs #,(syntax-position stx) ds ...))]]]) +(define-typed-syntax := #:literals (:=) + [(:= e_ref e) ≫ + [⊢ [[e_ref ≫ e_ref-] + (⇒ : (~Ref ty)) + (⇒ ν (~locs ns1 ...)) + (⇒ := (~locs as1 ...)) + (⇒ ! (~locs ds1 ...))]] + [⊢ [[e ≫ e-] + (⇐ : ty) + (⇒ ν (~locs ns2 ...)) + (⇒ := (~locs as2 ...)) + (⇒ ! (~locs ds2 ...))]] + -------- + [⊢ [[_ ≫ (set-box!- e_ref- e-)] + (⇒ : Unit) + (⇒ ν (locs ns1 ... ns2 ...)) + (⇒ := (locs #,(syntax-position stx) as1 ... as2 ...)) + (⇒ ! (locs ds1 ... ds2 ...))]]]) + diff --git a/typed-lang-builder/examples/stlc+lit.rkt b/typed-lang-builder/examples/stlc+lit.rkt @@ -0,0 +1,40 @@ +#lang typed-lang-builder +(extends "stlc.rkt") +(provide define-primop) + +;; Simply-Typed Lambda Calculus, plus numeric literals and primitives +;; Types: +;; - types from stlc.rkt +;; - Int +;; Terms: +;; - terms from stlc.rkt +;; - numeric literals +;; - prim + +;; Typechecking forms: +;; - define-primop + +(define-base-type Int) + +(define-syntax define-primop + (syntax-parser #:datum-literals (:) + [(define-primop op:id : τ:type) + #:with op/tc (generate-temporary #'op) + #'(begin- + (provide- (rename-out- [op/tc op])) + (define-primop op/tc op : τ))] + [(define-primop op/tc op : τ) + #'(begin- + ; rename transformer doesnt seem to expand at the right time + ; - op still has no type in #%app + (define-syntax op/tc + (make-variable-like-transformer (assign-type #'op #'τ))))])) + +(define-primop + : (→ Int Int Int)) + +(define-typed-syntax #%datum + [(#%datum . n:integer) ≫ + -------- + [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Int]]] + [(_ . x) ≫ + -------- + [_ #:error (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x)]]) diff --git a/typed-lang-builder/examples/stlc+rec-iso.rkt b/typed-lang-builder/examples/stlc+rec-iso.rkt @@ -0,0 +1,51 @@ +#lang typed-lang-builder +(extends "stlc+tup.rkt") +(reuse ∨ var case define-type-alias define #:from "stlc+reco+var.rkt") + +;; stlc + (iso) recursive types +;; Types: +;; - types from stlc+tup.rkt +;; - also ∨ from stlc+reco+var +;; - μ +;; Terms: +;; - terms from stlc+tup.rkt +;; - also var and case from stlc+reco+var +;; - fld, unfld +;; Other: +;; - extend type=? to handle lambdas + +(define-type-constructor μ #:bvs = 1) + +(begin-for-syntax + (define stlc:type=? (current-type=?)) + ;; extend to handle μ, ie lambdas + (define (type=? τ1 τ2) +; (printf "(τ=) t1 = ~a\n" #;τ1 (syntax->datum τ1)) +; (printf "(τ=) t2 = ~a\n" #;τ2 (syntax->datum τ2)) + (syntax-parse (list τ1 τ2) + ;; alternative #4: use old type=? for everything except lambda + [(((~literal #%plain-lambda) (x:id ...) t1 ...) + ((~literal #%plain-lambda) (y:id ...) t2 ...)) + (and (stx-length=? #'(x ...) #'(y ...)) + (stx-length=? #'(t1 ...) #'(t2 ...)) + (stx-andmap + (λ (t1 t2) + ((current-type=?) (substs #'(y ...) #'(x ...) t1) t2)) + #'(t1 ...) #'(t2 ...)))] + [_ (stlc:type=? τ1 τ2)])) + (current-type=? type=?) + (current-typecheck-relation type=?)) + +(define-typed-syntax unfld + [(unfld τ:type-ann e) ≫ + [#:with (~μ* (tv) τ_body) #'τ.norm] + [⊢ [[e ≫ e-] ⇐ : τ.norm]] + -------- + [⊢ [[_ ≫ e-] ⇒ : #,(subst #'τ.norm #'tv #'τ_body)]]]) +(define-typed-syntax fld + [(fld τ:type-ann e) ≫ + [#:with (~μ* (tv) τ_body) #'τ.norm] + [#:with τ_e (subst #'τ.norm #'tv #'τ_body)] + [⊢ [[e ≫ e-] ⇐ : τ_e]] + -------- + [⊢ [[_ ≫ e-] ⇒ : τ.norm]]]) diff --git a/typed-lang-builder/examples/stlc+reco+sub.rkt b/typed-lang-builder/examples/stlc+reco+sub.rkt @@ -0,0 +1,52 @@ +#lang typed-lang-builder +(extends "stlc+sub.rkt" #:except #%app #%datum) +(extends "stlc+reco+var.rkt" #:except #%datum +) +;;use type=? and eval-type from stlc+reco+var.rkt, not stlc+sub.rkt +;; but extend sub? from stlc+sub.rkt + +;; Simply-Typed Lambda Calculus, plus subtyping, plus records +;; Types: +;; - types from stlc+sub.rkt +;; Type relations: +;; - sub? extended to records +;; Terms: +;; - terms from stlc+sub.rkt +;; - records and variants from stlc+reco+var + +(define-typed-syntax #%datum + [(#%datum . n:number) ≫ + -------- + [_ ≻ (stlc+sub:#%datum . n)]] + [(#%datum . x) ≫ + -------- + [_ ≻ (stlc+reco+var:#%datum . x)]]) + +(begin-for-syntax + (define old-sub? (current-sub?)) + (define (sub? τ1 τ2) +; (printf "t1 = ~a\n" (syntax->datum τ1)) +; (printf "t2 = ~a\n" (syntax->datum τ2)) + (or + (old-sub? τ1 τ2) + (syntax-parse (list τ1 τ2) + [((~× [k : τk] ...) (~× [l : τl] ...)) + #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) + (stx-map syntax-e (syntax->list #'(k ...)))) + (stx-andmap + (syntax-parser + [(label τlabel) + #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) + ((current-sub?) #'τk_match #'τlabel)]) + #'([l τl] ...))] + [((~∨ [k : τk] ...) (~∨ [l : τl] ...)) + #:when (subset? (stx-map syntax-e (syntax->list #'(l ...))) + (stx-map syntax-e (syntax->list #'(k ...)))) + (stx-andmap + (syntax-parser + [(label τlabel) + #:with (k_match τk_match) (stx-assoc #'label #'([k τk] ...)) + ((current-sub?) #'τk_match #'τlabel)]) + #'([l τl] ...))] + [_ #f]))) + (current-sub? sub?) + (current-typecheck-relation (current-sub?))) diff --git a/typed-lang-builder/examples/stlc+reco+var.rkt b/typed-lang-builder/examples/stlc+reco+var.rkt @@ -0,0 +1,175 @@ +#lang typed-lang-builder +(extends "stlc+tup.rkt" #:except × ×? tup proj + #:rename [~× ~stlc:×]) +(provide × ∨ (for-syntax ~× ~×* ~∨ ~∨*)) + + +;; Simply-Typed Lambda Calculus, plus records and variants +;; Types: +;; - types from stlc+tup.rkt +;; - redefine tuple type × to records +;; - sum type constructor ∨ +;; Terms: +;; - terms from stlc+tup.rkt +;; - redefine tup to records +;; - sums (var) +;; TopLevel: +;; - define (values only) +;; - define-type-alias + +(provide define-type-alias) +(define-syntax define-type-alias + (syntax-parser + [(define-type-alias alias:id τ:type) + #'(define-syntax alias (make-variable-like-transformer #'τ.norm))] + [(define-type-alias (f:id x:id ...) ty) + #'(define-syntax (f stx) + (syntax-parse stx + [(_ x ...) #'ty]))])) + +(define-typed-syntax define + [(define x:id : τ:type e:expr) ≫ + ;This wouldn't work with mutually recursive definitions + ;[⊢ [[e ≫ e-] ⇐ τ.norm]] + ;So expand to an ann form instead. + -------- + [_ ≻ (begin- + (define-syntax x (make-rename-transformer (⊢ y : τ.norm))) + (define- y (ann e : τ.norm)))]] + [(define x:id e) ≫ + [⊢ [[e ≫ e-] ⇒ : τ]] + [#:with y (generate-temporary #'x)] + -------- + [_ ≻ (begin- + (define-syntax x (make-rename-transformer (⊢ y : τ))) + (define- y e-))]]) + + +; re-define tuples as records +; dont use define-type-constructor because I want the : literal syntax +(define-syntax × + (syntax-parser #:datum-literals (:) + [(_ [label:id : τ:type] ...) + #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) + #`(stlc+tup:× valid-τ ...)])) +(begin-for-syntax + (define-syntax ~× + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~stlc:× ((~literal #%plain-app) (quote l) τ_l) ddd)] + [(_ . args) + #'(~and (~stlc:× ((~literal #%plain-app) (quote l) τ_l) (... ...)) + (~parse args #'((l τ_l) (... ...))))]))) + (define ×? stlc+tup:×?) + (define-syntax ~×* + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~or (~× [l : τ_l] ddd) + (~and any (~do (type-error + #:src #'any + #:msg "Expected × type, got: ~a" #'any))))])))) + +(begin-for-syntax + (define (stx-assoc-ref stx-lst lookup-k #:else [fail (λ () #f)]) + (define match_res (stx-assoc lookup-k stx-lst)) + (cond [match_res + (stx-cadr match_res)] + [else + (fail)])) + (define (×-ref ×-type l) + (syntax-parse ×-type + [(~× [l_τ : τ] ...) + (define res + (stx-assoc-ref #'([l_τ τ] ...) l #:else (λ () (error 'X-ref "bad!")))) + (add-orig res (get-orig res))]))) + +;; records +(define-typed-syntax tup #:datum-literals (=) + [(tup [l:id = e] ...) ≫ + [⊢ [[e ≫ e-] ⇒ : τ] ...] + -------- + [⊢ [[_ ≫ (list- (list- 'l e-) ...)] ⇒ : (× [l : τ] ...)]]]) +(define-typed-syntax proj #:literals (quote) + [(proj e_rec l:id) ≫ + [⊢ [[e_rec ≫ e_rec-] ⇒ : τ_e]] + [#:fail-unless (×? #'τ_e) + (format "Expected expression ~s to have × type, got: ~a" + (syntax->datum #'e_rec) (type->str #'τ_e))] + [#:with τ_l (×-ref #'τ_e #'l)] + -------- + [⊢ [[_ ≫ (cadr- (assoc- 'l e_rec-))] ⇒ : τ_l]]]) + +(define-type-constructor ∨/internal #:arity >= 0) + +;; variants +(define-syntax ∨ + (syntax-parser #:datum-literals (:) + [(∨ (~and [label:id : τ:type] x) ...) + #:when (> (stx-length #'(x ...)) 0) + #:with (valid-τ ...) (stx-map mk-type #'(('label τ.norm) ...)) + #'(∨/internal valid-τ ...)] + [any + (type-error #:src #'any + #:msg (string-append + "Improper usage of type constructor ∨: ~a, " + "expected (∨ [label:id : τ:type] ...+)") + #'any)])) +(begin-for-syntax + (define ∨? ∨/internal?) + (define-syntax ~∨ + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~∨/internal ((~literal #%plain-app) (quote l) τ_l) ddd)] + [(_ . args) + #'(~and (~∨/internal ((~literal #%plain-app) (quote l) τ_l) (... ...)) + (~parse args #'((l τ_l) (... ...))))]))) + (define-syntax ~∨* + (pattern-expander + (syntax-parser #:datum-literals (:) + [(_ [l : τ_l] (~and ddd (~literal ...))) + #'(~and (~or (~∨ [l : τ_l] ddd) + (~and any (~do (type-error + #:src #'any + #:msg "Expected ∨ type, got: ~a" #'any)))) + ~!)])))) ; dont backtrack here + +(begin-for-syntax + (define (∨-ref ∨-type l #:else [fail (λ () #f)]) + (syntax-parse ∨-type + [(~∨ [l_τ : τ] ...) + (define res + (stx-assoc-ref #'([l_τ τ] ...) l #:else fail)) + (add-orig res (get-orig res))]))) + +(define-typed-syntax var #:datum-literals (as =) + [(var l:id = e as τ:type) ≫ + -------- + [_ ≻ (ann (var l = e) : τ.norm)]] + [(var l:id = e) ⇐ : τ ≫ + [#:fail-unless (∨? #'τ) + (format "Expected the expected type to be a ∨ type, got: ~a" (type->str #'τ))] + [#:with τ_e + (∨-ref #'τ #'l #:else + (λ () (raise-syntax-error #f + (format "~a field does not exist" (syntax->datum #'l)) + stx)))] + [⊢ [[e ≫ e-] ⇐ : τ_e]] + -------- + [⊢ [[_ ≫ (list- 'l e)] ⇐ : _]]]) + +(define-typed-syntax case + #:datum-literals (of =>) + [(case e [l:id x:id => e_l] ...) ≫ + [#:fail-unless (not (null? (syntax->list #'(l ...)))) "no clauses"] + [⊢ [[e ≫ e-] ⇒ : (~∨* [l_x : τ_x] ...)]] + [#:fail-unless (stx-length=? #'(l ...) #'(l_x ...)) "wrong number of case clauses"] + [#:fail-unless (typechecks? #'(l ...) #'(l_x ...)) "case clauses not exhaustive"] + [() ([x : τ_x ≫ x-]) ⊢ [[e_l ≫ e_l-] ⇒ : τ_el]] ... + -------- + [⊢ [[_ ≫ + (let- ([l_e (car- e-)]) + (cond- [(symbol=?- l_e 'l) (let- ([x- (cadr- e-)]) e_l-)] ...))] + ⇒ : (⊔ τ_el ...)]]]) diff --git a/typed-lang-builder/examples/stlc+sub.rkt b/typed-lang-builder/examples/stlc+sub.rkt @@ -0,0 +1,107 @@ +#lang typed-lang-builder +(extends "stlc+lit.rkt" #:except #%datum +) +(reuse Bool String add1 #:from "ext-stlc.rkt") +(require (prefix-in ext: (only-in "ext-stlc.rkt" #%datum)) + (only-in "ext-stlc.rkt" current-join)) +(provide (for-syntax subs? current-sub?)) + +;; Simply-Typed Lambda Calculus, plus subtyping +;; Types: +;; - types from and stlc+lit.rkt +;; - Top, Num, Nat +;; Type relations: +;; - sub? +;; - Any <: Top +;; - Nat <: Int +;; - Int <: Num +;; - → +;; Terms: +;; - terms from stlc+lit.rkt, except redefined: datum and + +;; - also * +;; Other: sub? current-sub? + +(define-base-type Top) +(define-base-type Num) +(define-base-type Nat) + +(define-primop + : (→ Num Num Num)) +(define-primop * : (→ Num Num Num)) + +(define-typed-syntax #%datum + [(#%datum . n:nat) ≫ + -------- + [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Nat]]] + [(#%datum . n:integer) ≫ + -------- + [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Int]]] + [(#%datum . n:number) ≫ + -------- + [⊢ [[_ ≫ (#%datum- . n)] ⇒ : Num]]] + [(#%datum . x) ≫ + -------- + [_ ≻ (ext:#%datum . x)]]) + +(begin-for-syntax + (define (sub? t1 t2) + ; need this because recursive calls made with unexpanded types + (define τ1 ((current-type-eval) t1)) + (define τ2 ((current-type-eval) t2)) +; (printf "t1 = ~a\n" (syntax->datum τ1)) +; (printf "t2 = ~a\n" (syntax->datum τ2)) + (or ((current-type=?) τ1 τ2) + (Top? τ2))) + (define current-sub? (make-parameter sub?)) + (current-typecheck-relation sub?) + (define (subs? τs1 τs2) + (and (stx-length=? τs1 τs2) + (stx-andmap (current-sub?) τs1 τs2))) + + (define-syntax (define-sub-relation stx) + (syntax-parse stx #:datum-literals (<: =>) + [(_ τ1:id <: τ2:id) + #:with τ1-expander (format-id #'τ1 "~~~a" #'τ1) + #:with τ2-expander (format-id #'τ2 "~~~a" #'τ2) + #:with fn (generate-temporary) + #:with old-sub? (generate-temporary) + #'(begin + (define old-sub? (current-sub?)) + (define (fn t1 t2) + (define τ1 ((current-type-eval) t1)) + (define τ2 ((current-type-eval) t2)) + (syntax-parse (list τ1 τ2) + [(τ1-expander τ) ((current-sub?) #'τ2 #'τ)] + [(τ τ2-expander) ((current-sub?) #'τ #'τ1)] + [_ #f])) + (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) + (current-typecheck-relation (current-sub?)))] + [(_ (~seq τ1:id <: τ2:id (~and (~literal ...) ddd)) + (~seq τ3:id <: τ4:id) + => + (tycon1 . rst1) <: (tycon2 . rst2)) + #:with tycon1-expander (format-id #'tycon1 "~~~a" #'tycon1) + #:with tycon2-expander (format-id #'tycon2 "~~~a" #'tycon2) + #:with fn (generate-temporary) + #:with old-sub? (generate-temporary) + #'(begin + (define old-sub? (current-sub?)) + (define (fn t1 t2) + (define τ1 ((current-type-eval) t1)) + (define τ2 ((current-type-eval) t2)) + (syntax-parse (list τ1 τ2) + [((tycon1-expander . rst1) (tycon2-expander . rst2)) + (and (subs? #'(τ1 ddd) #'(τ2 ddd)) + ((current-sub?) #'τ3 #'τ4))] + [_ #f])) + (current-sub? (λ (t1 t2) (or (old-sub? t1 t2) (fn t1 t2)))) + (current-typecheck-relation (current-sub?)))])) + + (define-sub-relation Nat <: Int) + (define-sub-relation Int <: Num) + (define-sub-relation t1 <: s1 ... s2 <: t2 => (→ s1 ... s2) <: (→ t1 ... t2)) + + (define (join t1 t2) + (cond + [((current-sub?) t1 t2) t2] + [((current-sub?) t2 t1) t1] + [else #'Top])) + (current-join join)) diff --git a/typed-lang-builder/examples/stlc+tup.rkt b/typed-lang-builder/examples/stlc+tup.rkt @@ -0,0 +1,35 @@ +#lang typed-lang-builder +(extends "ext-stlc.rkt") + +(require (for-syntax racket/list)) + +;; Simply-Typed Lambda Calculus, plus tuples +;; Types: +;; - types from ext-stlc.rkt +;; - × +;; Terms: +;; - terms from ext-stlc.rkt +;; - tup and proj + +(define-type-constructor × #:arity >= 0 + #:arg-variances (λ (stx) + (make-list (stx-length (stx-cdr stx)) covariant))) + +(define-typed-syntax tup + [(tup e ...) ⇐ : (~× τ ...) ≫ + [#:when (stx-length=? #'[e ...] #'[τ ...])] + [⊢ [[e ≫ e-] ⇐ : τ] ...] + -------- + [⊢ [[_ ≫ (list- e- ...)] ⇐ : _]]] + [(tup e ...) ≫ + [⊢ [[e ≫ e-] ⇒ : τ] ...] + -------- + [⊢ [[_ ≫ (list- e- ...)] ⇒ : (× τ ...)]]]) + +(define-typed-syntax proj + [(proj e_tup n:nat) ≫ + [⊢ [[e_tup ≫ e_tup-] ⇒ : (~× τ ...)]] + [#:fail-unless (< (syntax-e #'n) (stx-length #'[τ ...])) "index too large"] + -------- + [⊢ [[_ ≫ (list-ref- e_tup- n)] ⇒ : #,(stx-list-ref #'[τ ...] (syntax-e #'n))]]]) + diff --git a/typed-lang-builder/examples/stlc.rkt b/typed-lang-builder/examples/stlc.rkt @@ -0,0 +1,53 @@ +#lang typed-lang-builder +(provide only-in (for-syntax current-type=? types=?)) + +(begin-for-syntax + ;; type eval + ;; - type-eval == full expansion == canonical type representation + ;; - must expand because: + ;; - checks for unbound identifiers (ie, undefined types) + ;; - checks for valid types, ow can't distinguish types and terms + ;; - could parse types but separate parser leads to duplicate code + ;; - later, expanding enables reuse of same mechanisms for kind checking + ;; and type application + (define (type-eval τ) + ; TODO: optimization: don't expand if expanded + ; currently, this causes problems when + ; combining unexpanded and expanded types to create new types + (add-orig (expand/df τ) τ)) + + (current-type-eval type-eval)) + +(define-syntax-category type) +(define-type-constructor → #:arity >= 1 + #:arg-variances (λ (stx) + (syntax-parse stx + [(_ τ_in ... τ_out) + (append + (make-list (stx-length #'[τ_in ...]) contravariant) + (list covariant))]))) + +(define-typed-syntax λ #:datum-literals (:) + [(λ ([x:id : τ_in:type] ...) e) ≫ + [() ([x : τ_in.norm ≫ x-] ...) ⊢ [[e ≫ e-] ⇒ : τ_out]] + -------- + [⊢ [[_ ≫ (λ- (x- ...) e-)] ⇒ : (→ τ_in.norm ... τ_out)]]] + [(λ (x:id ...) e) ⇐ : (~→ τ_in ... τ_out) ≫ + [() ([x : τ_in ≫ x-] ...) ⊢ [[e ≫ e-] ⇐ : τ_out]] + -------- + [⊢ [[_ ≫ (λ- (x- ...) e-)] ⇐ : _]]]) + +(define-typed-syntax #%app + [(_ e_fn e_arg ...) ≫ + [⊢ [[e_fn ≫ e_fn-] ⇒ : (~→ τ_in ... τ_out)]] + [#:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...]) + (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])] + [⊢ [[e_arg ≫ e_arg-] ⇐ : τ_in] ...] + -------- + [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)] ⇒ : τ_out]]]) + +(define-typed-syntax ann #:datum-literals (:) + [(ann e : τ:type) ≫ + [⊢ [[e ≫ e-] ⇐ : τ.norm]] + -------- + [⊢ [[_ ≫ e-] ⇒ : τ.norm]]]) diff --git a/typed-lang-builder/examples/sysf.rkt b/typed-lang-builder/examples/sysf.rkt @@ -0,0 +1,32 @@ +#lang typed-lang-builder +(extends "stlc+lit.rkt") +(reuse #:from "stlc+rec-iso.rkt") ; want this type=? + +;; System F +;; Type relation: +;; - extend type=? with ∀ +;; Types: +;; - types from stlc+lit.rkt +;; - ∀ +;; Terms: +;; - terms from stlc+lit.rkt +;; - Λ and inst + +(define-type-constructor ∀ #:bvs >= 0) + +(define-typed-syntax Λ + [(Λ (tv:id ...) e) ≫ + [([tv : #%type ≫ tv-] ...) () ⊢ [[e ≫ e-] ⇒ : τ]] + -------- + [⊢ [[_ ≫ e-] ⇒ : (∀ (tv- ...) τ)]]]) + +(define-typed-syntax inst + [(inst e τ:type ...) ≫ + [⊢ [[e ≫ e-] ⇒ : (~∀ tvs τ_body)]] + [#:with τ_inst (substs #'(τ.norm ...) #'tvs #'τ_body)] + -------- + [⊢ [[_ ≫ e-] ⇒ : τ_inst]]] + [(inst e) ≫ + -------- + [_ ≻ e]]) + diff --git a/typed-lang-builder/examples/tests/exist-tests.rkt b/typed-lang-builder/examples/tests/exist-tests.rkt @@ -0,0 +1,370 @@ +#lang s-exp "../exist.rkt" +(require "rackunit-typechecking.rkt") + +(check-type (pack (Int 0) as (∃ (X) X)) : (∃ (X) X)) +(check-type (pack (Int 0) as (∃ (X) X)) : (∃ (Y) Y)) +(typecheck-fail (pack (Int 0) as (∃ (X) Y))) +(check-type (pack (Bool #t) as (∃ (X) X)) : (∃ (X) X)) +(typecheck-fail (pack (Int #t) as (∃ (X) X))) + +(check-type (pack (Int (pack (Int 0) as (∃ (X) X))) as (∃ (Y) (∃ (X) X))) + : (∃ (Y) (∃ (X) X))) +(check-type (pack (Int +) as (∃ (X) (→ X Int Int))) : (∃ (X) (→ X Int Int))) +(check-type (pack (Int (pack (Int +) as (∃ (X) (→ X Int Int)))) + as (∃ (Y) (∃ (X) (→ X Y Int)))) + : (∃ (Y) (∃ (X) (→ X Y Int)))) +(check-not-type (pack (Int (pack (Int +) as (∃ (X) (→ X Int Int)))) + as (∃ (Y) (∃ (X) (→ X Y Int)))) + : (∃ (X) (∃ (X) (→ X X Int)))) + +; cant typecheck bc X has local scope, and no X elimination form +;(check-type (open [x <= (pack (Int 0) as (∃ (X) X)) with X] x) : X) + +(check-type 0 : Int) +(check-type (+ 0 1) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (+ x 1)) 0) : Int ⇒ 1) +(typecheck-fail (open [x <= (pack (Int 0) as (∃ (X) X)) with] (+ x 1))) ; can't use as Int + +(check-type (λ ([x : (∃ (X) X)]) x) : (→ (∃ (X) X) (∃ (Y) Y))) +(check-type ((λ ([x : (∃ (X) X)]) x) (pack (Int 0) as (∃ (Z) Z))) + : (∃ (X) X) ⇒ 0) +(check-type ((λ ([x : (∃ (X) X)]) x) (pack (Bool #t) as (∃ (Z) Z))) + : (∃ (X) X) ⇒ #t) + +;; example where the two binding X's are conflated, see exist.rkt for explanation +(check-type (open [x <= (pack (Int 0) as (∃ (X) X)) with X] ((λ ([y : X]) 1) x)) + : Int ⇒ 1) + +(check-type + (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) + as (∃ (X) (× [a : X] [f : (→ X X)]))) + : (∃ (X) (× [a : X] [f : (→ X X)]))) + +(define p4 + (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) + as (∃ (X) (× [a : X] [f : (→ X Int)])))) +(check-type p4 : (∃ (X) (× [a : X] [f : (→ X Int)]))) + +(check-not-type (open [x <= p4 with X] (proj x a)) : Int) ; type is X, not Int +; type is (→ X X), not (→ Int Int) +(check-not-type (open [x <= p4 with X] (proj x f)) : (→ Int Int)) +(typecheck-fail (open [x <= p4 with X] (+ 1 (proj x a)))) +(check-type (open [x <= p4 with X] ((proj x f) (proj x a))) : Int ⇒ 6) +(check-type (open [x <= p4 with X] ((λ ([y : X]) ((proj x f) y)) (proj x a))) : Int ⇒ 6) + +(check-type + (open [x <= (pack (Int 0) as (∃ (Y) Y)) with X] + ((λ ([y : X]) 1) x)) + : Int ⇒ 1) + +(check-type + (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) + as (∃ (X) (× [a : Int] [f : (→ Int Int)]))) + : (∃ (X) (× [a : Int] [f : (→ Int Int)]))) + +(typecheck-fail + (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) + as (∃ (X) (× [a : Int] [f : (→ Bool Int)])))) + +(typecheck-fail + (pack (Int (tup [a = 5] [f = (λ ([x : Int]) (+ x 1))])) + as (∃ (X) (× [a : X] [f : (→ X Bool)])))) + +(check-type + (pack (Bool (tup [a = #t] [f = (λ ([x : Bool]) (if x 1 2))])) + as (∃ (X) (× [a : X] [f : (→ X Int)]))) + : (∃ (X) (× [a : X] [f : (→ X Int)]))) + +(define counterADT + (pack (Int (tup [new = 1] + [get = (λ ([i : Int]) i)] + [inc = (λ ([i : Int]) (+ i 1))])) + as (∃ (Counter) (× [new : Counter] + [get : (→ Counter Int)] + [inc : (→ Counter Counter)])))) +(check-type counterADT : + (∃ (Counter) (× [new : Counter] + [get : (→ Counter Int)] + [inc : (→ Counter Counter)]))) +(typecheck-fail + (open [counter <= counterADT with Counter] + (+ (proj counter new) 1)) + #:with-msg "expected Int, given Counter\n *expression: \\(proj counter new\\)") +(typecheck-fail + (open [counter <= counterADT with Counter] + ((λ ([x : Int]) x) (proj counter new))) + #:with-msg "expected Int, given Counter\n *expression: \\(proj counter new\\)") +(check-type + (open [counter <= counterADT with Counter] + ((proj counter get) ((proj counter inc) (proj counter new)))) + : Int ⇒ 2) + + (check-type + (open [counter <= counterADT with Counter] + (let ([inc (proj counter inc)] + [get (proj counter get)]) + (let ([add3 (λ ([c : Counter]) (inc (inc (inc c))))]) + (get (add3 (proj counter new)))))) + : Int ⇒ 4) + +(check-type + (open [counter <= counterADT with Counter] + (let ([get (proj counter get)] + [inc (proj counter inc)] + [new (λ () (proj counter new))]) + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (open [flipflop <= + (pack (Counter (tup [new = (new)] + [read = (λ ([c : Counter]) (is-even? (get c)))] + [toggle = (λ ([c : Counter]) (inc c))] + [reset = (λ ([c : Counter]) (new))])) + as (∃ (FlipFlop) (× [new : FlipFlop] + [read : (→ FlipFlop Bool)] + [toggle : (→ FlipFlop FlipFlop)] + [reset : (→ FlipFlop FlipFlop)]))) + with FlipFlop] + (let ([read (proj flipflop read)] + [togg (proj flipflop toggle)]) + (read (togg (togg (togg (togg (proj flipflop new))))))))))) + : Bool ⇒ #f) + +(define counterADT2 + (pack ((× [x : Int]) + (tup [new = (tup [x = 1])] + [get = (λ ([i : (× [x : Int])]) (proj i x))] + [inc = (λ ([i : (× [x : Int])]) (tup [x = (+ 1 (proj i x))]))])) + as (∃ (Counter) (× [new : Counter] + [get : (→ Counter Int)] + [inc : (→ Counter Counter)])))) +(check-type counterADT2 : + (∃ (Counter) (× [new : Counter] + [get : (→ Counter Int)] + [inc : (→ Counter Counter)]))) + +;; same as above, but with different internal counter representation +(check-type + (open [counter <= counterADT2 with Counter] + (let ([get (proj counter get)] + [inc (proj counter inc)] + [new (λ () (proj counter new))]) + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (open [flipflop <= + (pack (Counter (tup [new = (new)] + [read = (λ ([c : Counter]) (is-even? (get c)))] + [toggle = (λ ([c : Counter]) (inc c))] + [reset = (λ ([c : Counter]) (new))])) + as (∃ (FlipFlop) (× [new : FlipFlop] + [read : (→ FlipFlop Bool)] + [toggle : (→ FlipFlop FlipFlop)] + [reset : (→ FlipFlop FlipFlop)]))) + with + FlipFlop] + (let ([read (proj flipflop read)] + [togg (proj flipflop toggle)]) + (read (togg (togg (togg (togg (proj flipflop new))))))))))) + : Bool ⇒ #f) + +;; err cases +(typecheck-fail + (pack (Int 1) as Int) + #:with-msg + "Expected ∃ type, got: Int") +(typecheck-fail + (open [x <= 2 with X] 3) + #:with-msg + "Expected ∃ type, got: Int") + +;; previous tets from stlc+reco+var-tests.rkt --------------------------------- +;; define-type-alias +(define-type-alias Integer Int) +(define-type-alias ArithBinOp (→ Int Int Int)) +;(define-type-alias C Complex) ; error, Complex undefined + +(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) +(check-type + : ArithBinOp) +(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) + +;; records (ie labeled tuples) +(check-type "Stephen" : String) +(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [male? : Bool])) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) + : Int ⇒ 781) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) + : Bool ⇒ #t) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [my-name : String] [phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [my-phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [is-male? : Bool])) + +;; variants +(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) +(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) + (var coffee = (void) as (∨ [coffee : Unit])))) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1])) ; not enough clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [teaaaaaa x => 2])) ; wrong clause +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [tea x => 2] + [coke x => 3])) ; too many clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => "1"] + [tea x => 2])) ; mismatched branch types +(check-type + (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) + [coffee x => x] + [tea x => 2]) : Int ⇒ 1) +(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) +(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) +(check-type + (case ((λ ([d : Drink]) d) + (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +(check-type + (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +;; previous tests: ------------------------------------------------------------ +;; tests for tuples ----------------------------------------------------------- +;; old tuple syntax not supported here +;(check-type (tup 1 2 3) : (× Int Int Int)) +;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) +; +;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) +;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") +;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) +;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large +;(typecheck-fail (proj 1 2)) ; not tuple + +;; ext-stlc.rkt tests --------------------------------------------------------- +;; should still pass + +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) +(typecheck-fail ((λ ([x : Unit]) x) 2)) +(typecheck-fail ((λ ([x : Unit])) void)) +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(typecheck-fail (begin)) +(check-type (begin 1) : Int) +;(typecheck-fail (begin 1 2 3)) +(check-type (begin (void) 1) : Int ⇒ 1) + +;;ascription +(typecheck-fail (ann 1 : Bool)) +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(typecheck-fail (let ([x #f]) (+ x 1))) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) + +; letrec +(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) +(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/ext-stlc-tests.rkt b/typed-lang-builder/examples/tests/ext-stlc-tests.rkt @@ -0,0 +1,170 @@ +#lang s-exp "../ext-stlc.rkt" +(require "rackunit-typechecking.rkt") + +;; tests for stlc extensions +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) + +(typecheck-fail + ((λ ([x : Unit]) x) 2) + #:with-msg "expected Unit, given Int\n *expression: 2") +(typecheck-fail + ((λ ([x : Unit]) x) void) + #:with-msg "expected Unit, given \\(→ Unit\\)\n *expression: void") + +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(check-type (begin 1) : Int) + +(typecheck-fail (begin) #:with-msg "expected more terms") +;; 2016-03-06: begin terms dont need to be Unit +(check-type (begin 1 2 3) : Int) +#;(typecheck-fail + (begin 1 2 3) + #:with-msg "Expected expression 1 to have Unit type, got: Int") + +(check-type (begin (void) 1) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (begin (void) x)) 1) : Int) +(check-type ((λ ([x : Int]) (begin x)) 1) : Int) +(check-type ((λ ([x : Int]) (begin (begin x))) 1) : Int) +(check-type ((λ ([x : Int]) (begin (void) (begin (void) x))) 1) : Int) +(check-type ((λ ([x : Int]) (begin (begin (void) x))) 1) : Int) + +;;ascription +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) +(typecheck-fail (ann 1 : Bool) + #:with-msg "ann: type mismatch: expected Bool, given Int\n *expression: 1") +;ann errs +(typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier") +(typecheck-fail (ann 1 : 1) #:with-msg "not a valid type") +(typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a valid type") +(typecheck-fail (ann Int : Int) + #:with-msg "ann: type mismatch: expected Int, given #%type\n *expression: Int") + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail + (let ([x #f]) (+ x 1)) + #:with-msg "expected Int, given Bool\n *expression: x") +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y)) + #:with-msg "x: unbound identifier") + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail + (let* ([x #t] [y (+ x 1)]) 1) + #:with-msg "expected Int, given Bool\n *expression: x") + +; letrec +(typecheck-fail + (letrec ([(x : Int) #f] [(y : Int) 1]) y) + #:with-msg + "letrec: type mismatch: expected Int, given Bool\n *expression: #f") +(typecheck-fail + (letrec ([(y : Int) 1] [(x : Int) #f]) x) + #:with-msg + "letrec: type mismatch: expected Int, given Bool\n *expression: #f") +(typecheck-fail + (ann (letrec ([(x : Int) #f] [(y : Int) 1]) y) : Int) + #:with-msg + "letrec: type mismatch: expected Int, given Bool\n *expression: #f") +(typecheck-fail + (ann (letrec ([(y : Int) 1] [(x : Int) #f]) x) : Int) + #:with-msg + "letrec: type mismatch: expected Int, given Bool\n *expression: #f") + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; check some more err msgs +(typecheck-fail + (and "1" #f) + #:with-msg + "and: type mismatch: expected Bool, given String\n *expression: \"1\"") +(typecheck-fail + (and #t "2") + #:with-msg + "and: type mismatch: expected Bool, given String\n *expression: \"2\"") +(typecheck-fail + (or "1" #f) + #:with-msg + "or: type mismatch: expected Bool, given String\n *expression: \"1\"") +(typecheck-fail + (or #t "2") + #:with-msg + "or: type mismatch: expected Bool, given String\n *expression: \"2\"") +;; 2016-03-10: change if to work with non-false vals +(check-type (if "true" 1 2) : Int -> 1) +(typecheck-fail + (if #t 1 "2") + #:with-msg + "branches have incompatible types: Int and String") + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) + +(typecheck-fail + ((λ ([x : Bool]) x) 1) + #:with-msg "expected Bool, given Int\n *expression: 1") +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail + (λ ([f : Int]) (f 1 2)) + #:with-msg + "Expected → type, got: Int") + +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) + : Int ⇒ 3) + +(typecheck-fail + (+ 1 (λ ([x : Int]) x)) + #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: \\(λ \\(\\(x : Int\\)\\) x\\)") +(typecheck-fail + (λ ([x : (→ Int Int)]) (+ x x)) + #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: x") +(typecheck-fail + ((λ ([x : Int] [y : Int]) y) 1) + #:with-msg "wrong number of arguments: expected 2, given 1") + +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/fomega-tests.rkt b/typed-lang-builder/examples/tests/fomega-tests.rkt @@ -0,0 +1,211 @@ +#lang s-exp "../fomega.rkt" +(require "rackunit-typechecking.rkt") + +(check-type Int : ★) +(check-type String : ★) +(typecheck-fail →) +(check-type (→ Int Int) : ★) +(typecheck-fail (→ →)) +(typecheck-fail (→ 1)) +(check-type 1 : Int) + +(typecheck-fail (tyλ ([x : ★]) 1) #:with-msg "not a valid type: 1") + +(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) +(check-not-type (Λ ([X : ★]) (λ ([x : X]) x)) : + (∀ ([X : (∀★ ★)]) (→ X X))) + +;(check-type (∀ ([t : ★]) (→ t t)) : ★) +(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★)) +(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★) + +(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) + +(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x))) + : (∀ ([X : ★]) (→ X X))) +(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x)))) + +(check-type (tyλ ([t : ★]) t) : (⇒ ★ ★)) +(check-type (tyλ ([t : ★] [s : ★]) t) : (⇒ ★ ★ ★)) +(check-type (tyλ ([t : ★]) (tyλ ([s : ★]) t)) : (⇒ ★ (⇒ ★ ★))) +(check-type (tyλ ([t : (⇒ ★ ★)]) t) : (⇒ (⇒ ★ ★) (⇒ ★ ★))) +(check-type (tyλ ([t : (⇒ ★ ★ ★)]) t) : (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★))) +(check-type (tyλ ([arg : ★] [res : ★]) (→ arg res)) : (⇒ ★ ★ ★)) + +(check-type (tyapp (tyλ ([t : ★]) t) Int) : ★) +(check-type (λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) : (→ Int Int)) +(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1) +(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2) +(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2) +(typecheck-fail ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) "a-string")) + +;; partial-apply → +(check-type (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int) + : (⇒ ★ ★)) +;; f's type must have kind ★ +(typecheck-fail (λ ([f : (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)]) f)) +(check-type (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) : + (∀ ([tyf : (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String)))) +(check-type (inst + (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) + (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) + : (→ (→ Int String) (→ Int String))) +(typecheck-fail + (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1) + #:with-msg "inst: type mismatch: expected ★, given Int\n *expression: 1") + +(typecheck-fail + (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1))) + #:with-msg "Expected → type, got: \\(tyapp tyf String\\)") +;; applied f too early +(typecheck-fail + (inst + (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1))) + (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) + #:with-msg "Expected → type, got: \\(tyapp tyf String\\)") +(check-type ((inst + (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) + (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) + (λ ([x : Int]) "int")) : (→ Int String)) +(check-type (((inst + (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) + (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)) + (λ ([x : Int]) "int")) 1) : String ⇒ "int") + +;; tapl examples, p441 +(typecheck-fail + (define-type-alias tmp 1) + #:with-msg "not a valid type: 1") +(define-type-alias Id (tyλ ([X : ★]) X)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (tyapp Id String)) Int)) +(check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int (tyapp Id String)) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (tyapp Id Int) (tyapp Id String)) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (tyapp Id Int) String) Int)) +(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (tyapp Id (→ Int String)) Int)) +(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (→ Int String)) Int)) +(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (tyapp Id (→ Int String))) Int)) + +;; tapl examples, p451 +(define-type-alias Pair (tyλ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X)))) + +;(check-type Pair : (⇒ ★ ★ ★)) +(check-type Pair : (⇒ ★ ★ (∀★ ★))) + +(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X))) +; parametric pair constructor +(check-type + (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + : (∀ ([X : ★][Y : ★]) (→ X Y (tyapp Pair X Y)))) +; concrete Pair Int String constructor +(check-type + (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) + : (→ Int String (tyapp Pair Int String))) +;; Pair Int String value +(check-type + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1") + : (tyapp Pair Int String)) +;; fst: parametric +(check-type + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) X))) +;; fst: concrete Pair Int String accessor +(check-type + (inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + Int String) + : (→ (tyapp Pair Int String) Int)) +;; apply fst +(check-type + ((inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + Int String) + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1")) + : Int ⇒ 1) +;; snd +(check-type + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) Y))) +(check-type + (inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + Int String) + : (→ (tyapp Pair Int String) String)) +(check-type + ((inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + Int String) + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1")) + : String ⇒ "1") + +;; sysf tests wont work, unless augmented with kinds +(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) + +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv + +(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2))))) + +(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4))))) + +(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4))))) + +(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int)) +(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int) +; first inst should be discarded +(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) +; second inst is discarded +(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) + +;; polymorphic arguments +(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t))) +(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u)))) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u)))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) +(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u))) +(check-type + (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int)) +(check-type + ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10) + : Int ⇒ 10) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int))) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int)) +(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) + (Λ ([s : ★]) (λ ([y : s]) y))) + : Int ⇒ 10) + + +;; previous tests ------------------------------------------------------------- +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +;(typecheck-fail #f) ; unsupported literal +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type +(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/typed-lang-builder/examples/tests/fomega2-tests.rkt b/typed-lang-builder/examples/tests/fomega2-tests.rkt @@ -0,0 +1,203 @@ +#lang s-exp "../fomega2.rkt" +(require "rackunit-typechecking.rkt") + +(check-type Int : ★) +(check-type String : ★) +(typecheck-fail →) +(check-type (→ Int Int) : ★) +(typecheck-fail (→ →)) +(typecheck-fail (→ 1)) +(check-type 1 : Int) + +;; this should error but it doesnt +#;(λ ([x : ★]) 1) + +;(check-type (∀ ([t : ★]) (→ t t)) : ★) +(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★)) +(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★) + +(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) + +(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x))) + : (∀ ([X : ★]) (→ X X))) +(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (→ ★ ★)]) (λ ([x : X]) x)))) + +(check-type (λ ([t : ★]) t) : (→ ★ ★)) +(check-type (λ ([t : ★] [s : ★]) t) : (→ ★ ★ ★)) +(check-type (λ ([t : ★]) (λ ([s : ★]) t)) : (→ ★ (→ ★ ★))) +(check-type (λ ([t : (→ ★ ★)]) t) : (→ (→ ★ ★) (→ ★ ★))) +(check-type (λ ([t : (→ ★ ★ ★)]) t) : (→ (→ ★ ★ ★) (→ ★ ★ ★))) +(check-type (λ ([arg : ★] [res : ★]) (→ arg res)) : (→ ★ ★ ★)) + +(check-type ((λ ([t : ★]) t) Int) : ★) +(check-type (λ ([x : ((λ ([t : ★]) t) Int)]) x) : (→ Int Int)) +(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1) +(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2) +(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2) +(typecheck-fail ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) "a-string")) + +;; partial-apply → +(check-type ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int) + : (→ ★ ★)) +; f's type must have kind ★ +(typecheck-fail (λ ([f : ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)]) f)) +(check-type (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) : + (∀ ([tyf : (→ ★ ★)]) (→ (tyf String) (tyf String)))) +(check-type (inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) + : (→ (→ Int String) (→ Int String))) +(typecheck-fail + (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)) + ;#:with-msg "not a valid type: 1") + +;; applied f too early +(typecheck-fail (inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1))) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))) +(check-type ((inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) + (λ ([x : Int]) "int")) : (→ Int String)) +(check-type (((inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) + (λ ([x : Int]) "int")) 1) : String ⇒ "int") + +;; tapl examples, p441 +(typecheck-fail + (define-type-alias tmp 1)) + ;#:with-msg "not a valid type: 1") +(define-type-alias Id (λ ([X : ★]) X)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (Id String)) Int)) +(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int (Id String)) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) (Id String)) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) String) Int)) +(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (Id (→ Int String)) Int)) +(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (→ Int String)) Int)) +(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (Id (→ Int String))) Int)) + +;; tapl examples, p451 +(define-type-alias Pair (λ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X)))) + +;(check-type Pair : (→ ★ ★ ★)) +(check-type Pair : (→ ★ ★ (∀★ ★))) + +(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X))) +; parametric pair constructor +(check-type + (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + : (∀ ([X : ★][Y : ★]) (→ X Y (Pair X Y)))) +; concrete Pair Int String constructor +(check-type + (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) + : (→ Int String (Pair Int String))) +; Pair Int String value +(check-type + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1") + : (Pair Int String)) +; fst: parametric +(check-type + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) X))) +; fst: concrete Pair Int String accessor +(check-type + (inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + Int String) + : (→ (Pair Int String) Int)) +; apply fst +(check-type + ((inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + Int String) + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1")) + : Int ⇒ 1) +; snd +(check-type + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) Y))) +(check-type + (inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + Int String) + : (→ (Pair Int String) String)) +(check-type + ((inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + Int String) + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1")) + : String ⇒ "1") + +;;; sysf tests wont work, unless augmented with kinds +(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) + +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv + +(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2))))) + +(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4))))) + +(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4))))) + +(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int)) +(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int) +; first inst should be discarded +(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) +; second inst is discarded +(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) + +;; polymorphic arguments +(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t))) +(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u)))) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u)))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) +(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u))) +(check-type + (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int)) +(check-type + ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10) + : Int ⇒ 10) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int))) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int)) +(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) + (Λ ([s : ★]) (λ ([y : s]) y))) + : Int ⇒ 10) + + +;; previous tests ------------------------------------------------------------- +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +;(typecheck-fail #f) ; unsupported literal +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type +(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/typed-lang-builder/examples/tests/fomega3-tests.rkt b/typed-lang-builder/examples/tests/fomega3-tests.rkt @@ -0,0 +1,200 @@ +#lang s-exp "../fomega3.rkt" +(require "rackunit-typechecking.rkt") + +(check-type Int : ★) +(check-type String : ★) +(typecheck-fail →) +(check-type (→ Int Int) : ★) +(typecheck-fail (→ →)) +(typecheck-fail (→ 1)) +(check-type 1 : Int) + +;(check-type (∀ ([t : ★]) (→ t t)) : ★) +(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★)) +(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★) + +(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) + +(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x))) + : (∀ ([X : ★]) (→ X X))) +(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (→ ★ ★)]) (λ ([x : X]) x)))) + +(check-type (λ ([t : ★]) t) : (→ ★ ★)) +(check-type (λ ([t : ★] [s : ★]) t) : (→ ★ ★ ★)) +(check-type (λ ([t : ★]) (λ ([s : ★]) t)) : (→ ★ (→ ★ ★))) +(check-type (λ ([t : (→ ★ ★)]) t) : (→ (→ ★ ★) (→ ★ ★))) +(check-type (λ ([t : (→ ★ ★ ★)]) t) : (→ (→ ★ ★ ★) (→ ★ ★ ★))) +(check-type (λ ([arg : ★] [res : ★]) (→ arg res)) : (→ ★ ★ ★)) + +(check-type ((λ ([t : ★]) t) Int) : ★) +(check-type (λ ([x : ((λ ([t : ★]) t) Int)]) x) : (→ Int Int)) +(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1) +(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2) +(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2) +(typecheck-fail ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) "a-string")) + +;; partial-apply → +(check-type ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int) + : (→ ★ ★)) +; f's type must have kind ★ +(typecheck-fail (λ ([f : ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)]) f)) +(check-type (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) : + (∀ ([tyf : (→ ★ ★)]) (→ (tyf String) (tyf String)))) +(check-type (inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) + : (→ (→ Int String) (→ Int String))) +(typecheck-fail + (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)) + ;#:with-msg "not a valid type: 1") + +;; applied f too early +(typecheck-fail (inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1))) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))) +(check-type ((inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) + (λ ([x : Int]) "int")) : (→ Int String)) +(check-type (((inst + (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) + ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)) + (λ ([x : Int]) "int")) 1) : String ⇒ "int") + +;; tapl examples, p441 +(typecheck-fail + (define-type-alias tmp 1)) + ;#:with-msg "not a valid type: 1") +(define-type-alias Id (λ ([X : ★]) X)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (Id String)) Int)) +(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int (Id String)) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) (Id String)) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (Id Int) String) Int)) +(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (→ Int String) Int)) +(check-type (λ ([f : (→ Int String)]) 1) : (→ (Id (→ Int String)) Int)) +(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (→ Int String)) Int)) +(check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (Id (→ Int String))) Int)) + +;; tapl examples, p451 +(define-type-alias Pair (λ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X)))) + +;(check-type Pair : (→ ★ ★ ★)) +(check-type Pair : (→ ★ ★ (∀★ ★))) + +(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X))) +; parametric pair constructor +(check-type + (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + : (∀ ([X : ★][Y : ★]) (→ X Y (Pair X Y)))) +; concrete Pair Int String constructor +(check-type + (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) + : (→ Int String (Pair Int String))) +; Pair Int String value +(check-type + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1") + : (Pair Int String)) +; fst: parametric +(check-type + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) X))) +; fst: concrete Pair Int String accessor +(check-type + (inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + Int String) + : (→ (Pair Int String) Int)) +; apply fst +(check-type + ((inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x)))) + Int String) + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1")) + : Int ⇒ 1) +; snd +(check-type + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) Y))) +(check-type + (inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + Int String) + : (→ (Pair Int String) String)) +(check-type + ((inst + (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y)))) + Int String) + ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y))))) + Int String) 1 "1")) + : String ⇒ "1") + +;;; sysf tests wont work, unless augmented with kinds +(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X))) + +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false +(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv + +(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2))))) + +(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4))))) + +(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4))))) + +(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int)) +(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int) +; first inst should be discarded +(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) +; second inst is discarded +(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) + +;; polymorphic arguments +(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t))) +(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s)))) +(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u)))) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u)))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) +(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u))) +(check-type + (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int)) +(check-type + ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10) + : Int ⇒ 10) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int))) +(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int)) +(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) + (Λ ([s : ★]) (λ ([y : s]) y))) + : Int ⇒ 10) + + +;; previous tests ------------------------------------------------------------- +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +;(typecheck-fail #f) ; unsupported literal +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type +(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/typed-lang-builder/examples/tests/fsub-tests.rkt b/typed-lang-builder/examples/tests/fsub-tests.rkt @@ -0,0 +1,153 @@ +#lang s-exp "../fsub.rkt" +(require "rackunit-typechecking.rkt") + +;; examples from tapl ch26, bounded quantification +;; (same tests from stlc+reco+sub.rkt, but last one should not typecheck) +(check-type (λ ([x : (× [a : Int])]) x) : (→ (× [a : Int]) (× [a : Int]))) + +(define ra (tup [a = 0])) +(check-type ((λ ([x : (× [a : Int])]) x) ra) + : (× [a : Int]) ⇒ (tup [a = 0])) +(define rab (tup [a = 0][b = #t])) +(check-type ((λ ([x : (× [a : Int])]) x) rab) + : (× [a : Int]) ⇒ (tup [a = 0][b = #t])) + +(check-type (proj ((λ ([x : (× [a : Int])]) x) rab) a) + : Int ⇒ 0) + +(check-type (Λ ([X <: Top]) (λ ([x : X]) x)) : (∀ ([X <: Top]) (→ X X))) +(check-type (inst (Λ ([X <: Top]) (λ ([x : X]) x)) (× [a : Int][b : Bool])) + : (→ (× [a : Int][b : Bool]) (× [a : Int][b : Bool]))) + +(check-type (proj ((inst (Λ ([X <: Top]) (λ ([x : X]) x)) + (× [a : Int][b : Bool])) + rab) b) + : Bool ⇒ #t) + +(define f2 (λ ([x : (× [a : Nat])]) (tup [orig = x] [asucc = (+ 1 (proj x a))]))) +(check-type f2 : (→ (× [a : Nat]) (× [orig : (× [a : Nat])] [asucc : Nat]))) +(check-type (f2 ra) : (× [orig : (× [a : Nat])][asucc : Nat])) +(check-type (f2 rab) : (× [orig : (× [a : Nat])][asucc : Nat])) + +; check expose properly called for primops +(define fNat (Λ ([X <: Nat]) (λ ([x : X]) (+ x 1)))) +(check-type fNat : (∀ ([X <: Nat]) (→ X Nat))) + +;; check type constructors properly call expose +(define f2poly + (Λ ([X <: (× [a : Nat])]) + (λ ([x : X]) + (tup [orig = x][asucc = (+ (proj x a) 1)])))) + +(check-type f2poly : (∀ ([X <: (× [a : Nat])]) (→ X (× [orig : X][asucc : Nat])))) + +; inst f2poly with (× [a : Nat]) +(check-type (inst f2poly (× [a : Nat])) + : (→ (× [a : Nat]) + (× [orig : (× [a : Nat])][asucc : Nat]))) +(check-type ((inst f2poly (× [a : Nat])) ra) + : (× [orig : (× [a : Nat])][asucc : Nat]) + ⇒ (tup [orig = ra][asucc = 1])) + +(check-type ((inst f2poly (× [a : Nat])) rab) + : (× [orig : (× [a : Nat])][asucc : Nat]) + ⇒ (tup [orig = rab][asucc = 1])) + +(typecheck-fail (proj (proj ((inst f2poly (× [a : Nat])) rab) orig) b)) + +;; inst f2poly with (× [a : Nat][b : Bool]) +(check-type (inst f2poly (× [a : Nat][b : Bool])) + : (→ (× [a : Nat][b : Bool]) + (× [orig : (× [a : Nat][b : Bool])][asucc : Nat]))) +(typecheck-fail ((inst f2poly (× [a : Nat][b : Bool])) ra)) + +(check-type ((inst f2poly (× [a : Nat][b : Bool])) rab) + : (× [orig : (× [a : Nat][b : Bool])][asucc : Nat]) + ⇒ (tup [orig = rab][asucc = 1])) + +(check-type (proj (proj ((inst f2poly (× [a : Nat][b : Bool])) rab) orig) b) + : Bool ⇒ #t) + +;; make sure inst still checks args +(typecheck-fail (inst (Λ ([X <: Nat]) 1) Int)) + +; ch28 +(define f (Λ ([X <: (→ Nat Nat)]) (λ ([y : X]) (y 5)))) +(check-type f : (∀ ([X <: (→ Nat Nat)]) (→ X Nat))) +(check-type (inst f (→ Nat Nat)) : (→ (→ Nat Nat) Nat)) +(check-type (inst f (→ Int Nat)) : (→ (→ Int Nat) Nat)) +(typecheck-fail (inst f (→ Nat Int))) +(check-type ((inst f (→ Int Nat)) (λ ([z : Int]) 5)) : Nat) +(check-type ((inst f (→ Int Nat)) (λ ([z : Num]) 5)) : Nat) +(typecheck-fail ((inst f (→ Int Nat)) (λ ([z : Nat]) 5))) + + +;; old sysf tests ------------------------------------------------------------- +;; old syntax no longer valid +;(check-type (Λ (X) (λ ([x : X]) x)) : (∀ (X) (→ X X))) +; +;(check-type (Λ (X) (λ ([t : X] [f : X]) t)) : (∀ (X) (→ X X X))) ; true +;(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (X) (→ X X X))) ; false +;(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (Y) (→ Y Y Y))) ; false, alpha equiv +; +;(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) +; : (∀ (t1) (∀ (t2) (→ t1 (→ t2 t2))))) +; +;(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) +; : (∀ (t3) (∀ (t4) (→ t3 (→ t4 t4))))) +; +;(check-not-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) +; : (∀ (t4) (∀ (t3) (→ t3 (→ t4 t4))))) +; +;(check-type (inst (Λ (t) (λ ([x : t]) x)) Int) : (→ Int Int)) +;(check-type (inst (Λ (t) 1) (→ Int Int)) : Int) +;; first inst should be discarded +;(check-type (inst (inst (Λ (t) (Λ (t) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) +;; second inst is discarded +;(check-type (inst (inst (Λ (t1) (Λ (t2) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) +; +;;;; polymorphic arguments +;(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (t) (→ t t))) +;(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (s) (→ s s))) +;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (s) (∀ (t) (→ t t)))) +;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (t) (→ t t)))) +;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (s) (→ s s)))) +;(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (u) (→ u u)))) +;(check-type (λ ([x : (∀ (t) (→ t t))]) x) : (→ (∀ (s) (→ s s)) (∀ (u) (→ u u)))) +;(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) +;(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) +;(check-type ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) : (∀ (u) (→ u u))) +;(check-type +; (inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) : (→ Int Int)) +;(check-type +; ((inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) 10) +; : Int ⇒ 10) +;(check-type (λ ([x : (∀ (t) (→ t t))]) (inst x Int)) : (→ (∀ (t) (→ t t)) (→ Int Int))) +;(check-type (λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) : (→ (∀ (t) (→ t t)) Int)) +;(check-type ((λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) +; (Λ (s) (λ ([y : s]) y))) +; : Int ⇒ 10) + + +;;; previous tests ------------------------------------------------------------- +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +;; strings and boolean literals now ok +;(typecheck-fail "one") ; unsupported literal +;(typecheck-fail #f) ; unsupported literal +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +;; edited from sysf test to handle subtyping +(check-type ((λ ([f : (→ Nat Nat Nat)] [x : Nat] [y : Nat]) (f x y)) + 1 2) : Num ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Nat]) (+ x x)) 10) : Num ⇒ 20) diff --git a/typed-lang-builder/examples/tests/mlish-tests.rkt b/typed-lang-builder/examples/tests/mlish-tests.rkt @@ -0,0 +1,778 @@ +#lang s-exp "../mlish.rkt" +(require "rackunit-typechecking.rkt") + +;; match on tups +(check-type + (match (tup 1 2) with + [x y -> (+ x y)]) + : Int -> 3) + +;; tests more or less copied from infer-tests.rkt ------------------------------ +(typecheck-fail (λ (x) x) #:with-msg "λ: no expected type, add annotations") + +;; top-level defines +(define (f [x : Int] → Int) x) +(typecheck-fail (f 1 2) #:with-msg "f: wrong number of arguments: expected 1, given 2") +(check-type f : (→ Int Int)) +(check-type (f 1) : Int ⇒ 1) +(typecheck-fail (f (λ ([x : Int]) x))) + +(define (g [x : X] → X) x) +(check-type g : (→/test X X)) + +;; (inferred) polymorpic instantiation +(check-type (g 1) : Int ⇒ 1) +(check-type (g #f) : Bool ⇒ #f) ; different instantiation +(check-type (g add1) : (→ Int Int)) +(check-type (g +) : (→ Int Int Int)) + +;; function polymorphic in list element +(define-type (List X) + Nil + (Cons X (List X))) + +;; arity err +(typecheck-fail (Cons 1) #:with-msg "Cons: wrong number of arguments: expected 2, given 1") + +;; type err +(typecheck-fail (Cons 1 1) + #:with-msg "expected: \\(List Int\\)\n *given: Int") + +(typecheck-fail + (match (Cons 1 Nil) with + [Nil -> 1]) + #:with-msg "match: clauses not exhaustive; missing: Cons") +(typecheck-fail + (match (Cons 1 Nil) with + [Cons x xs -> 1]) + #:with-msg "match: clauses not exhaustive; missing: Nil") + +(define (g2 [lst : (List Y)] → (List Y)) lst) +(check-type g2 : (→/test (List Y) (List Y))) +(typecheck-fail (g2 1) + #:with-msg + "expected: \\(List Y\\)\n *given: Int") + +;; todo? allow polymorphic nil? +(check-type (g2 (Nil {Int})) : (List Int) ⇒ (Nil {Int})) +(check-type (g2 (Nil {Bool})) : (List Bool) ⇒ (Nil {Bool})) +(check-type (g2 (Nil {(List Int)})) : (List (List Int)) ⇒ (Nil {(List Int)})) +(check-type (g2 (Nil {(→ Int Int)})) : (List (→ Int Int)) ⇒ (Nil {(List (→ Int Int))})) +;; annotations unneeded: same as tests above, but without annotations +(check-type (g2 Nil) : (List Int) ⇒ Nil) +(check-type (g2 Nil) : (List Bool) ⇒ Nil) +(check-type (g2 Nil) : (List (List Int)) ⇒ Nil) +(check-type (g2 Nil) : (List (→ Int Int)) ⇒ Nil) + +(check-type (g2 (Cons 1 Nil)) : (List Int) ⇒ (Cons 1 Nil)) +(check-type (g2 (Cons "1" Nil)) : (List String) ⇒ (Cons "1" Nil)) + +;; mlish cant type this fn (ie, incomplete cases on variant --- what to put for Nil case?) +;(define (g3 [lst : (List X)] → X) (hd lst)) +;(check-type g3 : (→ {X} (List X) X)) +;(check-type g3 : (→ {A} (List A) A)) +;(check-not-type g3 : (→ {A B} (List A) B)) +;(typecheck-fail (g3) #:with-msg "Expected.+arguments with type.+List") ; TODO: more precise err msg +;(check-type (g3 (nil {Int})) : Int) ; runtime fail +;(check-type (g3 (nil {Bool})) : Bool) ; runtime fail +;(check-type (g3 (cons 1 nil)) : Int ⇒ 1) +;(check-type (g3 (cons "1" nil)) : String ⇒ "1") + +;; recursive fn +(define (recf [x : Int] → Int) (recf x)) +(check-type recf : (→ Int Int)) + +(define (countdown [x : Int] → Int) + (if (zero? x) + 0 + (countdown (sub1 x)))) +(check-type (countdown 0) : Int ⇒ 0) +(check-type (countdown 10) : Int ⇒ 0) +(typecheck-fail (countdown "10") #:with-msg "expected: Int\n *given: String") + +;; list fns ---------- + +; map: tests whether match and define properly propagate 'expected-type +(define (map [f : (→ X Y)] [lst : (List X)] → (List Y)) + (match lst with + [Nil -> Nil] + [Cons x xs -> (Cons (f x) (map f xs))])) +(check-type map : (→/test (→ X Y) (List X) (List Y))) +(check-type map : (→/test {Y X} (→ Y X) (List Y) (List X))) +(check-type map : (→/test (→ A B) (List A) (List B))) +(check-not-type map : (→/test (→ A B) (List B) (List A))) +(check-not-type map : (→/test (→ X X) (List X) (List X))) ; only 1 bound tyvar + +; nil without annotation; tests fn-first, left-to-right arg inference +; does work yet, need to add left-to-right inference in #%app +(check-type (map add1 Nil) : (List Int) ⇒ Nil) +(check-type (map add1 (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ (Cons 2 (Cons 3 (Cons 4 Nil)))) +(typecheck-fail (map add1 (Cons "1" Nil)) + #:with-msg "expected: Int\n *given: String") +(check-type (map (λ ([x : Int]) (+ x 2)) (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ (Cons 3 (Cons 4 (Cons 5 Nil)))) +;; ; doesnt work yet: all lambdas need annotations +;; (check-type (map (λ (x) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) + +(define (filter [p? : (→ X Bool)] [lst : (List X)] → (List X)) + (match lst with + [Nil -> Nil] + [Cons x xs -> (if (p? x) + (Cons x (filter p? xs)) + (filter p? xs))])) +(define (filter/guard [p? : (→ X Bool)] [lst : (List X)] → (List X)) + (match lst with + [Nil -> Nil] + [Cons x xs #:when (p? x) -> (Cons x (filter p? xs))] + [Cons x xs -> (filter p? xs)])) +(check-type (filter zero? Nil) : (List Int) ⇒ Nil) +(check-type (filter zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ Nil) +(check-type (filter zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 0 Nil)) +(check-type (filter (λ (x) (not (zero? x))) (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) +(check-type (filter/guard zero? Nil) : (List Int) ⇒ Nil) +(check-type (filter/guard zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ Nil) +(check-type (filter/guard zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 0 Nil)) +(check-type + (filter/guard (λ (x) (not (zero? x))) (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) +; doesnt work yet: all lambdas need annotations +;(check-type (filter (λ (x) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) + +(define (foldr [f : (→ X Y Y)] [base : Y] [lst : (List X)] → Y) + (match lst with + [Nil -> base] + [Cons x xs -> (f x (foldr f base xs))])) +(define (foldl [f : (→ X Y Y)] [acc : Y] [lst : (List X)] → Y) + (match lst with + [Nil -> acc] + [Cons x xs -> (foldr f (f x acc) xs)])) + +(define (all? [p? : (→ X Bool)] [lst : (List X)] → Bool) + (match lst with + [Nil -> #t] + [Cons x xs #:when (p? x) -> (all? p? xs)] + [Cons x xs -> #f])) + +(define (tails [lst : (List X)] → (List (List X))) + (match lst with + [Nil -> (Cons Nil Nil)] + [Cons x xs -> (Cons lst (tails xs))])) + +(define (build-list [n : Int] [f : (→ Int X)] → (List X)) + (if (zero? (sub1 n)) + (Cons (f 0) Nil) + (Cons (f (sub1 n)) (build-list (sub1 n) f)))) +(check-type (build-list 1 add1) : (List Int) ⇒ (Cons 1 Nil)) +(check-type (build-list 3 add1) : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 Nil)))) +(check-type (build-list 5 sub1) + : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 (Cons 0 (Cons -1 Nil)))))) +(check-type (build-list 5 (λ (x) (add1 (add1 x)))) + : (List Int) ⇒ (Cons 6 (Cons 5 (Cons 4 (Cons 3 (Cons 2 Nil)))))) + +(define (build-list/comp [i : Int] [n : Int] [nf : (→ Int Int)] [f : (→ Int X)] → (List X)) + (if (= i n) + Nil + (Cons (f (nf i)) (build-list/comp (add1 i) n nf f)))) + +(define built-list-1 (build-list/comp 0 3 (λ (x) (* 2 x)) add1)) +(define built-list-2 (build-list/comp 0 3 (λ (x) (* 2 x)) number->string)) +(check-type built-list-1 : (List Int) -> (Cons 1 (Cons 3 (Cons 5 Nil)))) +(check-type built-list-2 : (List String) -> (Cons "0" (Cons "2" (Cons "4" Nil)))) + +(define (~>2 [a : A] [f : (→ A A)] [g : (→ A B)] → B) + (g (f a))) + +(define ~>2-result-1 (~>2 1 (λ (x) (* 2 x)) add1)) +(define ~>2-result-2 (~>2 1 (λ (x) (* 2 x)) number->string)) +(check-type ~>2-result-1 : Int -> 3) +(check-type ~>2-result-2 : String -> "2") + +(define (append [lst1 : (List X)] [lst2 : (List X)] → (List X)) + (match lst1 with + [Nil -> lst2] + [Cons x xs -> (Cons x (append xs lst2))])) + +;; end infer.rkt tests -------------------------------------------------- + +;; algebraic data types +(define-type IntList + INil + (ConsI Int IntList)) + +;; HO, monomorphic +(check-type ConsI : (→ Int IntList IntList)) +(define (new-cons [c : (→ Int IntList IntList)] [x : Int] [xs : IntList] + -> IntList) + (c x xs)) +(check-type (new-cons ConsI 1 INil) : IntList -> (ConsI 1 INil)) + +;; check that ConsI and INil are available as tyvars +(define (f10 [x : INil] [y : ConsI] -> ConsI) y) +(check-type f10 : (→/test X Y Y)) + +(check-type INil : IntList) +(check-type (ConsI 1 INil) : IntList) +(check-type + (match INil with + [INil -> 1] + [ConsI x xs -> 2]) : Int ⇒ 1) +(check-type + (match (ConsI 1 INil) with + [INil -> 1] + [ConsI x xs -> 2]) : Int ⇒ 2) +(typecheck-fail (match 1 with [INil -> 1])) + +(typecheck-fail (ConsI #f INil) + #:with-msg + "expected: Int\n *given: Bool") + +;; annotated +(check-type (Nil {Int}) : (List Int)) +(check-type (Cons {Int} 1 (Nil {Int})) : (List Int)) +(check-type (Cons {Int} 1 (Cons 2 (Nil {Int}))) : (List Int)) +;; partial annotations +(check-type (Cons 1 (Nil {Int})) : (List Int)) +(check-type (Cons 1 (Cons 2 (Nil {Int}))) : (List Int)) +(check-type (Cons {Int} 1 Nil) : (List Int)) +(check-type (Cons {Int} 1 (Cons 2 Nil)) : (List Int)) +(check-type (Cons 1 (Cons {Int} 2 Nil)) : (List Int)) +; no annotations +(check-type (Cons 1 Nil) : (List Int)) +(check-type (Cons 1 (Cons 2 Nil)) : (List Int)) + +(define-type (Tree X) + (Leaf X) + (Node (Tree X) (Tree X))) +(check-type (Leaf 10) : (Tree Int)) +(check-type (Node (Leaf 10) (Leaf 11)) : (Tree Int)) + +(typecheck-fail Nil #:with-msg "Nil: no expected type, add annotations") +(typecheck-fail (Cons 1 (Nil {Bool})) + #:with-msg + "expected: \\(List Int\\)\n *given: \\(List Bool\\)") +(typecheck-fail (Cons {Bool} 1 (Nil {Int})) + #:with-msg + "Cons: type mismatch: expected Bool, given Int\n *expression: 1") +(typecheck-fail (Cons {Bool} 1 Nil) + #:with-msg + "Cons: type mismatch: expected Bool, given Int\n *expression: 1") + +(typecheck-fail (match Nil with [Cons x xs -> 2] [Nil -> 1]) + #:with-msg "Nil: no expected type, add annotations") +(check-type + (match (Nil {Int}) with + [Cons x xs -> 2] + [Nil -> 1]) + : Int ⇒ 1) + +(check-type + (match (Nil {Int}) with + [Nil -> 1] + [Cons x xs -> 2]) + : Int ⇒ 1) + +(check-type + (match (Cons 1 Nil) with + [Nil -> 3] + [Cons y ys -> (+ y 4)]) + : Int ⇒ 5) + +(check-type + (match (Cons 1 Nil) with + [Cons y ys -> (+ y 5)] + [Nil -> 3]) + : Int ⇒ 6) + +;; check expected-type propagation for other match paterns + +(define-type (Option A) + (None) + (Some A)) + +(define (None* → (Option A)) None) + +(check-type (match (tup 1 2) with [a b -> None]) : (Option Int) -> None) +(check-type + (match (list 1 2) with + [[] -> None] + [[x y] -> None]) + : (Option Int) -> None) + +(check-type + (match (list 1 2) with + [[] -> None] + [x :: xs -> None]) + : (Option Int) -> None) + +(define-type (Pairof A B) (C A B)) +(check-type (match (C 1 2) with [C a b -> None]) : (Option Int) -> None) + +;; type variable inference + +; F should remain valid tyvar, even though it's bound +(define (F [x : X] -> X) x) +(define (tvf1 [x : F] -> F) x) +(check-type tvf1 : (→/test X X)) + +; G should remain valid tyvar +(define-type (Type1 X) (G X)) +(define (tvf5 [x : G] -> G) x) +(check-type tvf5 : (→/test X X)) + +; TY should not be tyvar, bc it's a valid type +(define-type-alias TY (Pairof Int Int)) +(define (tvf2 [x : TY] -> TY) x) +(check-not-type tvf2 : (→/test X X)) + +; same with Bool +(define (tvf3 [x : Bool] -> Bool) x) +(check-not-type tvf3 : (→/test X X)) + +;; X in lam should not be a new tyvar +(define (tvf4 [x : X] -> (→ X X)) + (λ (y) x)) +(check-type tvf4 : (→/test X (→ X X))) +(check-not-type tvf4 : (→/test X (→ Y X))) + +(define (tvf6 [x : X] -> (→ Y X)) + (λ (y) x)) +(check-type tvf6 : (→/test X (→ Y X))) + +;; nested lambdas + +(check-type (λ ([x : X]) (λ ([y : X]) y)) : (→/test X (→ X X))) +(check-not-type (λ ([x : X]) (λ ([y : X]) y)) : (→/test {X} X (→/test {Y} Y Y))) +(check-type (λ ([x : X]) (λ ([y : Y]) y)) : (→/test {X} X (→/test {Y} Y Y))) +(check-not-type (λ ([x : X]) (λ ([y : Y]) x)) : (→/test X (→ X X))) + +(check-type + ((λ ([x : X]) (λ ([y : Y]) y)) 1) + : (→/test Y Y)) + +;; TODO? +;; - this fails if polymorphic functions are allowed as HO args +;; - do we want to allow this? +;; - must explicitly instantiate before passing fn +(check-type + ((λ ([x : (→ X (→ Y Y))]) x) + (inst (λ ([x : X]) (inst (λ ([y : Y]) y) Int)) Int)) + : (→ Int (→ Int Int))) + +(check-type + ((λ ([x : X]) (λ ([y : Y]) (λ ([z : Z]) z))) 1) + : (→/test {Y} Y (→/test {Z} Z Z))) + +(check-type (inst Cons (→/test X X)) + : (→ (→/test X X) (List (→/test X X)) (List (→/test X X)))) +(check-type map : (→/test (→ X Y) (List X) (List Y))) + +(check-type (Cons (λ ([x : X]) x) Nil) + : (List (→/test {X} X X))) + +(define (nn [x : X] -> (→ (× X (→ Y Y)))) + (λ () (tup x (λ ([x : Y]) x)))) +(typecheck-fail (nn 1) #:with-msg "Could not infer instantiation of polymorphic function nn.") +(check-type (nn 1) : (→ (× Int (→ String String)))) +(check-type (nn 1) : (→ (× Int (→ (List Int) (List Int))))) + +(define (nn2 [x : X] -> (→ (× X (→ Y Y) (List Z)))) + (λ () (tup x (λ ([x : Y]) x) Nil))) +(typecheck-fail (nn2 1) #:with-msg "Could not infer instantiation of polymorphic function nn2.") +(check-type (nn2 1) : (→ (× Int (→ String String) (List (List Int))))) +(check-type (nn2 1) : (→ (× Int (→ (List Int) (List Int)) (List String)))) +;; test inst order +(check-type ((inst nn2 Int String (List Int)) 1) + : (→ (× Int (→ String String) (List (List Int))))) +(check-type ((inst nn2 Int (List Int) String) 1) + : (→ (× Int (→ (List Int) (List Int)) (List String)))) + +(define (nn3 [x : X] -> (→ (× X (Option Y) (Option Z)))) + (λ () (tup x None None))) +(check-type (nn3 1) : (→/test (× Int (Option Y) (Option Z)))) +(check-type (nn3 1) : (→ (× Int (Option String) (Option (List Int))))) +(check-type ((nn3 1)) : (× Int (Option String) (Option (List Int)))) +(check-type ((nn3 1)) : (× Int (Option (List Int)) (Option String))) +;; test inst order +(check-type ((inst (nn3 1) String (List Int))) : (× Int (Option String) (Option (List Int)))) +(check-type ((inst (nn3 1) (List Int) String)) : (× Int (Option (List Int)) (Option String))) + +(define (nn4 -> (→ (Option X))) + (λ () (None*))) +(check-type (let ([x (nn4)]) + x) + : (→/test (Option X))) + +(define (nn5 -> (→ (Ref (Option X)))) + (λ () (ref (None {X})))) +(typecheck-fail (let ([x (nn5)]) + x) + #:with-msg "Could not infer instantiation of polymorphic function nn5.") + +(define (nn6 -> (→ (Option X))) + (let ([r (((inst nn5 X)))]) + (λ () (deref r)))) +(check-type (nn6) : (→/test (Option X))) + +;; A is covariant, B is invariant. +(define-type (Cps A B) + (cps (→ (→ A B) B))) +(define (cps* [f : (→ (→ A B) B)] → (Cps A B)) + (cps f)) + +(define (nn7 -> (→ (Cps (Option A) B))) + (let ([r (((inst nn5 A)))]) + (λ () (cps* (λ (k) (k (deref r))))))) +(typecheck-fail (let ([x (nn7)]) + x) + #:with-msg "Could not infer instantiation of polymorphic function nn7.") + +(define (nn8 -> (→ (Cps (Option A) Int))) + (nn7)) +(check-type (let ([x (nn8)]) + x) + : (→/test (Cps (Option A) Int))) + +(define-type (Result A B) + (Ok A) + (Error B)) + +(define (ok [a : A] → (Result A B)) + (Ok a)) +(define (error [b : B] → (Result A B)) + (Error b)) + +(define (ok-fn [a : A] -> (→ (Result A B))) + (λ () (ok a))) +(define (error-fn [b : B] -> (→ (Result A B))) + (λ () (error b))) + +(check-type (let ([x (ok-fn 1)]) + x) + : (→/test (Result Int B))) +(check-type (let ([x (error-fn "bad")]) + x) + : (→/test (Result A String))) + +(define (nn9 [a : A] -> (→ (Result A (Ref B)))) + (ok-fn a)) +(define (nn10 [a : A] -> (→ (Result A (Ref String)))) + (nn9 a)) +(define (nn11 -> (→ (Result (Option A) (Ref String)))) + (nn10 (None*))) + +(typecheck-fail (let ([x (nn9 1)]) + x) + #:with-msg "Could not infer instantiation of polymorphic function nn9.") +(check-type (let ([x (nn10 1)]) + x) + : (→ (Result Int (Ref String)))) +(check-type (let ([x (nn11)]) + x) + : (→/test (Result (Option A) (Ref String)))) + +(check-type (if (zero? (random 2)) + (ok 0) + (error "didn't get a zero")) + : (Result Int String)) + +(define result-if-0 + (λ ([b : (Result A1 B1)] [succeed : (→ A1 (Result A2 B2))] [fail : (→ B1 (Result A2 B2))]) + (match b with + [Ok a -> (succeed a)] + [Error b -> (fail b)]))) +(check-type result-if-0 + : (→/test (Result A1 B1) (→ A1 (Result A2 B2)) (→ B1 (Result A2 B2)) + (Result A2 B2))) + +(define (result-if-1 [b : (Result A1 B1)] + → (→ (→ A1 (Result A2 B2)) (→ B1 (Result A2 B2)) + (Result A2 B2))) + (λ ([succeed : (→ A1 (Result A2 B2))] [fail : (→ B1 (Result A2 B2))]) + (result-if-0 b succeed fail))) +(check-type result-if-1 + : (→/test (Result A1 B1) (→ (→ A1 (Result A2 B2)) (→ B1 (Result A2 B2)) + (Result A2 B2)))) +(check-type ((inst result-if-1 Int String (List Int) (List String)) (Ok 1)) + : (→ (→ Int (Result (List Int) (List String))) + (→ String (Result (List Int) (List String))) + (Result (List Int) (List String)))) +(check-type ((inst result-if-1 Int String (List Int) (List String)) (Error "bad")) + : (→ (→ Int (Result (List Int) (List String))) + (→ String (Result (List Int) (List String))) + (Result (List Int) (List String)))) +(check-type (((inst result-if-1 Int String (List Int) (List String)) (Ok 1)) + (λ ([a : Int]) (ok (Cons a Nil))) + (λ ([b : String]) (error (Cons b Nil)))) + : (Result (List Int) (List String))) +;; same thing, but without the lambda annotations: +(check-type (((inst result-if-1 Int String (List Int) (List String)) (Ok 1)) + (λ (a) (ok (Cons a Nil))) + (λ (b) (error (Cons b Nil)))) + : (Result (List Int) (List String))) + +(define (result-if-2 [b : (Result A1 B1)] + → (→ (→ A1 (Result A2 B2)) + (→ (→ B1 (Result A2 B2)) + (Result A2 B2)))) + (λ ([succeed : (→ A1 (Result A2 B2))]) + (λ ([fail : (→ B1 (Result A2 B2))]) + (result-if-0 b succeed fail)))) +(check-type result-if-2 + : (→/test (Result A1 B1) (→ (→ A1 (Result A2 B2)) + (→ (→ B1 (Result A2 B2)) + (Result A2 B2))))) +(check-type ((inst result-if-2 Int String (List Int) (List String)) (Ok 1)) + : (→/test (→ Int (Result (List Int) (List String))) + (→ (→ String (Result (List Int) (List String))) + (Result (List Int) (List String))))) +(check-type (((inst result-if-2 Int String (List Int) (List String)) (Ok 1)) + (λ (a) (Ok (Cons a Nil)))) + : (→/test (→ String (Result (List Int) (List String))) + (Result (List Int) (List String)))) +(check-type ((((inst result-if-2 Int String (List Int) (List String)) (Ok 1)) + (λ (a) (Ok (Cons a Nil)))) + (λ (b) (Error (Cons b Nil)))) + : (Result (List Int) (List String))) + +(define (tup* [a : A] [b : B] -> (× A B)) + (tup a b)) + +(define (nn12 -> (→ (× (Option A) (Option B)))) + (λ () (tup* (None*) (None*)))) +(check-type (let ([x (nn12)]) + x) + : (→/test (× (Option A) (Option B)))) + +(define (nn13 -> (→ (× (Option A) (Option (Ref B))))) + (nn12)) +(typecheck-fail (let ([x (nn13)]) + x) + #:with-msg "Could not infer instantiation of polymorphic function nn13.") + +;; records and automatically-defined accessors and predicates +(define-type (RecoTest X Y) + (RT1 [x : X] [y : Y] [z : String]) + (RT2 [a : Y] [b : X] [c : (List X)]) + (RT3 X Y)) ; mixing records and non-records allowed + +(check-type RT1-x : (→/test (RecoTest X Y) X)) +(check-type RT1-y : (→/test (RecoTest X Y) Y)) +(check-type RT1-z : (→/test (RecoTest X Y) String)) +(check-type RT2-a : (→/test (RecoTest X Y) Y)) +(check-type RT2-b : (→/test (RecoTest X Y) X)) + +(check-type RT1? : (→/test (RecoTest X Y) Bool)) +(check-type RT2? : (→/test (RecoTest X Y) Bool)) +(check-type RT3? : (→/test (RecoTest X Y) Bool)) + +(check-type (RT1-x (RT1 1 #t "2")) : Int -> 1) +(check-type (RT1-y (RT1 1 #t "2")) : Bool -> #t) +(check-type (RT1-z (RT1 1 #t "2")) : String -> "2") + +(check-type (RT2-a (RT2 1 #f Nil)) : Int -> 1) +(check-type (RT2-b (RT2 1 #f Nil)) : Bool -> #f) +(check-type (RT2-c (RT2 1 #f Nil)) : (List Bool) -> Nil) + +(check-type (RT1? (RT1 1 2 "3")) : Bool -> #t) +(check-type (RT1? (RT2 1 2 Nil)) : Bool -> #f) +(check-type (RT1? (RT3 1 "2")) : Bool -> #f) +(check-type (RT3? (RT3 1 2)) : Bool -> #t) +(check-type (RT3? (RT1 1 2 "3")) : Bool -> #f) + +(typecheck-fail RT3-x #:with-msg "unbound identifier") + +;; accessors produce runtime exception if given wrong variant +(check-runtime-exn (RT1-x (RT2 1 #f (Cons #t Nil)))) +(check-runtime-exn (RT1-y (RT2 1 #f (Cons #t Nil)))) +(check-runtime-exn (RT1-z (RT2 1 #f (Cons #t Nil)))) +(check-runtime-exn (RT1-x (RT3 1 2))) +(check-runtime-exn (RT2-a (RT1 1 #f "2"))) +(check-runtime-exn (RT2-c (RT1 1 #f "2"))) +(check-runtime-exn (RT2-c (RT1 1 #f "2"))) +(check-runtime-exn (RT2-a (RT3 #f #t))) + +;; non-match version +(define (rt-fn [rt : (RecoTest X Y)] -> X) + (if (RT1? rt) + (RT1-x rt) + (if (RT2? rt) + (RT2-b rt) + (match rt with [RT3 x y -> x][RT1 x y z -> x][RT2 a b c -> b])))) +(check-type (rt-fn (RT1 1 #f "3")) : Int -> 1) +(check-type (rt-fn (RT2 #f 2 Nil)) : Int -> 2) +(check-type (rt-fn (RT3 10 20)) : Int -> 10) + +;; HO constructors +(check-type RT1 : (→/test X Y String (RecoTest X Y))) +(check-type RT2 : (→/test {X Y} Y X (List X) (RecoTest X Y))) +(check-type RT3 : (→/test X Y (RecoTest X Y))) + +(typecheck-fail (for/fold ([x 1]) () "hello") + #:with-msg "for/fold: type mismatch: expected Int, given String\n *expression: \"hello\"") + +; ext-stlc tests -------------------------------------------------- + +; tests for stlc extensions +; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) + +(typecheck-fail + ((λ ([x : Unit]) x) 2) + #:with-msg + "expected: Unit\n *given: Int") +(typecheck-fail + ((λ ([x : Unit]) x) void) + #:with-msg + "expected: Unit\n *given: \\(→ Unit\\)") + +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(check-type (begin 1) : Int) + +(typecheck-fail (begin) #:with-msg "expected more terms") +;; 2016-03-06: begin terms dont need to be Unit +(check-type (begin 1 2 3) : Int) +#;(typecheck-fail + (begin 1 2 3) + #:with-msg "Expected expression 1 to have Unit type, got: Int") + +(check-type (begin (void) 1) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (begin (void) x)) 1) : Int) +(check-type ((λ ([x : Int]) (begin x)) 1) : Int) +(check-type ((λ ([x : Int]) (begin (begin x))) 1) : Int) +(check-type ((λ ([x : Int]) (begin (void) (begin (void) x))) 1) : Int) +(check-type ((λ ([x : Int]) (begin (begin (void) x))) 1) : Int) + +;;ascription +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) +(typecheck-fail (ann 1 : Bool) #:with-msg "expected Bool, given Int\n *expression: 1") +;ann errs +(typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier") +(typecheck-fail (ann 1 : 1) #:with-msg "not a valid type") +(typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a valid type") +(typecheck-fail (ann Int : Int) #:with-msg "expected Int, given #%type\n *expression: Int") + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail + (let ([x #f]) (+ x 1)) + #:with-msg "expected: Int\n *given: Bool") +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y)) + #:with-msg "x: unbound identifier") + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail + (let* ([x #t] [y (+ x 1)]) 1) + #:with-msg "expected: Int\n *given: Bool") + +; letrec +(typecheck-fail + (letrec ([(x : Int) #f] [(y : Int) 1]) y) + #:with-msg + "letrec: type mismatch: expected Int, given Bool\n *expression: #f") +(typecheck-fail + (letrec ([(y : Int) 1] [(x : Int) #f]) x) + #:with-msg + "letrec: type mismatch: expected Int, given Bool\n *expression: #f") + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ (i) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ (n) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ (n) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; check some more err msgs +(typecheck-fail + (and "1" #f) + #:with-msg "and: type mismatch: expected Bool, given String\n *expression: \"1\"") +(typecheck-fail + (and #t "2") + #:with-msg + "and: type mismatch: expected Bool, given String\n *expression: \"2\"") +(typecheck-fail + (or "1" #f) + #:with-msg + "or: type mismatch: expected Bool, given String\n *expression: \"1\"") +(typecheck-fail + (or #t "2") + #:with-msg + "or: type mismatch: expected Bool, given String\n *expression: \"2\"") +;; 2016-03-09: now ok +(check-type (if "true" 1 2) : Int -> 1) +(typecheck-fail + (if #t 1 "2") + #:with-msg + "branches have incompatible types: Int and String") + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ (x y) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ (x) x) : (→ Int Int)) +(check-type (λ (f) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) + +(typecheck-fail + ((λ ([x : Bool]) x) 1) + #:with-msg "expected: Bool\n *given: Int") +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail + (λ ([f : Int]) (f 1 2)) + #:with-msg + "Expected → type, got: Int") + +(check-type (λ (f x y) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) + : Int ⇒ 3) + +(typecheck-fail + (+ 1 (λ ([x : Int]) x)) + #:with-msg "expected: Int\n *given: \\(→ Int Int\\)") +(typecheck-fail + (λ ([x : (→ Int Int)]) (+ x x)) + #:with-msg "expected: Int\n *given: \\(→ Int Int\\)") +(typecheck-fail + ((λ ([x : Int] [y : Int]) y) 1) + #:with-msg "wrong number of arguments: expected 2, given 1\n *expected: +Int, Int\n *arguments: 1") + +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/mlish/ack.mlish b/typed-lang-builder/examples/tests/mlish/ack.mlish @@ -0,0 +1,27 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; tests cond with else + +(define (ack/else [m : Int] [n : Int] -> Int) + (cond + [(zero? m) (add1 n)] + [(zero? n) (ack/else (sub1 m) 1)] + [else + (ack/else (sub1 m) (ack/else m (sub1 n)))])) + +(check-type (ack/else 0 0) : Int -> 1) +(check-type (ack/else 1 1) : Int -> 3) +(check-type (ack/else 2 2) : Int -> 7) +(check-type (ack/else 3 4) : Int -> 125) + +(define (ack [m : Int] [n : Int] -> Int) + (cond + [(zero? m) (add1 n)] + [(zero? n) (ack (sub1 m) 1)] + [#t (ack (sub1 m) (ack m (sub1 n)))])) + +(check-type (ack 0 0) : Int -> 1) +(check-type (ack 1 1) : Int -> 3) +(check-type (ack 2 2) : Int -> 7) +(check-type (ack 3 4) : Int -> 125) diff --git a/typed-lang-builder/examples/tests/mlish/alex.mlish b/typed-lang-builder/examples/tests/mlish/alex.mlish @@ -0,0 +1,25 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; the following function def produces error: +;; define: Function should-err's body (let ((y (f x))) x) has type X, which +;; does not match given type Y. +;; TODO: add check-_ rackunit form for functions +#;(define (should-err [x : X] [f : (→ X Y)] -> Y) + (let ([y (f x)]) + x)) + +(define (try [x : X][f : (→ X Y)] → X) + (let ([y (f x)]) x)) + +(check-type try : (→/test X (→ X Y) X)) + +(define (accept-A×A [pair : (× A A)] → (× A A)) + pair) + +(typecheck-fail (accept-A×A (tup 8 "ate")) + #:with-msg "couldn't unify Int and String\n *expected: \\(× A A\\)\n *given: \\(× Int String\\)") + +(typecheck-fail (ann (accept-A×A (tup 8 "ate")) : (× String String)) + #:with-msg "expected: \\(× String String\\)\n *given: \\(× Int String\\)") + diff --git a/typed-lang-builder/examples/tests/mlish/ary.mlish b/typed-lang-builder/examples/tests/mlish/ary.mlish @@ -0,0 +1,26 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; test vectors and for loops +(define (main [args : (Vector String)] -> (× Int Int)) + (let* ([n (if (zero? (vector-length args)) + 1 + (string->number (vector-ref args 0)))] + [x (make-vector n 0)] + [y (make-vector n 0)] + [last (sub1 n)]) + (begin + (for ([i (in-range n)]) + (vector-set! x i (add1 i))) + (for* ([k (in-range 1000)] + [i (in-range last -1 -1)]) + (vector-set! y i (+ (vector-ref x i) (vector-ref y i)))) + (tup (vector-ref y 0) + (vector-ref y last))))) + +(check-type (main (vector "100")) + : (× Int Int) -> (tup 1000 100000)) +(check-type (main (vector "1000")) + : (× Int Int) -> (tup 1000 1000000)) +(check-type (main (vector "10000")) + : (× Int Int) -> (tup 1000 10000000)) diff --git a/tapl/tests/mlish/bg/README.md b/typed-lang-builder/examples/tests/mlish/bg/README.md diff --git a/typed-lang-builder/examples/tests/mlish/bg/basics-general.mlish b/typed-lang-builder/examples/tests/mlish/bg/basics-general.mlish @@ -0,0 +1,59 @@ +#lang s-exp "../../../mlish.rkt" + +(define-type (List X) + Nil + (Cons X (List X))) +(define-type (** X Y) + (Pair X Y)) +(define-type Bool + True + False) + +(define (map [f : (→ A B)] [x* : (List A)] → (List B)) + (match x* with + [Nil -> Nil] + [Cons x x* -> (Cons (f x) (map f x*))])) + +(define (append [x* : (List A)] [y* : (List A)] → (List A)) + (match x* with + [Nil -> y*] + [Cons x x* -> (Cons x (append x* y*))])) + +(define (fst [xy : (** A B)] → A) + (match xy with + [Pair x y -> x])) + +(define (snd [xy : (** A B)] → B) + (match xy with + [Pair x y -> y])) + +(define (member [x* : (List A)] [y : A] → Bool) + (match x* with + [Nil -> False] + [Cons x x* -> + (if (equal? x y) True (member x* y))])) + +(define (foldl [f : (→ A B A)] [acc : A] [x* : (List B)] → A) + (match x* with + [Nil -> acc] + [Cons x x* -> (foldl f (f acc x) x*)])) + +(define (foldr [f : (→ A B B)] [x* : (List A)] [acc : B] → B) + (match x* with + [Nil -> acc] + [Cons x x* -> (f x (foldr f x* acc))])) + +(define (filter [f : (→ A Bool)] [x* : (List A)] → (List A)) + (foldr (λ ([x : A] [acc : (List A)]) (match (f x) with [True -> (Cons x acc)] [False -> acc])) + x* + Nil)) + +(define (sum [x* : (List Float)] → Float) + (foldl fl+ (exact->inexact 0) x*)) + +(define (reverse [x* : (List A)] → (List A)) + (foldl (λ ([x* : (List A)] [x : A]) (Cons x x*)) Nil x*)) + +(provide-type List Nil Cons ** Pair Bool True False) + +(provide map append fst snd member foldl foldr filter sum reverse) diff --git a/typed-lang-builder/examples/tests/mlish/bg/basics.mlish b/typed-lang-builder/examples/tests/mlish/bg/basics.mlish @@ -0,0 +1,370 @@ +#lang s-exp "../../../mlish.rkt" +(require "../../rackunit-typechecking.rkt") +(require "basics-general.mlish") +(require-typed map append fst snd member foldl foldr filter sum reverse + #:from "basics-general.mlish") + +;; ============================================================================= +;; http://www.cs.cornell.edu/courses/cs3110/2011fa/hw/ps1/ps1.html + +(define (fn-list [f* : (List (→ A A))] [a : A] → A) + (match f* with + [Nil -> a] + [Cons f f* -> (fn-list f* (f a))])) + +(check-type + (fn-list (Cons (λ ([x : Int]) (+ x 1)) (Cons (λ ([x : Int]) (* x 2)) Nil)) 4) + : Int + ⇒ 10) + +;; ----------------------------------------------------------------------------- + +(define (count-letters/one [s : String] [c : Char] → Int) + (for/sum ([i (in-range (string-length s))]) + (if (equal? (string-ref s i) c) + 1 + 0))) + +(define (count-letters [s* : (List String)] [c : Char] → Int) + (match s* with + [Nil -> 0] + [Cons s s* -> (+ (count-letters/one s c) + (count-letters s* c))])) + +(check-type + (count-letters (Cons "OCaml" (Cons "Is" (Cons "Alot" (Cons "Better" (Cons "Than" (Cons "Java" Nil)))))) (string-ref "a" 0)) + : Int + ⇒ 4) + +;; ----------------------------------------------------------------------------- + +(define (flatten [x** : (List (List A))] → (List A)) + (match x** with + [Nil -> Nil] + [Cons x* x** -> (append x* (flatten x**))])) + +(define (insert [x : A] → (→ (List A) (List (List A)))) + (λ ([x* : (List A)]) + (Cons (Cons x x*) + (match x* with + [Nil -> Nil] + [Cons y y* -> (map (λ ([z* : (List A)]) (Cons y z*)) + ((insert x) y*))])))) + +(define (permutations [x* : (List A)] → (List (List A))) + (match x* with + [Nil -> (Cons Nil Nil)] + [Cons x x* -> (flatten (map (insert x) (permutations x*)))])) + +(check-type + (permutations Nil) + : (List (List Int)) + ⇒ (Cons Nil Nil)) + +(check-type + (permutations (Cons 1 Nil)) + : (List (List Int)) + ⇒ (Cons (Cons 1 Nil) Nil)) + +(check-type + (permutations (Cons 1 (Cons 2 Nil))) + : (List (List Int)) + ⇒ (Cons (Cons 1 (Cons 2 Nil)) (Cons (Cons 2 (Cons 1 Nil)) Nil))) + +(check-type + (permutations (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List (List Int)) + ⇒ (Cons (Cons 1 (Cons 2 (Cons 3 Nil))) + (Cons (Cons 2 (Cons 1 (Cons 3 Nil))) + (Cons (Cons 2 (Cons 3 (Cons 1 Nil))) + (Cons (Cons 1 (Cons 3 (Cons 2 Nil))) + (Cons (Cons 3 (Cons 1 (Cons 2 Nil))) + (Cons (Cons 3 (Cons 2 (Cons 1 Nil))) + Nil))))))) + +;; ============================================================================= +;; http://www.cs.cornell.edu/courses/cs3110/2011sp/hw/ps1/ps1.htm + +(define (split [ab* : (List (** A B))] → (** (List A) (List B))) + (match ab* with + [Nil -> (Pair Nil Nil)] + [Cons ab ab* -> + (match ab with + [Pair a b -> + (match (split ab*) with + [Pair a* b* -> + (Pair (Cons a a*) + (Cons b b*))])])])) + +(check-type + (split Nil) + : (** (List Int) (List Int)) + ⇒ (Pair Nil Nil)) + +(check-type + (split (Cons (Pair 1 2) (Cons (Pair 3 4) Nil))) + : (** (List Int) (List Int)) + ⇒ (Pair (Cons 1 (Cons 3 Nil)) + (Cons 2 (Cons 4 Nil)))) + +(check-type + (split (Cons (Pair 1 "one") (Cons (Pair 2 "two") (Cons (Pair 3 "three") Nil)))) + : (** (List Int) (List String)) + ⇒ (Pair (Cons 1 (Cons 2 (Cons 3 Nil))) + (Cons "one" (Cons "two" (Cons "three" Nil))))) + +;; ----------------------------------------------------------------------------- + +(define (combine [a*b* : (** (List A) (List B))] → (List (** A B))) + (match a*b* with + [Pair a* b* -> + (match a* with + [Nil -> + (match b* with + [Nil -> + Nil] + [Cons b b* -> + Nil])] ;; Error + [Cons a a* -> + (match b* with + [Nil -> + Nil] ;; Error + [Cons b b* -> + (Cons (Pair a b) (combine (Pair a* b*)))])])])) + +(check-type + (combine (Pair Nil Nil)) + : (List (** Int Int)) + ⇒ Nil) + +(check-type + (combine (Pair (Cons 1 (Cons 2 Nil)) (Cons 3 (Cons 4 Nil)))) + : (List (** Int Int)) + ⇒ (Cons (Pair 1 3) (Cons (Pair 2 4) Nil))) + +(check-type + (combine (split (Cons (Pair 1 "one") (Cons (Pair 2 "two") (Cons (Pair 3 "three") Nil))))) + : (List (** Int String)) + ⇒ (Cons (Pair 1 "one") (Cons (Pair 2 "two") (Cons (Pair 3 "three") Nil)))) + +;; ----------------------------------------------------------------------------- + +(define (convolve [x* : (List Float)] [y* : (List Float)] → Float) + (sum + (map (λ ([xy : (** Float Float)]) (fl* (fst xy) (snd xy))) + (combine (Pair x* (reverse y*)))))) + +(check-type + (convolve (Cons 1.0 (Cons 2.0 (Cons 3.0 Nil))) (Cons 1.0 (Cons 2.0 (Cons 3.0 Nil)))) + : Float + ⇒ (fl+ (fl+ (fl* 1.0 3.0) (fl* 2.0 2.0)) (fl* 3.0 1.0))) + +;; ----------------------------------------------------------------------------- + +(define (mc [n : Int] [f : (→ A A)] [x : A] → A) + (for/fold ([x x]) + ([_i (in-range n)]) + (f x))) + +(check-type + (mc 3000 (λ ([n : Int]) (+ n 1)) 3110) + : Int + ⇒ 6110) + +(define (square [n : Int] → Int) + (* n n)) + +(check-type + (mc 0 square 2) + : Int + ⇒ 2) + +(check-type + (mc 2 square 2) + : Int + ⇒ 16) + +(check-type + (mc 3 square 2) + : Int + ⇒ 256) + +;; ----------------------------------------------------------------------------- + +(define (successor [mcn : (→ (→ A A) A A)] → (→ (→ A A) A A)) + (λ ([f : (→ A A)] [x : A]) + (f (mcn f x)))) + +(check-type + ((successor (λ ([f : (→ Int Int)] [x : Int]) (mc 0 f x))) square 2) + : Int + ⇒ 4) + +(check-type + ((successor (successor (λ ([f : (→ Int Int)] [x : Int]) (mc 0 f x)))) square 2) + : Int + ⇒ 16) + +(check-type + ((successor (successor (successor (λ ([f : (→ Int Int)] [x : Int]) (mc 0 f x))))) square 2) + : Int + ⇒ 256) + +;; # (mc 3 successor) (mc 0) square 2;; + +;; ============================================================================= +;; === sorting + +;; ----------------------------------------------------------------------------- +;; --- mergesort + +(define (split2 [x* : (List A)] → (** (List A) (List A))) + (match x* with + [Nil -> (Pair Nil Nil)] + [Cons h t -> + (match t with + [Nil -> (Pair (Cons h Nil) Nil)] + [Cons h2 x* -> + (match (split2 x*) with + [Pair x* y* -> + (Pair (Cons h x*) (Cons h2 y*))])])])) + +(define (merge [x*+y* : (** (List Int) (List Int))] → (List Int)) + (match x*+y* with + [Pair xx* yy* -> + (match xx* with + [Nil -> yy*] + [Cons x x* -> + (match yy* with + [Nil -> xx*] + [Cons y y* -> + (if (<= x y) + (Cons x (merge (Pair x* yy*))) + (Cons y (merge (Pair xx* y*))))])])])) + +(define (mergesort [x* : (List Int)] → (List Int)) + (match x* with + [Nil -> Nil] + [Cons h t -> + (match t with + [Nil -> (Cons h Nil)] + [Cons h2 t2 -> + (match (split2 x*) with + [Pair x* y* -> + (merge (Pair (mergesort x*) (mergesort y*)))])])])) + +(check-type (mergesort Nil) : (List Int) ⇒ Nil) + +(check-type + (mergesort (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) + : (List Int) + ⇒ (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) + +(check-type + (mergesort (Cons 3 (Cons 7 (Cons 93 (Cons 0 (Cons 2 Nil)))))) + : (List Int) + ⇒ (Cons 0 (Cons 2 (Cons 3 (Cons 7 (Cons 93 Nil)))))) + +;; ----------------------------------------------------------------------------- +;; --- quicksort + +(define (quicksort [x* : (List Int)] → (List Int)) + (match x* with + [Nil -> x*] + [Cons h t -> + (match t with + [Nil -> x*] + [Cons h2 t2 -> + (append + (quicksort (filter (λ ([y : Int]) (if (<= y h) True False)) t)) + (append + (Cons h Nil) + (quicksort (filter (λ ([y : Int]) (if (> y h) True False)) t))))])])) + +(check-type (quicksort Nil) : (List Int) ⇒ Nil) + +(check-type + (quicksort (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) + : (List Int) + ⇒ (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))) + +(check-type + (quicksort (Cons 3 (Cons 7 (Cons 93 (Cons 0 (Cons 2 Nil)))))) + : (List Int) + ⇒ (Cons 0 (Cons 2 (Cons 3 (Cons 7 (Cons 93 Nil)))))) + +;; ============================================================================= +;; === CPS + +;; ----------------------------------------------------------------------------- +;; --- factorial + +(define (fact [n : Int] → Int) + (if (< n 2) + 1 + (* n (fact (- n 1))))) + +(define (range-aux [n : Int] → (List Int)) + (if (= 0 n) + (Cons n Nil) + (Cons n (range-aux (- n 1))))) + +(define (range [n : Int] → (List Int)) + (if (<= n 0) + Nil + (reverse (range-aux (- n 1))))) + +(define (fact-acc [n : Int] → Int) + (foldl (λ ([acc : Int] [n : Int]) (* n acc)) 1 (map (λ ([n : Int]) (+ n 1)) (range n)))) + +(define (fact-cps-aux [n : Int] [k : (→ Int Int)] → Int) + (if (< n 2) + (k 1) + (fact-cps-aux (- n 1) (λ ([m : Int]) (k (* n m)))))) + +(define (fact-cps [n : Int] → Int) + (fact-cps-aux n (λ ([x : Int]) x))) + +(check-type (fact 0) : Int ⇒ 1) +(check-type (fact 1) : Int ⇒ 1) +(check-type (fact 2) : Int ⇒ 2) +(check-type (fact 3) : Int ⇒ 6) +(check-type (fact 4) : Int ⇒ 24) +(check-type (fact 5) : Int ⇒ 120) + +(check-type (fact-acc 0) : Int ⇒ 1) +(check-type (fact-acc 1) : Int ⇒ 1) +(check-type (fact-acc 2) : Int ⇒ 2) +(check-type (fact-acc 3) : Int ⇒ 6) +(check-type (fact-acc 4) : Int ⇒ 24) +(check-type (fact-acc 5) : Int ⇒ 120) + +(check-type (fact-cps 0) : Int ⇒ 1) +(check-type (fact-cps 1) : Int ⇒ 1) +(check-type (fact-cps 2) : Int ⇒ 2) +(check-type (fact-cps 3) : Int ⇒ 6) +(check-type (fact-cps 4) : Int ⇒ 24) +(check-type (fact-cps 5) : Int ⇒ 120) + +;; ----------------------------------------------------------------------------- +;; --- map + +(define (map-cps-aux [f : (→ A B)] [x* : (List A)] [k : (→ (List B) (List B))] → (List B)) + (match x* with + [Nil -> (k Nil)] + [Cons x x* -> + (map-cps-aux f x* (λ ([b* : (List B)]) (k (Cons (f x) b*))))])) + +(define (map-cps [f : (→ A B)] [x* : (List A)] → (List B)) + (map-cps-aux f x* (λ ([x : (List B)]) x))) + +(check-type + (map-cps (λ ([x : Int]) (+ x 2)) (Cons 2 (Cons 4 (Cons 8 Nil)))) + : (List Int) + ⇒ (Cons 4 (Cons 6 (Cons 10 Nil)))) + +(check-type + (map-cps exact->inexact (Cons 2 (Cons 4 (Cons 8 Nil)))) + : (List Float) + ⇒ (Cons 2.0 (Cons 4.0 (Cons 8.0 Nil)))) + diff --git a/typed-lang-builder/examples/tests/mlish/bg/basics2.mlish b/typed-lang-builder/examples/tests/mlish/bg/basics2.mlish @@ -0,0 +1,138 @@ +#lang s-exp "../../../mlish.rkt" +(require "../../rackunit-typechecking.rkt") +(require "basics-general.mlish") +(require-typed append filter foldr foldl reverse snd member + #:from "basics-general.mlish") + + +;; ============================================================================= +;; http://www.cs.cornell.edu/courses/cs3110/2011fa/hw/ps1/ps1.html +;; continued + +;; ----------------------------------------------------------------------------- + +(define (map-index [is* : (List (** Int (List String)))] → (List (** String Int))) + (match is* with + [Nil -> Nil] + [Cons hd tl -> + (match hd with + [Pair i s* -> + (append (foldr (λ ([s : String] [acc : (List (** String Int))]) (Cons (Pair s i) acc)) + s* + Nil) + (map-index tl))])])) + +(check-type + (map-index Nil) + : (List (** String Int)) + ⇒ Nil) + +(check-type + (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) Nil)) + : (List (** String Int)) + ⇒ (Cons (Pair "a" 0) (Cons (Pair "b" 0) (Cons (Pair "c" 0) Nil)))) + +(check-type + (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) + (Cons (Pair 1 (Cons "d" (Cons "e" Nil))) + Nil))) + : (List (** String Int)) + ⇒ (Cons (Pair "a" 0) (Cons (Pair "b" 0) (Cons (Pair "c" 0) (Cons (Pair "d" 1) (Cons (Pair "e" 1) Nil)))))) + +(define (reduce-index [si* : (List (** String Int))] → (List (** String (List Int)))) + (snd (foldr + (λ ([si : (** String Int)] [acc : (** (List String) (List (** String (List Int))))]) + (match si with + [Pair s i -> + (match acc with + [Pair seen out -> + (match (member seen s) with + [True -> + (Pair + seen + (foldr + (λ ([si* : (** String (List Int))] [acc : (List (** String (List Int)))]) + (match si* with + [Pair s2 i* -> + (if (equal? s s2) + (match (member i* i) with + [True -> (Cons si* acc)] + [False -> (Cons (Pair s2 (Cons i i*)) acc)]) + (Cons si* acc))])) + out + Nil))] + [False -> + (Pair + (Cons s seen) + (Cons (Pair s (Cons i Nil)) out))])])])) + si* + (Pair Nil Nil)))) + + +(check-type + (reduce-index Nil) + : (List (** String (List Int))) + ⇒ Nil) + +(check-type + (reduce-index + (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) + (Cons (Pair 1 (Cons "d" (Cons "e" Nil))) + Nil)))) + : (List (** String (List Int))) + ⇒ (Cons (Pair "a" (Cons 0 Nil)) + (Cons (Pair "b" (Cons 0 Nil)) + (Cons (Pair "c" (Cons 0 Nil)) + (Cons (Pair "d" (Cons 1 Nil)) + (Cons (Pair "e" (Cons 1 Nil)) + Nil)))))) + +(check-type + (reduce-index + (map-index (Cons (Pair 0 (Cons "a" (Cons "b" (Cons "c" Nil)))) + (Cons (Pair 1 (Cons "a" (Cons "b" Nil))) + Nil)))) + : (List (** String (List Int))) + ⇒ (Cons (Pair "c" (Cons 0 Nil)) + (Cons (Pair "a" (Cons 0 (Cons 1 Nil))) + (Cons (Pair "b" (Cons 0 (Cons 1 Nil))) + Nil)))) + +;; For every string, get all integers that refer to the string +(define (make-index [is* : (List (** Int (List String)))] + → (List (** String (List Int)))) + (reduce-index (map-index is*))) + +(check-type + (make-index Nil) + : (List (** String (List Int))) + ⇒ Nil) + +(check-type + (make-index (Cons (Pair 1 (Cons "ocaml" (Cons "is" (Cons "fun" (Cons "because" (Cons "fun" (Cons "is" (Cons "a" (Cons "keyword" Nil))))))))) + (Cons (Pair 2 (Cons "page" (Cons "2" (Cons "intentionally" (Cons "left" (Cons "blank" Nil)))))) + (Cons (Pair 3 (Cons "the" (Cons "quick" (Cons "brown" (Cons "fox" (Cons "jumped" (Cons "over" (Cons "the" (Cons "lazy" (Cons "dog" Nil)))))))))) + (Cons (Pair 4 (Cons "is" (Cons "this" (Cons "the" (Cons "end" Nil))))) Nil))))) + : (List (** String (List Int))) + ⇒ (Cons (Pair "ocaml" (Cons 1 Nil)) + (Cons (Pair "because" (Cons 1 Nil)) + (Cons (Pair "fun" (Cons 1 Nil)) + (Cons (Pair "a" (Cons 1 Nil)) + (Cons (Pair "keyword" (Cons 1 Nil)) + (Cons (Pair "page" (Cons 2 Nil)) + (Cons (Pair "2" (Cons 2 Nil)) + (Cons (Pair "intentionally" (Cons 2 Nil)) + (Cons (Pair "left" (Cons 2 Nil)) + (Cons (Pair "blank" (Cons 2 Nil)) + (Cons (Pair "quick" (Cons 3 Nil)) + (Cons (Pair "brown" (Cons 3 Nil)) + (Cons (Pair "fox" (Cons 3 Nil)) + (Cons (Pair "jumped" (Cons 3 Nil)) + (Cons (Pair "over" (Cons 3 Nil)) + (Cons (Pair "lazy" (Cons 3 Nil)) + (Cons (Pair "dog" (Cons 3 Nil)) + (Cons (Pair "is" (Cons 1 (Cons 4 Nil))) + (Cons (Pair "this" (Cons 4 Nil)) + (Cons (Pair "the" (Cons 3 (Cons 4 Nil))) + (Cons (Pair "end" (Cons 4 Nil)) Nil)))))))))))))))))))))) + diff --git a/typed-lang-builder/examples/tests/mlish/bg/huffman.mlish b/typed-lang-builder/examples/tests/mlish/bg/huffman.mlish @@ -0,0 +1,278 @@ +#lang s-exp "../../../mlish.rkt" +(require "../../rackunit-typechecking.rkt") + +;; Huffman trees from SICP + +;; ============================================================================= +;; === Sets of Symbols + +(define-type-alias Symbol String) + +;; Set of strings +(define-type Symbol* + [Empty] + [Singleton String] + [Join String Symbol* Symbol*]) + +(define (empty → Symbol*) + Empty) + +(define (singleton [s : String] → Symbol*) + (Singleton s)) + +(define (insert [s* : Symbol*] [s1 : String] → Symbol*) + (match s* with + [Empty -> (singleton s1)] + [Singleton s2 -> + (if (string<=? s1 s2) + (if (string=? s1 s2) + s* + (Join s2 (singleton s1) (empty))) + (Join s1 (singleton s2) (empty)))] + [Join s2 l* r* -> + (if (string<=? s1 s2) + (if (string=? s1 s2) + s* + (Join s2 (insert l* s1) r*)) + (Join s2 l* (insert r* s1)))])) + +(define (union [s1 : Symbol*] [s2 : Symbol*] → Symbol*) + (match s1 with + [Empty -> s2] + [Singleton s -> (insert s2 s)] + [Join s l* r* -> (union l* (union r* (insert s2 s)))])) + +(define (contains [s* : Symbol*] [s : Symbol] → Bool) + (match s* with + [Empty -> #f] + [Singleton s2 -> (string=? s s2)] + [Join s2 l* r* -> + (if (string<=? s s2) + (if (string=? s s2) + #t + (contains l* s)) + (contains r* s))])) + +;; ----------------------------------------------------------------------------- + +(check-type + (insert (empty) "hello") + : Symbol* + ⇒ (singleton "hello")) + +(check-type + (insert (insert (empty) "a") "b") + : Symbol* + ⇒ (Join "b" (singleton "a") (empty))) + +(check-type + (insert (insert (empty) "b") "a") + : Symbol* + ⇒ (Join "b" (singleton "a") (empty))) + +(check-type + (insert (insert (insert (empty) "a") "b") "c") + : Symbol* + ⇒ (Join "b" (singleton "a") (singleton "c"))) + +(check-type + (insert (insert (insert (empty) "c") "b") "a") + : Symbol* + ⇒ (Join "c" (Join "b" (singleton "a") (empty)) (empty))) + +(check-type + (union + (insert (insert (insert (empty) "c") "b") "a") + (insert (insert (insert (empty) "a") "b") "c")) + : Symbol* + ⇒ (Join "b" (singleton "a") (singleton "c"))) + +;; ----------------------------------------------------------------------------- + +(define-type (List A) + [⊥] + [∷ A (List A)]) + +(define-type-alias SymbolList (List Symbol)) + +(define (list [x : A] → (List A)) + (∷ x ⊥)) + +(define (append [x* : (List A)] [y* : (List A)] → (List A)) + (match x* with + [⊥ -> y*] + [∷ x x* -> + (∷ x (append x* y*))])) + +(define (length [x* : (List A)] → Int) + (match x* with + [⊥ -> 0] + [∷ x x* -> (+ 1 (length x*))])) + +;; ----------------------------------------------------------------------------- + +(define-type Bit O I) +(define-type-alias Bit* (List Bit)) + +;; ----------------------------------------------------------------------------- + +(define-type HTree + [Leaf String Int] ;; Symbol, Weight + [Node HTree HTree Symbol* Int] ;; Left, Right, Symbols, Weight +) + +(define (symbols [h : HTree] → Symbol*) + (match h with + [Leaf s w -> (singleton s)] + [Node lh rh s* w -> s*])) + +(define (weight [h : HTree] → Int) + (match h with + [Leaf s w -> w] + [Node l r s w -> w])) + +(define (make-code-tree [left : HTree] [right : HTree] → HTree) + (Node left right + (union (symbols left) (symbols right)) + (+ (weight left) (weight right)))) + +(define (decode-aux [bits : Bit*] [root : HTree] [current-branch : HTree] → SymbolList) + (match bits with + [⊥ -> + ⊥] + [∷ b bit* -> + (match (choose-branch b current-branch) with + [Leaf s w -> + (∷ s (decode-aux bit* root root))] + [Node l r s* w -> + (decode-aux bit* root (Node l r s* w))])])) + +(define (decode [bits : Bit*] [tree : HTree] → SymbolList) + (decode-aux bits tree tree)) + +(define (choose-branch [bit : Bit] [branch : HTree] → HTree) + (match branch with + [Leaf s w -> + ;; Error + (Leaf "ERROR" 0)] + [Node l* r* s* w -> + (match bit with + [O -> l*] + [I -> r*])])) + +(define-type-alias HTreeSet (List HTree)) + +(define (adjoin-set [x : HTree] [set : HTreeSet] → HTreeSet) + (match set with + [⊥ -> (list x)] + [∷ y y* -> + (if (< (weight x) (weight y)) + (∷ x set) + (∷ y (adjoin-set x y*)))])) + +(define (make-leaf-set [pair* : (List (× Symbol Int))] → HTreeSet) + (match pair* with + [⊥ -> ⊥] + [∷ pair pair* -> + (match pair with + [s i -> + (adjoin-set (Leaf s i) (make-leaf-set pair*))])])) + +(check-type + (make-leaf-set (∷ (tup "A" 4) + (∷ (tup "B" 2) + (∷ (tup "C" 1) + (∷ (tup "D" 1) + ⊥))))) + : HTreeSet + ⇒ (∷ (Leaf "D" 1) + (∷ (Leaf "C" 1) + (∷ (Leaf "B" 2) + (∷ (Leaf "A" 4) + ⊥))))) + +(define sample-tree + (make-code-tree + (Leaf "A" 4) + (make-code-tree + (Leaf "B" 2) + (make-code-tree + (Leaf "D" 1) + (Leaf "C" 1))))) + +(define sample-message + (∷ O (∷ I (∷ I (∷ O (∷ O (∷ I (∷ O (∷ I (∷ O (∷ I (∷ I (∷ I (∷ I (∷ O ⊥))))))))))))))) + +(check-type + (decode sample-message sample-tree) + : SymbolList + ⇒ (∷ "A" (∷ "D" (∷ "A" (∷ "B" (∷ "B" (∷ "C" (∷ "B" ⊥)))))))) + +(define (encode [message : SymbolList] [tree : HTree] → Bit*) + (match message with + [⊥ -> ⊥] + [∷ m m* -> + (append (encode-symbol m tree) (encode m* tree))])) + +(define (contains-symbol [s : Symbol] [tree : HTree] → Bool) + (contains (symbols tree) s)) + +;; Undefined if symbol is not in tree. Be careful! +(define (encode-symbol [s : Symbol] [tree : HTree] → Bit*) + (match tree with + [Leaf s w -> ⊥] + [Node l* r* s* w -> + (if (contains-symbol s l*) + (∷ O (encode-symbol s l*)) + (∷ I (encode-symbol s r*)))])) + +(check-type + (encode (decode sample-message sample-tree) sample-tree) + : Bit* + ⇒ sample-message) + +(define-type-alias Frequency Int) +(define (generate-huffman-tree [pair* : (List (× Symbol Frequency))] → HTree) + (successive-merge (make-leaf-set pair*))) + +(define (successive-merge [tree* : HTreeSet] → HTree) + (match tree* with + [⊥ -> (Leaf "ERROR" 0)] + [∷ t t* -> + (match t* with + [⊥ -> t] + [∷ t2 t* -> + (successive-merge (adjoin-set (make-code-tree t t2) t*))])])) + +(define rock-pair* + (∷ (tup "A" 2) + (∷ (tup "BOOM" 2) + (∷ (tup "GET" 2) + (∷ (tup "JOB" 2) + (∷ (tup "NA" 16) + (∷ (tup "SHA" 3) + (∷ (tup "YIP" 9) + (∷ (tup "WAH" 1) + ⊥))))))))) + +(define rock-tree (generate-huffman-tree rock-pair*)) + +(define rock-message + (∷ "GET" (∷ "A" (∷ "JOB" + (∷ "SHA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" + (∷ "GET" (∷ "A" (∷ "JOB" + (∷ "SHA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" (∷ "NA" + (∷ "WAH" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" (∷ "YIP" + (∷ "SHA" (∷ "BOOM" ⊥))))))))))))))))))))))))))))))))))))) + +(define rock-bit* (encode rock-message rock-tree)) + +(check-type + (decode rock-bit* rock-tree) + : SymbolList + ⇒ rock-message) + +(check-type + (length rock-bit*) + : Int + ⇒ 84) diff --git a/typed-lang-builder/examples/tests/mlish/bg/lambda.mlish b/typed-lang-builder/examples/tests/mlish/bg/lambda.mlish @@ -0,0 +1,95 @@ +#lang s-exp "../../../mlish.rkt" +(require "../../rackunit-typechecking.rkt") + +;; Lambda Calculus interpreter + + +;; Problems: +;; - Cannot use variable in head position of match (gotta exhaust constructors) + +;; ----------------------------------------------------------------------------- + +(define-type Λ + (Var Int) + (Lambda Int Λ) + (App Λ Λ)) + +(define (fresh [e : Λ] → Int) + (match e with + [Var i -> (+ i 1)] + [Lambda i e -> (+ i (fresh e))] + [App e1 e2 -> (+ 1 (+ (fresh e1) (fresh e2)))])) + +(define (subst [e : Λ] [i : Int] [v : Λ] → Λ) + (match e with + [Var j -> + (if (= i j) + v + e)] + [Lambda j e2 -> + (if (= i j) + e + (Lambda j (subst e2 i v)))] + [App e1 e2 -> + (App (subst e1 i v) (subst e2 i v))])) + +(define (simpl-aux [e : Λ] [i : Int] → (× Int Λ)) + (match e with + [Var j -> (tup i (Var j))] + [Lambda j e -> + (match (simpl-aux (subst e j (Var i)) (+ i 1)) with + [k e2 -> + (tup k (Lambda i e2))])] + [App e1 e2 -> + (match (simpl-aux e1 i) with + [j e1 -> + (match (simpl-aux e2 j) with + [k e2 -> + (tup k (App e1 e2))])])])) + +(define (simpl [e : Λ] → Λ) + (match (simpl-aux e 0) with + [i e2 -> e2])) + +(define (eval [e : Λ] → Λ) + (match e with + [Var i -> (Var i)] + [Lambda i e1 -> e] + [App e1 e2 -> + (match (eval e1) with + [Var i -> (Var -1)] + [App e1 e2 -> (Var -2)] + [Lambda i e -> + (match (tup 0 (eval e2)) with + [zero v2 -> + (eval (subst e i (subst v2 i (Var (+ (fresh e) (fresh v2))))))])])])) + +;; ----------------------------------------------------------------------------- + +(define I (Lambda 0 (Var 0))) +(define K (Lambda 0 (Lambda 1 (Var 0)))) +(define S (Lambda 0 (Lambda 1 (Lambda 2 (App (App (Var 0) (Var 2)) (App (Var 1) (Var 2))))))) +(define false (App S K)) + +;; ----------------------------------------------------------------------------- + +(check-type + (eval I) + : Λ + ⇒ I) + +(check-type + (eval (App I I)) + : Λ + ⇒ I) + +(check-type + (eval (App (App K (Var 2)) (Var 3))) + : Λ + ⇒ (Var 2)) + +(check-type + (eval (App (App false (Var 2)) (Var 3))) + : Λ + ⇒ (Var 3)) + diff --git a/typed-lang-builder/examples/tests/mlish/bg/monad.mlish b/typed-lang-builder/examples/tests/mlish/bg/monad.mlish @@ -0,0 +1,122 @@ +#lang s-exp "../../../mlish.rkt" +(require "../../rackunit-typechecking.rkt") + +(define-type (Option A) + [None] + [Some A]) + +;; ----------------------------------------------------------------------------- + +(define-type (List a) + [Nil] + [∷ a (List a)]) + +(define (foldl [f : (→ A B A)] [acc : A] [x* : (List B)] → A) + (match x* with + [Nil -> acc] + [∷ h t -> (foldl f (f acc h) t)])) + +(define (reverse [x* : (List A)] → (List A)) + (foldl (λ ([acc : (List A)] [x : A]) (∷ x acc)) Nil x*)) + +;; ============================================================================= +;; === BatchedQueue + +(define-type (BatchedQueue A) + [BQ (List A) (List A)]) + +(define (bq-check [f : (List A)] [r : (List A)] → (BatchedQueue A)) + (match f with + [Nil -> (BQ (reverse r) Nil)] + [∷ h t -> (BQ f r)])) + +(define (bq-empty → (BatchedQueue A)) + (BQ Nil Nil)) + +(define (bq-isEmpty [bq : (BatchedQueue A)] → Bool) + (match bq with + [BQ f r -> + (match f with + [Nil -> #t] + [∷ h t -> #f])])) + +(define (bq-snoc [bq : (BatchedQueue A)] [x : A] → (BatchedQueue A)) + (match bq with + [BQ f r -> (bq-check f (∷ x r))])) + +(define (bq-head [bq : (BatchedQueue A)] → (Option A)) + (match bq with + [BQ f r -> + (match f with + [Nil -> None] + [∷ h t -> (Some h)])])) + +(define (bq-tail [bq : (BatchedQueue A)] → (Option (BatchedQueue A))) + (match bq with + [BQ f* r* -> + (match f* with + [Nil -> None] + [∷ x f* -> + (Some (bq-check f* r*))])])) + +(define (list->bq [x* : (List A)] → (BatchedQueue A)) + (foldl + (λ ([q : (BatchedQueue A)] [x : A]) (bq-snoc q x)) + (bq-empty) x*)) + +;; ----------------------------------------------------------------------------- + +(define digit* + (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))))))) + +(check-type digit* : (List Int)) + +(define sample-bq + (list->bq digit*)) + +(check-type sample-bq : (BatchedQueue Int)) + +(check-type (Some sample-bq) : (Option (BatchedQueue Int))) + +(define (>> [f : (→ A (Option B))] [x : (Option A)] → (Option B)) + (match x with + [None -> None] + [Some y -> (f y)])) + +(check-type >> : (→/test (→ X (Option Y)) (Option X) (Option Y))) + +(check-type (bq-tail sample-bq) : (Option (BatchedQueue Int))) + +;; can't pass polymorphic fn? need to inst first +(check-type (>> (inst bq-tail Int) (Some sample-bq)) + : (Option (BatchedQueue Int))) + +;(ann (>> bq-tail (Some sample-bq)) : (Option (BatchedQueue Int))) + +(define intbq-tail (inst bq-tail Int)) + +(check-type intbq-tail : + (→/test (BatchedQueue Int) (Option (BatchedQueue Int)))) + +(check-type (>> intbq-tail (Some sample-bq)) + : (Option (BatchedQueue Int))) + +(check-type (inst bq-head Int) : (→/test (BatchedQueue Int) (Option Int))) + +(define bq-tails-result + (>> intbq-tail (>> intbq-tail (>> intbq-tail (Some sample-bq))))) + +(check-type bq-tails-result : (Option (BatchedQueue Int)) + ⇒ (Some (BQ (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))) Nil))) + +(check-type (>> (inst bq-head Int) bq-tails-result) : (Option Int) -> (Some 4)) + +;; check match2 nested datatype bug +(check-type + (match bq-tails-result with + [None -> None] + [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4)) +(check-type + (match2 bq-tails-result with + [None -> None] + [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4)) diff --git a/typed-lang-builder/examples/tests/mlish/bg/okasaki.mlish b/typed-lang-builder/examples/tests/mlish/bg/okasaki.mlish @@ -0,0 +1,1654 @@ +#lang s-exp "../../../mlish.rkt" +(require "../../rackunit-typechecking.rkt") + +;; TODO +;; - cannot inst polymorphic function `bq-empty` +;; - cannot inst `(BQ (Nil {A}) (Nil {A}))` +;; - cannot use bq-snoc directly in a foldl (need wrapper λ) + +;; ----------------------------------------------------------------------------- + +(define-type (Option A) + [None] + [Some A]) + +;; ----------------------------------------------------------------------------- + +(define (div (n1 : Int) (n2 : Int) → Int) + (if (< n1 n2) + 0 + (+ 1 (div (- n1 n2) n2)))) + +(define (mod (n1 : Int) (n2 : Int) → Int) + (if (< n1 n2) + n1 + (mod (- n1 n2) n2))) + +;; ----------------------------------------------------------------------------- + +(define-type (List a) + [Nil] + [∷ a (List a)]) + +(define (foldl [f : (→ A B A)] [acc : A] [x* : (List B)] → A) + (match x* with + [Nil -> acc] + [∷ h t -> (foldl f (f acc h) t)])) + +(define (reverse [x* : (List A)] → (List A)) + (foldl (λ ([acc : (List A)] [x : A]) (∷ x acc)) Nil x*)) + +(define (append [x* : (List A)] [y* : (List A)] → (List A)) + (match x* with + [Nil -> y*] + [∷ x x* -> + (∷ x (append x* y*))])) + +(define (take [i : Int] [x* : (List A)] → (List A)) + (if (<= i 0) + Nil + (match x* with + [Nil -> Nil] + [∷ h t -> (∷ h (take (- i 1) t))]))) + +(define (drop [i : Int] [x* : (List A)] → (List A)) + (if (<= i 0) + x* + (match x* with + [Nil -> Nil] + [∷ h t -> (drop (- i 1) t)]))) + +;; ============================================================================= +;; === BatchedQueue + +(define-type (BatchedQueue A) + [BQ (List A) (List A)]) + +(define (bq-check [f : (List A)] [r : (List A)] → (BatchedQueue A)) + (match f with + [Nil -> (BQ (reverse r) Nil)] + [∷ h t -> (BQ f r)])) + +(define (bq-empty → (BatchedQueue A)) + (BQ Nil Nil)) + +(define (bq-isEmpty [bq : (BatchedQueue A)] → Bool) + (match bq with + [BQ f r -> + (match f with + [Nil -> #t] + [∷ h t -> #f])])) + +(define (bq-snoc [bq : (BatchedQueue A)] [x : A] → (BatchedQueue A)) + (match bq with + [BQ f r -> (bq-check f (∷ x r))])) + +(define (bq-head [bq : (BatchedQueue A)] → (Option A)) + (match bq with + [BQ f r -> + (match f with + [Nil -> None] + [∷ h t -> (Some h)])])) + +(define (bq-tail [bq : (BatchedQueue A)] → (Option (BatchedQueue A))) + (match bq with + [BQ f* r* -> + (match f* with + [Nil -> None] + [∷ x f* -> + (Some (bq-check f* r*))])])) + +(define (list->bq [x* : (List A)] → (BatchedQueue A)) + (foldl + ;bq-snoc ;; TODO + (λ ([q : (BatchedQueue A)] [x : A]) (bq-snoc q x)) + (bq-empty) x*)) + +;; ----------------------------------------------------------------------------- + +(define digit* + (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))))))) + +(define abc + (∷ "A" (∷ "B" (∷ "C" Nil)))) + +(define def + (∷ "D" (∷ "E" (∷ "F" Nil)))) + +(define sample-bq (list->bq digit*)) + +(check-type + (bq-isEmpty (BQ (Nil {Bool}) (Nil {Bool}))) + ;(bq-isEmpty (bq-empty {Bool})) + ;(bq-isEmpty (BQ (Nil {Bool}) (Nil {Bool}))) ;; TODO + : Bool + ⇒ #t) + +(check-type + (bq-isEmpty sample-bq) + : Bool + ⇒ #f) + +(check-type + (bq-head sample-bq) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (bq-head (bq-snoc sample-bq 10)) + : (Option Int) + ⇒ (Some 1)) + +(define (>> [f : (→ A (Option A))] [x : (Option A)] → (Option A)) + (match x with + [None -> None] + [Some y -> (f y)])) + +(check-type + (match (bq-tail sample-bq) with + [None -> None] + [Some bq -> (bq-head bq)]) + : (Option Int) + ⇒ (Some 2)) + +;; TODO +;(check-type +; (>> bq-head (>> bq-tail (>> bq-tail (>> bq-tail (Some sample-bq))))) +; : (Option Int) +; ⇒ (Some 4)) + +;; ============================================================================= +;; === Bankers Queue + +(define-type (BankersQueue A) + (Bank Int (List A) Int (List A))) + +(define (bank-check [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (BankersQueue A)) + (if (<= lenr lenf) + (Bank lenf f lenr r) + (Bank (+ lenf lenr) (append f (reverse r)) 0 Nil))) + +(define (bank-empty → (BankersQueue A)) + (Bank 0 Nil 0 Nil)) + +(define (bank-isEmpty [bq : (BankersQueue A)] → Bool) + (match bq with + [Bank lenf f lenr r -> (= 0 lenf)])) + +(define (bank-snoc [bq : (BankersQueue A)] [x : A] → (BankersQueue A)) + (match bq with + [Bank lenf f lenr r -> (bank-check lenf f (+ 1 lenr) (∷ x r))])) + +(define (bank-head [bq : (BankersQueue A)] → (Option A)) + (match bq with + [Bank lenf f lenr r -> + (match f with + [Nil -> None] + [∷ h t -> (Some h)])])) + +(define (bank-tail [bq : (BankersQueue A)] → (Option (BankersQueue A))) + (match bq with + [Bank lenf f lenr r -> + (match f with + [Nil -> None] + [∷ h t -> (Some (bank-check (- lenf 1) t lenr r))])])) + +;; ----------------------------------------------------------------------------- + +(define sample-bank + (foldl (λ ([acc : (BankersQueue Int)] [x : Int]) (bank-snoc acc x)) (bank-empty) digit*)) + +(check-type + (bank-isEmpty (Bank 0 (Nil {Int}) 0 (Nil {Int}))) + : Bool + ⇒ #t) + +(check-type + (bank-isEmpty sample-bank) + : Bool + ⇒ #f) + +(check-type + (bank-head sample-bank) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (bank-head (bank-snoc sample-bank 10)) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (match (bank-tail sample-bank) with + [None -> None] + [Some bank -> (bank-head bank)]) + : (Option Int) + ⇒ (Some 2)) + +;; ============================================================================= +;; === Physicists Queue + +(define-type (PhysicistsQueue A) + (PQ (List A) Int (List A) Int (List A))) + +(define (pq-check [w : (List A)] [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (PhysicistsQueue A)) + (if (<= lenr lenf) + (pq-checkw w lenf f lenr r) + (pq-checkw f (+ lenf lenr) (append f (reverse r)) 0 Nil))) + +(define (pq-checkw [w : (List A)] [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (PhysicistsQueue A)) + (match w with + [Nil -> (PQ f lenf f lenr r)] + [∷ h t -> (PQ w lenf f lenr r)])) + +(define (pq-empty → (PhysicistsQueue A)) + (PQ Nil 0 Nil 0 Nil)) + +(define (pq-isEmpty [pq : (PhysicistsQueue A)] → Bool) + (match pq with + [PQ w lenf f lenr r -> + (= lenf 0)])) + +(define (pq-snoc [pq : (PhysicistsQueue A)] [x : A] → (PhysicistsQueue A)) + (match pq with + [PQ w lenf f lenr r -> (pq-check w lenf f (+ 1 lenr) (∷ x r))])) + +(define (pq-head [pq : (PhysicistsQueue A)] → (Option A)) + (match pq with + [PQ w lenf f lenr r -> + (match w with + [Nil -> None] + [∷ w w* -> (Some w)])])) + +(define (pq-tail [pq : (PhysicistsQueue A)] → (Option (PhysicistsQueue A))) + (match pq with + [PQ w lenf f lenr r -> + (match w with + [Nil -> None] + [∷ x w* -> + (match f with + [Nil -> None] ;; Never happens + [∷ f f* -> (Some (pq-check w* (- lenf 1) f* lenr r))])])])) + +;; ----------------------------------------------------------------------------- + +(define sample-pq + (foldl (λ ([acc : (PhysicistsQueue Int)] [x : Int]) (pq-snoc acc x)) (pq-empty) digit*)) + +(check-type + (pq-isEmpty (PQ (Nil {Int}) 0 (Nil {Int}) 0 (Nil {Int}))) + : Bool + ⇒ #t) + +(check-type + (pq-isEmpty sample-pq) + : Bool + ⇒ #f) + +(check-type + (pq-head sample-pq) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (pq-head (pq-snoc sample-pq 10)) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (match (pq-tail sample-pq) with + [None -> None] + [Some pq -> (pq-head pq)]) + : (Option Int) + ⇒ (Some 2)) + +;; ============================================================================= +;; === Hood-Melville Queue + +(define-type (RotationState A) + [Idle] + [Reversing Int (List A) (List A) (List A) (List A)] + [Appending Int (List A) (List A)] + [Done (List A)]) + +(define-type (HoodMelvilleQueue A) + [HM Int (List A) (RotationState A) Int (List A)]) + +(define (hm-exec [rs : (RotationState A)] → (RotationState A)) + (match rs with + [Idle -> rs] + [Done x -> rs] + [Appending ok f* r* -> + (if (= ok 0) + (Done r*) + (match f* with + [Nil -> rs] + [∷ x f* -> + (Appending (- ok 1) f* (∷ x r*))]))] + [Reversing ok f1* f2* r1* r2* -> + (match f1* with + [Nil -> + (match r1* with + [Nil -> rs] + [∷ y r1* -> + (match r1* with + [Nil -> (Appending ok f2* (∷ y r2*))] + [∷ a b -> rs])])] + [∷ x f1* -> + (match r1* with + [Nil -> rs] + [∷ y r1* -> + (Reversing (+ ok 1) f1* (∷ x f2*) r1* (∷ y r2*))])])])) + +(define (hm-invalidate [rs : (RotationState A)] → (RotationState A)) + (match rs with + [Reversing ok f1* f2* r1* r2* -> + (Reversing (- ok 1) f1* f2* r1* r2*)] + [Appending ok f* r* -> + (if (= 0 ok) + (match r* with + [Nil -> rs] + [∷ x r* -> (Done r*)]) + (Appending (- ok 1) f* r*))] + [Done x -> rs] + [Idle -> rs])) + +(define (hm-exec2 [lenf : Int] [f* : (List A)] [state : (RotationState A)] [lenr : Int] [r : (List A)] → (HoodMelvilleQueue A)) + ((λ ([newstate : (RotationState A)]) + (match newstate with + [Done newf -> (HM lenf newf Idle lenr r)] + [Idle -> (HM lenf f* newstate lenr r)] + [Appending a b c -> (HM lenf f* newstate lenr r)] + [Reversing a b c d e -> (HM lenf f* newstate lenr r)])) + (hm-exec (hm-exec state)))) + +(define (hm-check [lenf : Int] [f* : (List A)] [state : (RotationState A)] [lenr : Int] [r* : (List A)] → (HoodMelvilleQueue A)) + (if (<= lenr lenf) + (hm-exec2 lenf f* state lenr r*) + (hm-exec2 (+ lenf lenr) f* (Reversing 0 f* Nil r* Nil) 0 Nil))) + +(define (hm-empty → (HoodMelvilleQueue A)) + (HM 0 Nil Idle 0 Nil)) + +(define (hm-isEmpty [hm : (HoodMelvilleQueue A)] → Bool) + (match hm with + [HM lenf b c d e -> + (= lenf 0)])) + +(define (hm-snoc [hm : (HoodMelvilleQueue A)] [x : A] → (HoodMelvilleQueue A)) + (match hm with + [HM lenf f state lenr r -> (hm-check lenf f state (+ lenr 1) (∷ x r))])) + +(define (hm-head [hm : (HoodMelvilleQueue A)] → (Option A)) + (match hm with + [HM a f b c d -> + (match f with + [Nil -> None] + [∷ x f* -> (Some x)])])) + +(define (hm-tail [hm : (HoodMelvilleQueue A)] → (Option (HoodMelvilleQueue A))) + (match hm with + [HM lenf f state lenr r -> + (match f with + [Nil -> None] + [∷ x f* -> (Some (hm-check (- lenf 1) f* (hm-invalidate state) lenr r))])])) + +;; ----------------------------------------------------------------------------- + +(define sample-hm + (foldl (λ ([acc : (HoodMelvilleQueue Int)] [x : Int]) (hm-snoc acc x)) (hm-empty) digit*)) + +(check-type + (hm-isEmpty (HM 0 (Nil {Int}) Idle 0 (Nil {Int}))) + : Bool + ⇒ #t) + +(check-type + (hm-isEmpty sample-hm) + : Bool + ⇒ #f) + +(check-type + (hm-head sample-hm) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (hm-head (hm-snoc sample-hm 10)) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (match (hm-tail sample-hm) with + [None -> None] + [Some hm -> (hm-head hm)]) + : (Option Int) + ⇒ (Some 2)) + +;; ============================================================================= +;; === Bootstrapped Queue + +(define-type (BootstrappedQueue a) + [E] + [Q Int (List a) (BootstrappedQueue (List a)) Int (List a)]) + +(define (bs-checkQ [lenfm : Int] [f : (List A)] [m : (BootstrappedQueue (List A))] [lenr : Int] [r : (List A)] → (BootstrappedQueue A)) + (if (<= lenr lenfm) + (bs-checkF lenfm f m lenr r) + (bs-checkF (+ lenfm lenr) f (bs-snoc m (reverse r)) 0 Nil))) + +(define (bs-checkF [lenfm : Int] [f : (List A)] [m : (BootstrappedQueue (List A))] [lenr : Int] [r : (List A)] → (BootstrappedQueue A)) + (match f with + [Nil -> + (match m with + [E -> E] + [Q _a _b _c _d _e -> + (match (bs-head m) with + [None -> E] + [Some hd -> + (match (bs-tail m) with + [None -> E] + [Some tl -> + (Q lenfm hd tl lenr r)])])])] + [∷ _f _f* -> + (Q lenfm f m lenr r)])) + +(define (bs-empty → (BootstrappedQueue A)) + (Q 0 Nil E 0 Nil)) + +(define (bs-isEmpty [m : (BootstrappedQueue A)] → Bool) + (match m with + [E -> #t] + [Q a b c d e -> #f])) + +(define (bs-snoc [m : (BootstrappedQueue A)] [x : A] → (BootstrappedQueue A)) + (match m with + [E -> (Q 1 (∷ x Nil) E 0 Nil)] + [Q lenfm f m lenr r -> (bs-checkQ lenfm f m (+ 1 lenr) (∷ x r))])) + +(define (bs-head [m : (BootstrappedQueue A)] → (Option A)) + (match m with + [E -> None] + [Q lenfm f m lenr r -> + (match f with + [Nil -> None] + [∷ x f* -> (Some x)])])) + +(define (bs-tail [m : (BootstrappedQueue A)] → (Option (BootstrappedQueue A))) + (match m with + [E -> None] + [Q lenfm f m lenr r -> + (match f with + [Nil -> None] + [∷ _x f* -> (Some (bs-checkQ (- lenfm 1) f* m lenr r))])])) + +;; ----------------------------------------------------------------------------- + +(define sample-bs + (foldl (λ ([acc : (BootstrappedQueue Int)] [x : Int]) (bs-snoc acc x)) (bs-empty) digit*)) + +(check-type + (bs-isEmpty (E {Int})) + : Bool + ⇒ #t) + +(check-type + (bs-isEmpty sample-bs) + : Bool + ⇒ #f) + +(check-type + (bs-head sample-bs) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (bs-head (bs-snoc sample-bs 10)) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (match (bs-tail sample-bs) with + [None -> None] + [Some bs -> (bs-head bs)]) + : (Option Int) + ⇒ (Some 2)) + +;; ============================================================================= +;; === Implicit Queue + +(define-type (Digit A) + [Zero] + [One A] + [Two A A]) + +(define-type (ImplicitQueue A) + [Shallow (Digit A)] + [Deep (Digit A) (ImplicitQueue (× A A)) (Digit A)]) + +(define (iq-empty → (ImplicitQueue A)) + (Shallow Zero)) + +(define (iq-isEmpty [iq : (ImplicitQueue A)] → Bool) + (match iq with + [Shallow d -> + (match d with + [Zero -> #t] + [One x -> #f] + [Two x y -> #f])] + [Deep a b c -> #f])) + +(define (iq-snoc [iq : (ImplicitQueue A)] [y : A] → (ImplicitQueue A)) + (match iq with + [Shallow d -> + (match d with + [Zero -> (Shallow (One y))] + [One x -> (Deep (Two x y) (Shallow Zero) Zero)] + [Two x y -> ;; Error + (Shallow Zero)])] + [Deep f m d -> + (match d with + [Zero -> (Deep f m (One y))] + [One x -> (Deep f (iq-snoc m (tup x y)) Zero)] + [Two x y -> (Shallow Zero)])])) ;; Error + +(define (iq-head [iq : (ImplicitQueue A)] → (Option A)) + (match iq with + [Shallow d -> + (match d with + [Zero -> None] + [One x -> (Some x)] + [Two x y -> (Some x)])] ;; Error + [Deep d m r -> + (match d with + [Zero -> None] ;; Error + [One x -> (Some x)] + [Two x y -> (Some x)])])) + +(define (iq-tail [iq : (ImplicitQueue A)] → (Option (ImplicitQueue A))) + (match iq with + [Shallow d -> + (match d with + [Zero -> None] + [One x -> (Some (Shallow Zero))] + [Two x y -> None])] ;; Error + [Deep d m r -> + (match d with + [Zero -> None] ;; Error + [One x -> + (match (iq-head m) with + [None -> (Some (Shallow r))] + [Some yz -> + (match yz with + [y z -> + (match (iq-tail m) with + [None -> None] + [Some tl -> + (Some (Deep (Two y z) tl r))])])])] + [Two x y -> (Some (Deep (One y) m r))])])) + +;; ----------------------------------------------------------------------------- + +(define sample-iq + (foldl (λ ([acc : (ImplicitQueue Int)] [x : Int]) (iq-snoc acc x)) (iq-empty) digit*)) + +(check-type + (iq-isEmpty (Shallow (Zero {Int}))) + : Bool + ⇒ #t) + +(check-type + (iq-isEmpty sample-iq) + : Bool + ⇒ #f) + +(check-type + (iq-head sample-iq) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (iq-head (iq-snoc sample-iq 10)) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (match (iq-tail sample-iq) with + [None -> None] + [Some iq -> (iq-head iq)]) + : (Option Int) + ⇒ (Some 2)) + +;; ============================================================================= +;; === Bankers Deque + +(define-type (BankersDeque A) + [BD Int (List A) Int (List A)]) + +(define c 3) + +(define (bd-check [lenf : Int] [f : (List A)] [lenr : Int] [r : (List A)] → (BankersDeque A)) + (if (> lenf (+ c (+ lenr 1))) + (let* ([i (div (+ lenf lenr) 2)] + [j (- (+ lenf lenr) i)] + [r2 (take j r)] + [f2 (append f (reverse (drop j r)))]) + (BD i f2 j r2)) + (if (> lenr (+ 1 (* c lenf))) + (let* ([j (div (+ lenf lenr) 2)] + [i (- (+ lenr lenf) j)] + [r2 (take j r)] + [f2 (append f (reverse (drop j r)))]) + (BD i f2 j r2)) + (BD lenf f lenr r)))) + +(define (bd-empty → (BankersDeque A)) + (BD 0 Nil 0 Nil)) + +(define (bd-isEmpty [bd : (BankersDeque A)] → Bool) + (match bd with + [BD lenf f lenr r -> (= 0 (+ lenf lenr))])) + +(define (bd-cons [x : A] [bd : (BankersDeque A)] → (BankersDeque A)) + (match bd with + [BD lenf f lenr r -> (bd-check (+ lenf 1) (∷ x f) lenr r)])) + +(define (bd-head [bd : (BankersDeque A)] → (Option A)) + (match bd with + [BD lenf f lenr r -> + (match f with + [Nil -> None] + [∷ x f2 -> (Some x)])])) + +(define (bd-tail [bd : (BankersDeque A)] → (Option (BankersDeque A))) + (match bd with + [BD lenf f lenr r -> + (match f with + [Nil -> None] + [∷ x f2 -> (Some (bd-check (- lenf 1) f2 lenr r))])])) + +(define (bd-snoc [bd : (BankersDeque A)] [x : A] → (BankersDeque A)) + (match bd with + [BD lenf f lenr r -> (bd-check lenf f (+ lenr 1) (∷ x r))])) + +(define (bd-last [bd : (BankersDeque A)] → (Option A)) + (match bd with + [BD lenf f lenr r -> + (match r with + [Nil -> None] + [∷ x r2 -> (Some x)])])) + +(define (bd-init [bd : (BankersDeque A)] → (Option (BankersDeque A))) + (match bd with + [BD lenf f lenr r -> + (match r with + [Nil -> None] + [∷ x r -> (Some (bd-check lenf f (- lenr 1) r))])])) + +;; ----------------------------------------------------------------------------- + +(define sample-bd + (foldl (λ ([acc : (BankersDeque Int)] [x : Int]) (bd-snoc acc x)) (bd-empty) digit*)) + +(check-type + (bd-isEmpty (BD 0 (Nil {Int}) 0 (Nil {Int}))) + : Bool + ⇒ #t) + +(check-type + (bd-isEmpty sample-bd) + : Bool + ⇒ #f) + +(check-type + (bd-head sample-bd) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (bd-last sample-bd) + : (Option Int) + ⇒ (Some 9)) + +(check-type + (bd-head (bd-snoc sample-bd 10)) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (bd-head (bd-cons 10 sample-bd)) + : (Option Int) + ⇒ (Some 10)) + +(check-type + (match (bd-tail sample-bd) with + [None -> None] + [Some bd -> (bd-head bd)]) + : (Option Int) + ⇒ (Some 2)) + +(check-type + (match (bd-init sample-bd) with + [None -> None] + [Some bd -> (bd-last bd)]) + : (Option Int) + ⇒ (Some 8)) + +;; ============================================================================= +;; === Simple Catenable Deque + +(define-type (SimpleCatDeque a) + [SShallow (BankersDeque a)] + [SDeep (BankersDeque a) (SimpleCatDeque (BankersDeque a)) (BankersDeque a)]) + +(define (bd-tooSmall [d : (BankersDeque A)] → Bool) + (if (bd-isEmpty d) + #t + (match (bd-tail d) with + [None -> #t] + [Some d -> (bd-isEmpty d)]))) + +(define (bd-dappendL [d1 : (BankersDeque A)] [d2 : (BankersDeque A)] → (BankersDeque A)) + (match (bd-head d1) with + [None -> d2] + [Some h -> (bd-cons h d2)])) + +(define (bd-dappendR [d1 : (BankersDeque A)] [d2 : (BankersDeque A)] → (BankersDeque A)) + (match (bd-head d2) with + [None -> d1] + [Some h -> (bd-snoc d1 h)])) + +(define (scd-empty → (SimpleCatDeque A)) + (SShallow (bd-empty))) + +(define (scd-isEmpty [scd : (SimpleCatDeque A)] → Bool) + (match scd with + [SShallow d -> (bd-isEmpty d)] + [SDeep a b c -> #f])) + +(define (scd-cons [x : A] [scd : (SimpleCatDeque A)] → (SimpleCatDeque A)) + (match scd with + [SShallow d -> (SShallow (bd-cons x d))] + [SDeep f m r -> (SDeep (bd-cons x f) m r)])) + +(define (scd-snoc [scd : (SimpleCatDeque A)] [x : A] → (SimpleCatDeque A)) + (match scd with + [SShallow d -> (SShallow (bd-snoc d x))] + [SDeep f m r -> (SDeep f m (bd-snoc f x))])) + +(define (scd-head [scd : (SimpleCatDeque A)] → (Option A)) + (match scd with + [SShallow d -> (bd-head d)] + [SDeep f m r -> (bd-head f)])) + +(define (scd-last [scd : (SimpleCatDeque A)] → (Option A)) + (match scd with + [SShallow d -> (bd-last d)] + [SDeep f m r -> (bd-last r)])) + +(define (scd-tail [scd : (SimpleCatDeque A)] → (Option (SimpleCatDeque A))) + (match scd with + [SShallow d -> + (match (bd-tail d) with + [None -> None] + [Some t -> (Some (SShallow t))])] + [SDeep f m r -> + (match (bd-tail f) with + [None -> None] + [Some f2 -> + (if (not (bd-tooSmall f2)) + (Some (SDeep f2 m r)) + (if (scd-isEmpty m) + (Some (SShallow (bd-dappendL f2 r))) + (match (scd-head m) with + [None -> None] + [Some hm -> + (match (scd-tail m) with + [None -> None] + [Some tm -> + (Some (SDeep (bd-dappendL f2 hm) tm r))])])))])])) + +(define (scd-init [scd : (SimpleCatDeque A)] → (Option (SimpleCatDeque A))) + (match scd with + [SShallow d -> + (match (bd-init d) with + [None -> None] + [Some t -> (Some (SShallow t))])] + [SDeep f m r -> + (match (bd-init r) with + [None -> None] + [Some r2 -> + (if (not (bd-tooSmall r2)) + (Some (SDeep f m r2)) + (if (scd-isEmpty m) + (Some (SShallow (bd-dappendR r r2))) + (match (scd-last m) with + [None -> None] + [Some lm -> + (match (scd-init m) with + [None -> None] + [Some im -> + (Some (SDeep f im (bd-dappendR lm r2)))])])))])])) + +(define (scd-++ [scd1 : (SimpleCatDeque A)] [scd2 : (SimpleCatDeque A)] → (SimpleCatDeque A)) + (match scd1 with + [SShallow d1 -> + (match scd2 with + [SShallow d2 -> + (if (bd-tooSmall d1) + (SShallow (bd-dappendL d1 d2)) + (if (bd-tooSmall d2) + (SShallow (bd-dappendR d1 d2)) + (SDeep d1 (scd-empty) d2)))] + [SDeep f m r -> + (if (bd-tooSmall d1) + (SDeep (bd-dappendL d1 f) m r) + (SDeep d1 (scd-cons f m) r))])] + [SDeep f1 m1 r1 -> + (match scd2 with + [SShallow d2 -> + (if (bd-tooSmall d2) + (SDeep f1 m1 (bd-dappendR r1 d2)) + (SDeep f1 (scd-snoc m1 r1) d2))] + [SDeep f2 m2 r2 -> + (SDeep f1 (scd-++ (scd-snoc m1 f1) (scd-cons r1 m2)) r2)])])) + +(define (scd->list [scd : (SimpleCatDeque A)] → (List A)) + (match (scd-head scd) with + [None -> Nil] + [Some hd -> + (match (scd-tail scd) with + [None -> (∷ hd Nil)] + [Some tl -> (∷ hd (scd->list tl))])])) + +;; ----------------------------------------------------------------------------- + +(define sample-scd + (foldl (λ ([acc : (SimpleCatDeque Int)] [x : Int]) (scd-snoc acc x)) (scd-empty) digit*)) + +(define (empty-sample → (SimpleCatDeque Int)) + (scd-empty)) + +(check-type + (scd-isEmpty (SShallow (BD 0 (Nil {Int}) 0 (Nil {Int})))) + : Bool + ⇒ #t) + +(check-type + (scd-isEmpty sample-scd) + : Bool + ⇒ #f) + +(check-type + (scd-head sample-scd) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (scd-head (empty-sample)) + : (Option Int) + ⇒ None) + +(check-type + (scd-last sample-scd) + : (Option Int) + ⇒ (Some 9)) + +(check-type + (scd-last (empty-sample)) + : (Option Int) + ⇒ None) + +(check-type + (scd-head (scd-snoc sample-scd 10)) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (scd-head (scd-cons 10 sample-scd)) + : (Option Int) + ⇒ (Some 10)) + +(check-type + (match (scd-tail sample-scd) with + [None -> None] + [Some scd -> (scd-head scd)]) + : (Option Int) + ⇒ (Some 2)) + +(check-type + (scd-tail (empty-sample)) + : (Option (SimpleCatDeque Int)) + ⇒ None) + +(check-type + (match (scd-init sample-scd) with + [None -> None] + [Some scd -> (scd-last scd)]) + : (Option Int) + ⇒ (Some 8)) + +(check-type + (scd-init (empty-sample)) + : (Option (SimpleCatDeque Int)) + ⇒ None) + +(check-type + (match (scd-head (scd-++ (scd-cons 1 (scd-empty)) (empty-sample))) with + [None -> None] + [Some i -> (Some i)]) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (match (scd-head (scd-++ (empty-sample) (scd-cons 2 (scd-empty)))) with + [None -> None] + [Some scd -> (Some scd)]) + : (Option Int) + ⇒ (Some 2)) + +(check-type + (match (scd-tail (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty)))) with + [None -> None] + [Some scd -> (scd-head scd)]) + : (Option Int) + ⇒ (Some 2)) + +(define (scd-ref [n : Int] [scd : (SimpleCatDeque A)] → (Option A)) + (if (< n 1) + (scd-head scd) + (match (scd-tail scd) with + [None -> None] + [Some tl -> (scd-ref (- n 1) tl)]))) + +(check-type + (scd-ref 2 + (scd-++ + (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) + (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty))))) + : (Option Int) + ⇒ (Some 3)) + +(check-type + (scd-ref 0 + (scd-++ + (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) + (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty))))) + : (Option Int) + ⇒ (Some 1)) + +(check-type + (scd->list + (scd-++ + (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) + (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty))))) + : (List Int) + ⇒ (∷ 1 (∷ 2 (∷ 3 (∷ 4 Nil))))) + +(check-type + (scd-ref 1 + (scd-++ + (scd-++ + (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) + (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty)))) + (scd-++ + (scd-++ (scd-cons 5 (scd-empty)) (scd-cons 6 (scd-empty))) + (scd-++ (scd-cons 7 (scd-empty)) (scd-cons 8 (scd-empty)))))) + : (Option Int) + ⇒ (Some 2)) + +(check-type + (scd-ref 3 + (scd-++ + (scd-++ + (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) + (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty)))) + (scd-++ + (scd-++ (scd-cons 5 (scd-empty)) (scd-cons 6 (scd-empty))) + (scd-++ (scd-cons 7 (scd-empty)) (scd-cons 8 (scd-empty)))))) + : (Option Int) + ⇒ (Some 4)) + +;; TODO this is a bug, but at least we have the right types in MLish +;(check-type +; (scd->list +; (scd-++ +; (scd-++ +; (scd-++ (scd-cons 1 (scd-empty)) (scd-cons 2 (scd-empty))) +; (scd-++ (scd-cons 3 (scd-empty)) (scd-cons 4 (scd-empty)))) +; (scd-++ +; (scd-++ (scd-cons 5 (scd-empty)) (scd-cons 6 (scd-empty))) +; (scd-++ (scd-cons 7 (scd-empty)) (scd-cons 8 (scd-empty)))))) +; : (List Int) +; ⇒ (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 Nil))))))))) + +;; ============================================================================= +;; === Binary Random Access List + +(define-type (Tree A) + (Leaf A) + (Node Int (Tree A) (Tree A))) + +(define-type (BLDigit A) + (BLZero) + (BLOne (Tree A))) + +(define-type (BinaryList A) + (BL (List (BLDigit A)))) + +(define (size (t : (Tree A)) → Int) + (match t with + (Leaf x -> 1) + (Node w t1 t2 -> w))) + +(define (link (t1 : (Tree A)) (t2 : (Tree A)) → (Tree A)) + (Node (+ (size t1) (size t2)) t1 t2)) + +(define (consTree (t : (Tree A)) (x* : (List (BLDigit A))) → (List (BLDigit A))) + (match x* with + (Nil -> (∷ (BLOne t) Nil)) + (∷ h ts -> + (match h with + (BLZero -> (∷ (BLOne t) ts)) + (BLOne t2 -> (∷ BLZero (consTree (link t t2) ts))))))) + + +;; TODO τ_e bad syntax when using `match2` +(define (unconsTree (d* : (List (BLDigit A))) → (Option (× (Tree A) (List (BLDigit A))))) + (match d* with + (Nil -> None) + (∷ d*-hd d*-tl -> + (match d*-hd with + (BLOne t -> + (match d*-tl with + (Nil -> (Some (tup t Nil))) + (∷ a b -> (Some (tup t (∷ BLZero d*-tl)))))) + (BLZero -> + (match (unconsTree d*-tl) with + (None -> None) + (Some udt -> + (match udt with + (a ts -> + (match a with + (Leaf x -> None) + (Node x t1 t2 -> + (Some (tup t1 (∷ (BLOne t2) ts)))))))))))))) + +(define (bl-empty → (BinaryList A)) + (BL Nil)) + +(define (bl-isEmpty (b : (BinaryList A)) → Bool) + (match b with + (BL x* -> + (match x* with + (Nil -> #t) + (∷ a b -> #f))))) + +(define (bl-cons (x : A) (b : (BinaryList A)) → (BinaryList A)) + (match b with + (BL ts -> (BL (consTree (Leaf x) ts))))) + +(define (bl-head (b : (BinaryList A)) → (Option A)) + (match b with + (BL ts -> + (match (unconsTree ts) with + (None -> None) + (Some xy -> + (match xy with + (x y -> + (match x with + (Leaf x -> (Some x)) + (Node a b c -> None))))))))) + +(define (bl-tail (b : (BinaryList A)) → (Option (BinaryList A))) + (match b with + (BL ts -> + (match (unconsTree ts) with + (None -> None) + (Some xy -> + (match xy with + (x ts2 -> (Some (BL ts2))))))))) + +(define (bl-lookup (i : Int) (b : (BinaryList A)) → (Option A)) + (match b with + [BL ts -> + (look i ts)])) + +(define (look [i : Int] [ts : (List (BLDigit A))] → (Option A)) + (match ts with + [Nil -> None] + [∷ h ts -> + (match h with + [BLZero -> + (look i ts)] + [BLOne t -> + (let ((size-t (size t))) + (if (< i size-t) + (lookTree i t) + (look (- i size-t) ts)))])])) + +(define (lookTree (i : Int) (t : (Tree A)) → (Option A)) + (match t with + [Leaf x -> + (if (= 0 i) + (Some x) + None)] + [Node w t1 t2 -> + (let ((w/2 (div w 2))) + (if (< i w/2) + (lookTree i t1) + (lookTree (- i w/2) t2)))])) + +(define (bl-update (i : Int) (y : A) (b : (BinaryList A)) → (Option (BinaryList A))) + (match b with + [BL ts -> + (match (upd i y ts) with + (None -> None) + (Some x -> (Some (BL x))))])) + +(define (upd (i : Int) (y : A) (b : (List (BLDigit A))) → (Option (List (BLDigit A)))) + (match b with + [Nil -> None] + [∷ h ts -> + (match h with + [BLZero -> + (match (upd i y ts) with + (None -> None) + (Some x -> (Some (∷ BLZero x))))] + [BLOne t -> + (let ((size-t (size t))) + (if (< i size-t) + (match (updTree i y t) with + (None -> None) + (Some x -> (Some (∷ (BLOne x) ts)))) + (match (upd (- i size-t) y ts) with + (None -> None) + (Some x -> (Some (∷ (BLOne t) x))))))])])) + +(define (updTree (i : Int) (y : A) (t : (Tree A)) → (Option (Tree A))) + (match t with + (Leaf x -> + (if (= 0 i) + (Some (Leaf y)) + None)) + (Node w t1 t2 -> + (let ((w/2 (div w 2))) + (if (< i w/2) + (match (updTree i y t1) with + (None -> None) + (Some x -> (Some (Node w x t2)))) + (match (updTree (- i w/2) y t2) with + (None -> None) + (Some x -> (Some (Node w t1 x))))))))) + +(define (list->bl-list (x* : (List A)) → (BinaryList A)) + (match x* with + (Nil -> (bl-empty)) + (∷ x x* -> (bl-cons x (list->bl-list x*))))) + +;; ============================================================================= + +(define bl-digit* + (list->bl-list (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil))))))))))) + +(define (bl-nil → (BinaryList Int)) + (list->bl-list Nil)) + +(check-type + (bl-isEmpty (bl-nil)) + : Bool + ⇒ #t) + +(check-type + (bl-isEmpty bl-digit*) + : Bool + ⇒ #f) + +(check-type + (match (bl-head bl-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 1) + +(check-type + (match (bl-tail bl-digit*) with + (None -> 0) + (Some x -> + (match (bl-head x) with + (None -> 0) + (Some y -> y)))) + : Int + ⇒ 2) + +(check-type + (match (bl-lookup 7 bl-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 8) + +(check-type + (match (bl-lookup 8 bl-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 9) + +(check-type + (bl-lookup -111 bl-digit*) + : (Option Int) + ⇒ None) + +(check-type + (match (bl-update 3 99 bl-digit*) with + (None -> None) + (Some x -> (bl-lookup 3 x))) + : (Option Int) + ⇒ (Some 99)) + +(check-type + (match (bl-update 0 222 bl-digit*) with + (None -> None) + (Some x -> (bl-head x))) + : (Option Int) + ⇒ (Some 222)) + +(check-type + (bl-update 83 1 bl-digit*) + : (Option (BinaryList Int)) + ⇒ None) + +;; ============================================================================= +;; === Skew Binary Random Access Lists + +(define-type (ATree A) + (ALeaf A) + (ANode A (ATree A) (ATree A))) + +(define-type (SkewList A) + (SL (List (× Int (ATree A))))) + +(define (sb-empty → (SkewList A)) + (SL Nil)) + +(define (sb-isEmpty (sl : (SkewList A)) → Bool) + (match sl with + (SL xs -> + (match xs with + (Nil -> #t) + (∷ a b -> #f))))) + +(define (sb-cons (x : A) (sl : (SkewList A)) → (SkewList A)) + (match sl with + (SL ts -> + (let ((base-case (SL (∷ (tup 1 (ALeaf x)) ts)))) + (match ts with + (Nil -> base-case) + (∷ w1t1 ts -> + (match ts with + (Nil -> base-case) + (∷ w2t2 ts -> + (match w1t1 with + (w1 t1 -> + (match w2t2 with + (w2 t2 -> + (if (= w1 w2) + (SL (∷ (tup (+ 1 (+ w1 w2)) (ANode x t1 t2)) ts)) + base-case))))))))))))) + +(define (sb-head (sl : (SkewList A)) → (Option A)) + (match sl with + (SL ts -> + (match ts with + (Nil -> None) + (∷ w1t1 ts -> + (match w1t1 with + (w1 t1 -> + (match t1 with + (ALeaf x -> + (if (= w1 1) + (Some x) + None)) ;; Invariant error + (ANode x t1 t2 -> + (Some x)))))))))) + +(define (sb-tail (sl : (SkewList A)) → (Option (SkewList A))) + (match sl with + (SL ts -> + (match ts with + (Nil -> None) + (∷ w1t1 ts -> + (match w1t1 with + (w1 t1 -> + (match t1 with + (ALeaf x -> + (if (= 1 w1) + (Some (SL ts)) + None)) ;; Invariant + (ANode x t1 t2 -> + (let ((w1/2 (div w1 2))) + (Some (SL (∷ (tup w1/2 t1) (∷ (tup w1/2 t2) ts)))))))))))))) + +(define (sb-lookup (i : Int) (sl : (SkewList A)) → (Option A)) + (match sl with + (SL ts -> + (sb-look i ts)))) + +(define (sb-look (i : Int) (ts : (List (× Int (ATree A)))) → (Option A)) + (match ts with + (Nil -> None) ;; Bad subscript + (∷ wt ts -> + (match wt with + (w t -> + (if (< i w) + (sb-lookTree w i t) + (sb-look (- i w) ts))))))) + +(define (sb-lookTree (w : Int) (i : Int) (t : (ATree A)) → (Option A)) + (match t with + (ALeaf x -> + (if (and (= w 1) (= i 0)) + (Some x) + None)) + (ANode x t1 t2 -> + (if (= 0 i) + (Some x) + (let ((w/2 (div w 2))) + (if (<= i w/2) + (sb-lookTree w/2 (- i 1) t1) + (sb-lookTree w/2 (- (- i 1) w/2) t2))))))) + +(define (sb-update (i : Int) (y : A) (sl : (SkewList A)) → (Option (SkewList A))) + (match sl with + (SL ts -> + (match (sb-upd i y ts) with + (None -> None) + (Some ts -> (Some (SL ts))))))) + +(define (sb-upd (i : Int) (y : A) (ts : (List (× Int (ATree A)))) → (Option (List (× Int (ATree A))))) + (match ts with + (Nil -> None) + (∷ wt ts -> + (match wt with + (w t -> + (if (< i w) + (match (sb-updTree w i y t) with + (None -> None) + (Some x -> (Some (∷ (tup w x) ts)))) + (match (sb-upd (- i w) y ts) with + (None -> None) + (Some x -> (Some (∷ (tup w t) x)))))))))) + +(define (sb-updTree (w : Int) (i : Int) (y : A) (t : (ATree A)) → (Option (ATree A))) + (match t with + (ALeaf x -> + (if (and (= 1 w) (= 0 i)) + (Some (ALeaf y)) + None)) ;; Invariant error + (ANode x t1 t2 -> + (if (= 0 i) + (Some (ANode y t1 t2)) + (let ((w/2 (div w 2))) + (if (<= i w/2) + (match (sb-updTree w/2 (- i 1) y t1) with + (None -> None) + (Some z -> (Some (ANode x z t2)))) + (match (sb-updTree w/2 (- (- i 1) w/2) y t2) with + (None -> None) + (Some z -> (Some (ANode x t1 z)))))))))) + +(define (list->sb-list (x* : (List A)) → (SkewList A)) + (match x* with + (Nil -> (sb-empty)) + (∷ h t -> (sb-cons h (list->sb-list t))))) + +;; ============================================================================= + +(define sb-digit* + (list->sb-list (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil))))))))))) + +(define (sb-nil → (SkewList Int)) + (list->sb-list Nil)) + +(check-type + (sb-isEmpty (sb-nil)) + : Bool + ⇒ #t) + +(check-type + (sb-isEmpty sb-digit*) + : Bool + ⇒ #f) + +(check-type + (match (sb-head sb-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 1) + +(check-type + (match (sb-tail sb-digit*) with + (None -> 0) + (Some x -> + (match (sb-head x) with + (None -> 0) + (Some y -> y)))) + : Int + ⇒ 2) + +(check-type + (match (sb-lookup 7 sb-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 8) + +(check-type + (match (sb-lookup 8 sb-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 9) + +(check-type + (sb-lookup -111 sb-digit*) + : (Option Int) + ⇒ None) + +(check-type + (match (sb-update 3 99 sb-digit*) with + (None -> None) + (Some x -> (sb-lookup 3 x))) + : (Option Int) + ⇒ (Some 99)) + +(check-type + (match (sb-update 0 222 sb-digit*) with + (None -> None) + (Some x -> (sb-head x))) + : (Option Int) + ⇒ (Some 222)) + +(check-type + (sb-update 83 1 sb-digit*) + : (Option (SkewList Int)) + ⇒ None) + +;; ============================================================================= +;; === Alt Binary Random Access List + +(define-type (BinaryRAList A) + (ABLNil) + (ABLZero (BinaryRAList (× A A))) + (ABLOne A (BinaryRAList (× A A)))) + +(define (abl-uncons (bl : (BinaryRAList A)) → (Option (× A (BinaryRAList A)))) + (match bl with + (ABLNil -> None) + (ABLOne x ps -> + (Some (match ps with + (ABLNil -> (tup x ABLNil)) + (ABLOne y ps2 -> (tup x (ABLZero ps))) + (ABLZero ps2 -> (tup x (ABLZero ps)))))) + (ABLZero ps -> + (match (abl-uncons ps) with + (None -> None) + (Some xyps2 -> + (match xyps2 with + (xy ps2 -> + (match xy with + (x y -> (Some (tup x (ABLOne y ps2)))))))))))) + +(define (abl-fupdate (f : (→ A A)) (i : Int) (bl : (BinaryRAList A)) → (Option (BinaryRAList A))) + (match bl with + (ABLNil -> None) + (ABLOne x ps -> + (if (= 0 i) + (Some (ABLOne (f x) ps)) + (match (abl-fupdate f (- i 1) (ABLZero ps)) with + (None -> None) + (Some z -> (Some (abl-cons x z)))))) + (ABLZero ps -> + (let ((f2 (if (= 0 (mod i 2)) + (λ ([xy : (× A A)]) + (match xy with (x y -> (tup (f x) y)))) + (λ ([xy : (× A A)]) + (match xy with (x y -> (tup x (f y)))))))) + (match (abl-fupdate f2 (div i 2) ps) with + (None -> None) + (Some z -> (Some (ABLZero z)))))))) + +(define (aabl-empty → (BinaryRAList A)) + ABLNil) + +(define (abl-isEmpty (bl : (BinaryRAList A)) → Bool) + (match bl with + (ABLNil -> #t) + (ABLOne a b -> #f) + (ABLZero a -> #f))) + +(define (abl-cons (x : A) (bl : (BinaryRAList A)) → (BinaryRAList A)) + (match bl with + (ABLNil -> (ABLOne x ABLNil)) + (ABLZero ps -> (ABLOne x ps)) + (ABLOne y ps -> (ABLZero (abl-cons (tup x y) ps))))) + +(define (abl-head (bl : (BinaryRAList A)) → (Option A)) + (match (abl-uncons bl) with + (None -> None) + (Some xy -> + (match xy with + (x y -> (Some x)))))) + +(define (abl-tail (bl : (BinaryRAList A)) → (Option (BinaryRAList A))) + (match (abl-uncons bl) with + (None -> None) + (Some xy -> + (match xy with + (x y -> (Some y)))))) + +(define (abl-lookup (i : Int) (bl : (BinaryRAList A)) → (Option A)) + (if (< i 0) + None + (abl-lookup/natural i bl))) + +(define (abl-lookup/natural (i : Int) (bl : (BinaryRAList A)) → (Option A)) + (match bl with + (ABLNil -> None) + (ABLOne x ps -> + (if (= 0 i) + (Some x) + (abl-lookup/natural (- i 1) (ABLZero ps)))) + (ABLZero ps -> + (match (abl-lookup/natural (div i 2) ps) with + (None -> None) + (Some xy -> + (match xy with + (x y -> + (if (= 0 (mod i 2)) + (Some x) + (Some y))))))))) + +(define (abl-update (i : Int) (y : A) (bl : (BinaryRAList A)) → (Option (BinaryRAList A))) + (abl-fupdate (λ ([x : A]) y) i bl)) + +(define (list->abl-list (xs : (List A)) → (BinaryRAList A)) + (match xs with + (Nil -> (aabl-empty)) + (∷ a b -> (abl-cons a (list->abl-list b))))) + +;; ============================================================================= + +(define abl-digit* + (list->abl-list (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil))))))))))) + +(define (abl-nil → (BinaryRAList Int)) + (list->abl-list Nil)) + +(check-type + (abl-isEmpty (abl-nil)) + : Bool + ⇒ #t) + +(check-type + (abl-isEmpty abl-digit*) + : Bool + ⇒ #f) + +(check-type + (match (abl-head abl-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 1) + +(check-type + (match (abl-tail abl-digit*) with + (None -> 0) + (Some x -> + (match (abl-head x) with + (None -> 0) + (Some y -> y)))) + : Int + ⇒ 2) + +(check-type + (match (abl-lookup 7 abl-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 8) + +(check-type + (match (abl-lookup 8 abl-digit*) with + (None -> 0) + (Some x -> x)) + : Int + ⇒ 9) + +(check-type + (abl-lookup -111 abl-digit*) + : (Option Int) + ⇒ None) + +(check-type + (match (abl-update 3 99 abl-digit*) with + (None -> None) + (Some x -> (abl-lookup 3 x))) + : (Option Int) + ⇒ (Some 99)) + +(check-type + (match (abl-update 0 222 abl-digit*) with + (None -> None) + (Some x -> (abl-head x))) + : (Option Int) + ⇒ (Some 222)) + +(check-type + (abl-update 83 1 abl-digit*) + : (Option (BinaryRAList Int)) + ⇒ None) + diff --git a/typed-lang-builder/examples/tests/mlish/chameneos.mlish b/typed-lang-builder/examples/tests/mlish/chameneos.mlish @@ -0,0 +1,129 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type Color Red Yellow Blue) + +(define-type (Option X) None (Some X)) + +(define-type-alias Meet + (× (Channel (Option (× Color String))) + (× Color String))) + +(define-type-alias Result (× Int Int)) + +(define-type-alias MeetChan (Channel Meet)) +(define-type-alias ResultChan (Channel Result)) + +(typecheck-fail (channel-put (make-channel {Bool}) 1) + #:with-msg "channel-put: type mismatch: expected Bool, given Int\n *expression: 1") + +(define (change [c1 : Color] [c2 : Color] -> Color) + (match c1 with + [Red -> + (match c2 with + [Blue -> Yellow] + [Yellow -> Blue] + [Red -> c1])] + [Yellow -> + (match c2 with + [Blue -> Red] + [Red -> Blue] + [Yellow -> c1])] + [Blue -> + (match c2 with + [Yellow -> Red] + [Red -> Yellow] + [Blue -> c1])])) + +(check-type (change Red Blue) : Color -> Yellow) +(check-type (change Yellow Red) : Color -> Blue) +(check-type (change Blue Blue) : Color -> Blue) + +(define NONE (None {(× Color String)})) + +(define (get+put [ch-meet : MeetChan] -> Unit) + (match (channel-get ch-meet) with + [ch v -> + (begin (channel-put ch NONE) + (get+put ch-meet))])) + +(define (swap [ch-meet : MeetChan] [n : Int] -> Unit) + (if (zero? n) + (get+put ch-meet) + (match (channel-get ch-meet) with + [ch1 v1 -> + (match (channel-get ch-meet) with + [ch2 v2 -> + (begin (channel-put ch1 (Some v2)) + (channel-put ch2 (Some v1)) + (swap ch-meet (sub1 n)))])]))) + + +(define (place [ch-meet : MeetChan] [n : Int] -> Thread) + (thread (λ () (swap ch-meet n)))) + +(define (rand-name -> String) + (string (integer->char (random 256)))) + +(define (sleeper [ch-meet : MeetChan] [ch-res : ResultChan] + [ch : (Channel (Option (× Color String)))] + [name : String] [c : Color] [met : Int] [same : Int] + -> Unit) + (begin + (channel-put ch-meet (tup ch (tup c name))) + (match (channel-get ch) with + [Some c+s -> + (match c+s with + [other-col other-name -> + (begin + (sleep 0) + (sleeper + ch-meet ch-res ch + name (change c other-col) + (add1 met) (+ same (if (string=? name other-name) 1 0))))])] + [None -> (channel-put ch-res (tup met same))]))) + +(define (creature [c : Color] [ch-meet : MeetChan] [ch-res : ResultChan] + -> Thread) + (thread + (λ () + (let ([ch (make-channel {(Option (× Color String))})] + [name (rand-name)]) + (sleeper ch-meet ch-res ch name c 0 0))))) + +(define (map [f : (→ X Y)] [lst : (List X)] -> (List Y)) + (if (isnil lst) + nil + (cons (f (head lst)) (map f (tail lst))))) + +(define (go [n : Int] [inits : (List Color)] -> (List Result)) + (let* ([ch-res (make-channel {Result})] + [ch-meet (make-channel {Meet})] + [start (place ch-meet n)] + [ths (map (λ ([c : Color]) (creature c ch-meet ch-res)) inits)]) + (map (λ ([c : Color]) (channel-get ch-res)) inits))) + +(define res1 (go 100 (list Blue Red Yellow))) + +(define (check-res1 [r : Result] -> Bool) + (match r with + [met same -> (or (= met 66) (= met 67))])) + +(check-type (length res1) : Int -> 3) + +(check-type (check-res1 (list-ref res1 0)) : Bool -> #t) +(check-type (check-res1 (list-ref res1 1)) : Bool -> #t) +(check-type (check-res1 (list-ref res1 2)) : Bool -> #t) + ;; -> (list (list 67 0) + ;; (list 66 0) + ;; (list 67 0))) + +(check-type (map (λ ([x : Result]) (proj x 0)) + (go 1000 (list Blue Red Yellow Red Yellow Blue))) + : (List Int) -> (list 333 333 333 333 334 334)) + ;; -> (list (list 333 0) + ;; (list 333 0) + ;; (list 333 0) + ;; (list 333 0) + ;; (list 334 0) + ;; (list 334 0))) diff --git a/typed-lang-builder/examples/tests/mlish/fannkuch.mlish b/typed-lang-builder/examples/tests/mlish/fannkuch.mlish @@ -0,0 +1,54 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define (fannkuch [n : Int] -> Int) + (let ([pi (list->vector + (for/list ([i (in-range n)]) i))] + [tmp (make-vector n)] + [count (make-vector n)]) + (let loop : Int ([flips 0] [perms 0] [r n]) + #;(when (< perms 30) + (for ([x (in-vector pi)]) + (display (add1 x))) + (newline)) + (for ([i (in-range r)]) + (vector-set! count i (add1 i))) + (let ((flips2 (max (count-flips pi tmp) flips))) + (let loop2 : Int ([r 1]) + (if (= r n) + flips2 + (let ((perm0 (vector-ref pi 0))) + (for ([i (in-range r)]) + (vector-set! pi i (vector-ref pi (add1 i)))) + (vector-set! pi r perm0) + (vector-set! count r (sub1 (vector-ref count r))) + (cond + [(<= (vector-ref count r) 0) + (loop2 (add1 r))] + [else (loop flips2 (add1 perms) r)])))))))) + +(define (count-flips [pi : (Vector Int)] [rho : (Vector Int)] -> Int) + (vector-copy! rho 0 pi) + (let loop : Int ([i 0]) + (if (= (vector-ref rho 0) 0) + i + (begin + (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0))) + (loop (add1 i)))))) + +(define (vector-reverse-slice! [v : (Vector X)] [i : Int] [j : Int] -> Unit) + (let loop : Unit ([i i] [j (sub1 j)]) + (when (> j i) + (vector-swap! v i j) + (loop (add1 i) (sub1 j))))) + +(define (vector-swap! [v : (Vector X)] [i : Int] [j : Int] -> Unit) + (let ((t (vector-ref v i))) + (vector-set! v i (vector-ref v j)) + (vector-set! v j t))) + +(check-type (fannkuch 5) : Int -> 7) +(check-type (fannkuch 6) : Int -> 10) +(check-type (fannkuch 7) : Int -> 16) +(check-type (fannkuch 8) : Int -> 22) +(check-type (fannkuch 9) : Int -> 30) diff --git a/typed-lang-builder/examples/tests/mlish/fasta.mlish b/typed-lang-builder/examples/tests/mlish/fasta.mlish @@ -0,0 +1,191 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define +alu+ + (string-append "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG" + "GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA" + "CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT" + "ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA" + "GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG" + "AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC" + "AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA")) + +(check-type +alu+ : String) + +(define IUB + (hash #\a 0.27 #\c 0.12 #\g 0.12 #\t 0.27 #\B 0.02 + #\D 0.02 #\H 0.02 #\K 0.02 #\M 0.02 #\N 0.02 + #\R 0.02 #\S 0.02 #\V 0.02 #\W 0.02 #\Y 0.02)) + +(check-type IUB : (Hash Char Float)) + +(define HOMOSAPIEN + (hash #\a 0.3029549426680 #\c 0.1979883004921 + #\g 0.1975473066391 #\t 0.3015094502008)) + +(check-type HOMOSAPIEN : (Hash Char Float)) + +(define line-length 60) + +(check-type line-length : Int) + +(define (repeat-fasta [header : String] [N : Int] [sequence : String] -> String) + (let* ([out (open-output-string)] + [len (string-length sequence)] + [buf (make-string (+ len line-length))]) + (string-copy! buf 0 sequence) + (string-copy! buf len sequence 0 line-length) + (write-string header out) + (let loop : String ([n N] [start 0]) + (if (> n 0) + (let ([end (+ start (min n line-length))]) + (write-string buf out start end) + (write-string "\n" out) + (loop (- n line-length) (if (> end len) (- end len) end))) + (get-output-string out))))) + +(define IA 3877) +(define IC 29573) +(define IM 139968) +(define IM.0 (fx->fl IM)) + +(define V + (for/vector ([id (in-range IM)]) + (modulo (+ IC (* id IA)) IM))) + +(check-type V : (Vector Int)) + +(define (random-next [cur : Int] -> Int) (vector-ref V cur)) + +(check-type (tup 0 0.0) : (× Int Float)) + +(check-type (in-hash IUB) : (Sequence (× Char Float))) + +(define (make-lookup-table [frequency-table : (Hash Char Float)] -> String) + (let ([v (make-string IM)]) + (for/fold ([cs (tup 0 0.0)]) + ([k+v (in-hash frequency-table)]) + (match cs with + [c c. -> + (match k+v with + [key val -> + (let* ([c1. (fl+ c. (fl* IM.0 val))] + [c1 (inexact->exact (flceiling c1.))] + #;[b (char->integer key)]) + (for ([i (in-range c c1)]) (string-set! v i key)) + (tup c1 c1.))])])) + v)) + +(define (n-randoms [buf : String][out : String-Port][lookup : String] + [to : Int][R : Int] -> Int) + (let loop : Int ([n 0] [R R]) + (if (< n to) + (let ([R (random-next R)]) + (string-set! buf n (string-ref lookup R)) + (loop (add1 n) R)) + (begin (write-string buf out 0 (add1 to)) R)))) + +(define LF #\newline) + +(define (make-line! [buf : String] [lookup : String] + [start : Int] [R : Int] -> Int) + (let ([end (+ start line-length)]) + (string-set! buf end LF) + (let loop : Int ([n start] [R R]) + (if (< n end) + (let ([R (random-next R)]) + (string-set! buf n (string-ref lookup R)) + (loop (add1 n) R)) + R)))) + +(define (random-fasta [header : String] [N : Int] + [table : (Hash Char Float)] [R : Int] + -> (× Int String)) + (let* ([buf (make-string (add1 line-length))] + [out (open-output-string)] + [lookup-str (make-lookup-table table)] + [full-lines+last (quotient+remainder N line-length)] + [C + (let* ([len+1 (add1 line-length)] + [buflen (* len+1 IM)] + [buf2 (make-string buflen)]) + (let loop : String ([R R] [i 0]) + (if (< i buflen) + (loop (make-line! buf2 lookup-str i R) (+ i len+1)) + buf2)))]) + (string-set! buf line-length LF) + (write-string header out) + (tup + (match full-lines+last with + [full-lines last -> + (let loop : Int ([i full-lines] [R R]) + (if (> i IM) + (begin (write-string C out) (loop (- i IM) R)) + (let loop : Int ([i i] [R R]) + (cond + [(> i 0) + (loop + (sub1 i) + (n-randoms buf out lookup-str line-length R))] + [(> last 0) + (string-set! buf last LF) + (n-randoms buf out lookup-str last R)] + [else R]))))]) + (get-output-string out)))) + +(define n 10) + +(check-type (repeat-fasta ">ONE Homo sapiens alu\n" (* n 2) +alu+) : String + -> ">ONE Homo sapiens alu\nGGCCGGGCGCGGTGGCTCAC\n") + +(define res1 + (random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB 42)) + +(define res2 + (match res1 with + [R str -> + (random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN R)])) + +(check-type (proj res1 1) : String + -> ">TWO IUB ambiguity codes\nattRtBtaDtatVataKatgaatcccgDtY\n") + +(check-type (proj res2 1) : String + -> (string-append ">THREE Homo sapiens frequency\n" + "atttgcggaaacgacaaatattaacacatcatcagagtaccataaaggga\n")) + +(define (mk-fasta [n : Int] -> String) + (let + ([res1 (repeat-fasta ">ONE Homo sapiens alu\n" (* n 2) +alu+)] + [res2 (random-fasta ">TWO IUB ambiguity codes\n" (* n 3) IUB 42)] + [res3 + (match res2 with + [R str -> + (random-fasta ">THREE Homo sapiens frequency\n" (* n 5) HOMOSAPIEN R)])]) + (string-append res1 (proj res2 1) (proj res3 1)))) + +(provide mk-fasta) + +(check-type (mk-fasta 100) + : String + -> (string-append + ">ONE Homo sapiens alu\n" + "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGA\n" + "TCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACT\n" + "AAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAG\n" + "GCTGAGGCAGGAGAATCGCT\n" + ">TWO IUB ambiguity codes\n" + "attRtBtaDtatVataKatgaatcccgDtYtcccNaNgtRttNtatttatcctSaRataW\n" + "taatNtNctaatctttggMtMttKtYtMHagBttagcMKMttttcWaactgcSttgaaac\n" + "gtcatHagHtgtaHVgtcattatgRcaVcaatctcWgaNtttVaaYcaaaataYtgWgtt\n" + "acttMgtHHgagtattaaaKSgtBgacaaggSaaRttVaVDHttRgctagtaaacgaaac\n" + "ttcRNtgcatttSagBtHttNRaatgtctattcaSaRYcgtatSattttttttgaBgagD\n" + ">THREE Homo sapiens frequency\n" + "gaagacaggtgtaacgtgggaaaatctctagtaaagctttgatcagcggagacgcgatca\n" + "acagatcctttatatcgcgaaacttctctctatcagcgaactaaggagggcgacaatccg\n" + "agctgttccggaccaaaccctgaaagtacgactctgctctaataaagtcaaaacgtagaa\n" + "gactagatacaattatactgacaacaaaaaaaagttgcgtgcacaagagtacgatgtttg\n" + "accgccagttattatgacgagggtgagaacaagtcaggctaaagtagaagagcaccatag\n" + "gtatcagtttaactgagtaaatgcgaatgcgtgactttaaataagcctgcgtgtgtcaaa\n" + "actctacaatatctttgttatattattgaatcattctggatttgaggcagtggagcatac\n" + "tgtataaaataatttttcggtgggtcaaaaataaatttcaattaagacgttaaggataat\n" + "gaaatgactcaatctaaggt\n")) diff --git a/typed-lang-builder/examples/tests/mlish/fibo.mlish b/typed-lang-builder/examples/tests/mlish/fibo.mlish @@ -0,0 +1,22 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define (fib [n : Int] -> Int) + (cond + [(< n 2) 1] + [else + (+ (fib (- n 2)) (fib (sub1 n)))])) + +(define (main [args : (Vector String)] -> Int) + (let ([n (if (= (vector-length args) 0) + 1 + (string->number (vector-ref args 0)))]) + (fib n))) + +(check-type (main (vector "0")) : Int -> 1) + +(check-type (main (vector "1")) : Int -> 1) + +(check-type (main (vector "2")) : Int -> 2) + +(check-type (main (vector "22")) : Int -> 28657) diff --git a/typed-lang-builder/examples/tests/mlish/find.mlish b/typed-lang-builder/examples/tests/mlish/find.mlish @@ -0,0 +1,87 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type (List X) + Nil + (Cons X (List X))) + +(define-type (Option X) + None + (Some X)) + +(define (find [lst : (List X)] [pred : (→ X Bool)] → (Option X)) + (match lst with + [Nil -> None] + [Cons fst rst -> + (cond [(pred fst) (Some fst)] + [else (find rst pred)])])) + +(check-type + (find (Cons 1 (Cons 2 (Cons 3 Nil))) (λ ([x : Int]) (<= 2 x))) + : (Option Int) + -> (Some 2)) + +(check-type + (find (Cons 1 (Cons 0 (Cons -1 Nil))) (λ ([x : Int]) (<= 2 x))) + : (Option Int) + -> None) + +;; args inferred in order, L-to-R, currently no backtracking +(check-type + (find Nil (λ ([x : Int]) (<= 2 x))) + : (Option Int) + -> None) + +;; reversing arg order leads to successful inference +(define (find2 [pred : (→ X Bool)] [lst : (List X)] → (Option X)) + (match lst with + [Nil -> None] + [Cons fst rst -> + (cond [(pred fst) (Some fst)] + [else (find2 pred rst)])])) + +(check-type + (find2 (λ ([x : Int]) (<= 2 x)) Nil) + : (Option Int) + -> None) + +(define (find-min/max [lst : (List X)] [<? : (→ Y Y Bool)] [extract-key : (→ X Y)] + → (Option (× X X))) + (match lst with + [Nil -> None] + [Cons x1 rst -> + (let ([y1 (extract-key x1)]) + (Some (find-min/max-accum rst <? extract-key x1 y1 x1 y1)))])) + +(define (find-min/max-accum [lst : (List X)] [<? : (→ Y Y Bool)] [extract-key : (→ X Y)] + [x-min : X] [y-min : Y] [x-max : X] [y-max : Y] + → (× X X)) + (match lst with + [Nil -> (tup x-min x-max)] + [Cons x2 rst -> + (let ([y2 (extract-key x2)]) + (cond [(<? y2 y-min) + (find-min/max-accum rst <? extract-key x2 y2 x-max y-max)] + [(<? y-max y2) + (find-min/max-accum rst <? extract-key x-min y-min x2 y2)] + [else + (find-min/max-accum rst <? extract-key x-min y-min x-max y-max)]))])) + +(check-type + (find-min/max (Nil {Int}) + (λ ([x : Int] [y : Int]) + (< x y)) + (λ ([x : Int]) + x)) + : (Option (× Int Int)) + -> None) + +(check-type + (find-min/max (Cons 1 (Cons 2 (Cons 3 Nil))) + (λ ([x : Int] [y : Int]) + (< x y)) + (λ ([x : Int]) + x)) + : (Option (× Int Int)) + -> (Some (tup 1 3))) + diff --git a/typed-lang-builder/examples/tests/mlish/hash.mlish b/typed-lang-builder/examples/tests/mlish/hash.mlish @@ -0,0 +1,19 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define (main [argv : (Vector String)] -> Int) + (let* ([n (string->number (vector-ref argv 0))] + [hash + (for/hash ([i (in-range n)]) + (let ([j (add1 i)]) + (tup (number->string j 16) j)))]) + (for/sum ([i (in-range 1 (add1 n))] + #:when + (hash-has-key? hash (number->string i))) + 1))) + +(check-type (main (vector "2000")) : Int -> 799) + +(check-type (main (vector "20000")) : Int -> 4999) + +(check-type (main (vector "200000")) : Int -> 30999) diff --git a/typed-lang-builder/examples/tests/mlish/infer-variances.mlish b/typed-lang-builder/examples/tests/mlish/infer-variances.mlish @@ -0,0 +1,243 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type T1 t1) +;; No type arguments to determine variance for. + +(check-type t1 : T1 -> t1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Non-Recursive Types + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T2 X) t2) +;; X should be inferred to be irrelevant within (T2 X). +;; That means it should be both covariant and contravariant. + +;; This checks that X is covariant within (T2 X). +(define (t2* → (T2 X)) t2) +(define (t2** → (→ (T2 X))) (inst t2* X)) +(check-type (t2**) : (→/test (T2 X))) + +;; This checks that X is contravariant within (T2 X), +;; by checking that X is covariant within (→ (T2 X) Int). +(define (t2->int [t2 : (T2 X)] → Int) 0) +(define (t2->int* → (→ (T2 X) Int)) (inst t2->int X)) +(check-type (t2->int*) : (→/test (T2 X) Int)) + +;; This checks that X is irrelevant, even within a Ref type, +;; by checking that X is covariant within (Ref (T2 X)). +;; This is still sound because a value of type (Ref (T2 X)) will never +;; contain anything of type X anyway. X is irrelevant within it. +(define (ref-t2* → (Ref (T2 X))) (ref (t2 {X}))) +(define (ref-t2** → (→ (Ref (T2 X)))) (inst ref-t2* X)) +(check-type (ref-t2**) : (→/test (Ref (T2 X)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T3 X) t3-none (t3-some X)) +;; X should be inferred to be covariant within (T3 X). + +;; This checks that X is covariant within (T3 X). +(define (t3-none* → (T3 X)) t3-none) +(define (t3-none** → (→ (T3 X))) (inst t3-none* X)) +(check-type (t3-none**) : (→/test (T3 X))) + +;; This checks that X is not contravariant within (T3 X), +;; by checking that X is not covariant within (→ (T3 X) Int). +(define (t3->int [t3 : (T3 X)] → Int) 0) +(define (t3->int* → (→ (T3 X) Int)) (inst t3->int X)) +(typecheck-fail (t3->int*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T4 X) t4-none (t4-some (→ X Int))) +;; X should be inferred to be contravariant within (T4 X). + +;; This checks that X is not covariant within (T4 X). +(define (t4-none* → (T4 X)) t4-none) +(define (t4-none** → (→ (T4 X))) (inst t4-none* X)) +(typecheck-fail (t4-none**)) + +;; This checks that X is contravariant within (T4 X), +;; by checking that X is covariant within (→ (T4 X) Int). +(define (t4->int [t4 : (T4 X)] → Int) 0) +(define (t4->int* → (→ (T4 X) Int)) (inst t4->int X)) +(check-type (t4->int*) : (→/test (T4 X) Int)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T5 X) t5-none (t5-some+ X) (t5-some- (→ X Int))) +;; X should be inferred to be invariant within (T5 X). + +;; This checks that X is not covariant within (T5 X). +(define (t5-none* → (T5 X)) t5-none) +(define (t5-none** → (→ (T5 X))) (inst t5-none* X)) +(typecheck-fail (t5-none**)) + +;; This checks that X is not contravariant within (T5 X), +;; by checking that X is not covariant within (→ (T5 X) Int). +(define (t5->int [t5 : (T5 X)] → Int) 0) +(define (t5->int* → (→ (T5 X) Int)) (inst t5->int X)) +(typecheck-fail (t5->int*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Recursive Types + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T6 X) t6-none (t6-same (T6 X))) +;; X should be inferred to be irrelevant within (T6 X). + +;; This checks that X is covariant within (T6 X). +(define (t6-none* → (T6 X)) t6-none) +(define (t6-none** → (→ (T6 X))) (inst t6-none* X)) +(check-type (t6-none**) : (→/test (T6 X))) + +;; This checks that X is contravariant within (T6 X), +;; by checking that X is covariant within (→ (T6 X) Int). +(define (t6->int [t6 : (T6 X)] → Int) 0) +(define (t6->int* → (→ (T6 X) Int)) (inst t6->int X)) +(check-type (t6->int*) : (→/test (T6 X) Int)) + +;; This checks that X is irrelevant, even within a Ref type, +;; by checking that X is covariant within (Ref (T6 X)). +;; This is still sound because a value of type (Ref (T6 X)) will never +;; contain anything of type X anyway. X is irrelevant within it. +(define (ref-t6* → (Ref (T6 X))) (ref (t6-none {X}))) +(define (ref-t6** → (→ (Ref (T6 X)))) (inst ref-t6* X)) +(check-type (ref-t6**) : (→/test (Ref (T6 X)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T7 X) t7-none (t7-weird (→ (T7 X) Int))) +(define-type (T8 X) t8-none (t8-weird (T8 (→ X Int)))) +(define-type (T9 X) t9-none (t9-weird (→ (T9 (→ X Int)) Int))) +;; X should be inferred to be irrelevant within (T7 X), (T8 X), and +;; (T9 X). None of these types could contain or recieve an actual X. + +(define-type (T10 X) (t10 (T7 X) (T8 X) (T9 X))) +;; So because of that, X should be irrelevant within (T10 X). + +;; This checks that X is covariant within (T10 X). +(define (t10-none* → (T10 X)) (t10 t7-none t8-none t9-none)) +(define (t10-none** → (→ (T10 X))) (inst t10-none* X)) +(check-type (t10-none**) : (→/test (T10 X))) + +;; This checks that X is contravariant within (T10 X), +;; by checking that X is covariant within (→ (T10 X) Int). +(define (t10->int [t10 : (T10 X)] → Int) 0) +(define (t10->int* → (→ (T10 X) Int)) (inst t10->int X)) +(check-type (t10->int*) : (→/test (T10 X) Int)) + +;; This checks that X is irrelevant, even within a Ref type, +;; by checking that X is covariant within (Ref (T10 X)). +;; This is still sound because a value of type (Ref (T10 X)) will never +;; contain anything of type X anyway. X is irrelevant within it. +(define (ref-t10* → (Ref (T10 X))) (ref (t10 (t7-none {X}) (t8-none {X}) (t9-none {X})))) +(define (ref-t10** → (→ (Ref (T10 X)))) (inst ref-t10* X)) +(check-type (ref-t10**) : (→/test (Ref (T10 X)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T11 X) t11-none (t11+ X) (t11-weird (→ (T11 X) Int))) +(define-type (T12 X) t12-none (t12+ X) (t12-weird (T12 (→ X Int)))) +(define-type (T13 X) t13-none (t13+ X) + (t13-weird (→ (T13 (→ X Int)) Int))) +(define-type (T14 X) t14-none (t14- (→ X Int)) + (t14-weird (→ (T14 (→ X Int)) Int))) +;; X should be inferred to be invariant within (T11 X) and (T12 X), +;; but covariant within (T13 X), and contravariant within (T14 X). + +;; This checks that X is covariant within (T13 X), but not any of the +;; others. +(define (t11-none* → (T11 X)) t11-none) +(define (t12-none* → (T12 X)) t12-none) +(define (t13-none* → (T13 X)) t13-none) +(define (t14-none* → (T14 X)) t14-none) +(define (t11-none** → (→ (T11 X))) (inst t11-none* X)) +(define (t12-none** → (→ (T12 X))) (inst t12-none* X)) +(define (t13-none** → (→ (T13 X))) (inst t13-none* X)) +(define (t14-none** → (→ (T14 X))) (inst t14-none* X)) +(typecheck-fail (t11-none**)) +(typecheck-fail (t12-none**)) +(check-type (t13-none**) : (→/test (T13 X))) +(typecheck-fail (t14-none**)) + +;; This checks that X is contravariant within (T14 X), but not any of +;; the others. +(define (t11->int [t11 : (T11 X)] → Int) 0) +(define (t12->int [t12 : (T12 X)] → Int) 0) +(define (t13->int [t13 : (T13 X)] → Int) 0) +(define (t14->int [t14 : (T14 X)] → Int) 0) +(define (t11->int* → (→ (T11 X) Int)) (inst t11->int X)) +(define (t12->int* → (→ (T12 X) Int)) (inst t12->int X)) +(define (t13->int* → (→ (T13 X) Int)) (inst t13->int X)) +(define (t14->int* → (→ (T14 X) Int)) (inst t14->int X)) +(typecheck-fail (t11->int*)) +(typecheck-fail (t12->int*)) +(typecheck-fail (t13->int*)) +(check-type (t14->int*) : (→/test (T14 X) Int)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T15 X) t15-none (t15-cons+ X (T15 X))) +(define-type (T16 X) t16-none (t16-cons- (→ X Int) (T16 X))) +;; X should be inferred to be covariant within (T15 X), and +;; contravariant within (T16 X). (T15 X) is just like a (List X) type, +;; and (T16 X) is just like a (List (→ X Int)). + +;; This checks that X is covariant within (T15 X). +(define (t15-none* → (T15 X)) t15-none) +(define (t15-none** → (→ (T15 X))) (inst t15-none* X)) +(check-type (t15-none**) : (→/test (T15 X))) +;; This checks that X is not covariant within (T16 X). +(define (t16-none* → (T16 X)) t16-none) +(define (t16-none** → (→ (T16 X))) (inst t16-none* X)) +(typecheck-fail (t16-none**)) + +;; This checks that X is not contravariant within (T15 X), +;; by checking that X is not covariant within (→ (T15 X) Int). +(define (t15->int [t15 : (T15 X)] → Int) 0) +(define (t15->int* → (→ (T15 X) Int)) (inst t15->int X)) +(typecheck-fail (t15->int*)) +;; This checks that X is contravariant within (T16 X), +;; by checking that X is covariant within (→ (T16 X) Int). +(define (t16->int [t16 : (T16 X)] → Int) 0) +(define (t16->int* → (→ (T16 X) Int)) (inst t16->int X)) +(check-type (t16->int*) : (→/test (T16 X) Int)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Mutually Recursive Types + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-type (T17 X) (t17-some X) (t18 (T18 X))) +(define-type (T18 X) t18-none (t18-cons (T17 X) (T18 X))) +;; X should be inferred to be covariant in both (T17 X) and (T18 X). +;; This is similar to an arbitrary-arity tree type. + +;; This checks that X is covariant within (T17 X). +(define (t17-none* → (T17 X)) (t18 t18-none)) +(define (t17-none** → (→ (T17 X))) (inst t17-none* X)) +(check-type (t17-none**) : (→/test (T17 X))) +;; This checks that X is covariant within (T18 X). +(define (t18-none* → (T18 X)) t18-none) +(define (t18-none** → (→ (T18 X))) (inst t18-none* X)) +(check-type (t18-none**) : (→/test (T18 X))) + +;; This checks that X is not contravariant within (T17 X), +;; by checking that X is not covariant within (→ (T17 X) Int). +(define (t17->int [t17 : (T17 X)] → Int) 0) +(define (t17->int* → (→ (T17 X) Int)) (inst t17->int X)) +(typecheck-fail (t17->int*)) +;; This checks that X is not contravariant within (T18 X), +;; by checking that X is not covariant within (→ (T18 X) Int). +(define (t18->int [t18 : (T18 X)] → Int) 0) +(define (t18->int* → (→ (T18 X) Int)) (inst t18->int X)) +(typecheck-fail (t18->int*)) + diff --git a/typed-lang-builder/examples/tests/mlish/inst.mlish b/typed-lang-builder/examples/tests/mlish/inst.mlish @@ -0,0 +1,74 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; tests for instantiation of polymorphic functions and constructors + +(define-type (Result A B) + (Ok A) + (Error B)) + +(define (ok [a : A] -> (Result A B)) + (Ok a)) + +(check-type ok : (→/test A (Result A B))) ; test inferred +(check-type (inst ok Int String) : (→/test Int (Result Int String))) + +(define (f -> (Result Int String)) + (ok 1)) + +(check-type f : (→/test (Result Int String))) + +(define (g -> (Result Int String)) + (Ok 1)) + +(check-type g : (→/test (Result Int String))) + +(define (h -> (Result Int Y)) + (Ok 1)) + +(check-type h : (→/test (Result Int Y))) + +(define (i -> (Result Int String)) + (h)) + +(check-type i : (→/test (Result Int String))) + +(define (f/cond [b : Bool] -> (Result Int String)) + (cond [b (ok 1)] + [else (ok 0)])) + +(check-type f/cond : (→/test Bool (Result Int String))) + +(define-type-alias (Read-Result A) (Result (× A (List Char)) String)) + +(define (alias-test -> (Read-Result A)) + (Error "asd")) + +(check-type alias-test : (→/test (Result (× A (List Char)) String))) +(check-type alias-test : (→/test (Read-Result A))) + +(define (alias-test2 [in : A] -> (Read-Result A)) + (ok (tup in nil))) +(define (alias-test3 [in : A] -> (Read-Result A)) + (ok (tup in (list #\a #\b #\c)))) + +(check-type alias-test2 : (→/test A (Result (× A (List Char)) String))) +(check-type alias-test2 : (→/test A (Read-Result A))) +(check-type alias-test3 : (→/test A (Result (× A (List Char)) String))) +(check-type alias-test3 : (→/test A (Read-Result A))) + +(check-type alias-test2 : (→/test B (Result (× B (List Char)) String))) +(check-type alias-test2 : (→/test B (Read-Result B))) +(check-type alias-test3 : (→/test B (Result (× B (List Char)) String))) +(check-type alias-test3 : (→/test B (Read-Result B))) + +(define (expect-listof-int [loi : (List Int)] → Int) + 0) + +(check-type (expect-listof-int nil) : Int -> 0) + +(define (expect-→listof-int [f : (→ (List Int))] → Int) + 0) + +(check-type (expect-→listof-int (λ () nil)) : Int -> 0) + diff --git a/typed-lang-builder/examples/tests/mlish/knuc.mlish b/typed-lang-builder/examples/tests/mlish/knuc.mlish @@ -0,0 +1,67 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(require-typed mk-fasta #:from "fasta.mlish") + +(define (all-counts [len : Int] [dna : String] -> (Hash String (Ref Int))) + (let ([table (hash {String (Ref Int)})]) + (for ([s (in-range (- (string-length dna) len) -1 -1)]) + (let ([key (make-string len)]) + (string-copy! key 0 dna s (+ s len)) + (let* ([b (if (hash-has-key? table key) + (hash-ref table key) + (let ([b (ref 0)]) + (hash-set! table key b) + b))]) + (:= b (add1 (deref b)))))) + table)) + + +(define dna + (let* ([in (mk-fasta 100000)] + ;; Skip to ">THREE ..." + [rst + (head (tail + (regexp-match + (regexp ">THREE Homo sapiens frequency\n(.*)$") + in)))]) + (let ([s (open-output-string)]) + ;; Copy everything but newlines to s: + (for ([l (in-lines rst)]) + (write-string l s)) + ;; Extract the string from s: + (string-upcase (get-output-string s))))) + +(check-type dna : String) + +;; 1-nucleotide counts: +(define counts1 (all-counts 1 dna)) + +(check-type counts1 : (Hash String (Ref Int))) + +(check-type (hash-count counts1) : Int -> 4) + +;; 2-nucleotide counts: +(define counts2 (all-counts 2 dna)) + +(check-type counts2 : (Hash String (Ref Int))) + +(check-type (hash-count counts2) : Int -> 16) + +;; 2-nucleotide counts: +(define counts3 (all-counts 3 dna)) + +(check-type counts3 : (Hash String (Ref Int))) + +(check-type (hash-count counts3) : Int -> 64) + +;; Specific sequences: +(check-type + (for/list ([seq (in-list (list "GGT" "GGTA" "GGTATT" + "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))]) + (let ([table (all-counts (string-length seq) dna)]) + (if (hash-has-key? table seq) + (deref (hash-ref table seq)) + 0))) + : (List Int) + -> (list 5861 1776 176 0 0)) diff --git a/typed-lang-builder/examples/tests/mlish/listpats.mlish b/typed-lang-builder/examples/tests/mlish/listpats.mlish @@ -0,0 +1,70 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; pattern matching for built-in lists + +(check-type + (match (list 1 2) with + [[] -> 0] + [[x y] -> (+ x y)]) : Int -> 3) + +(typecheck-fail + (match (list 1 2) with + [[x y] -> (+ x y)]) #:with-msg "missing empty list case") + +(typecheck-fail + (match (list 1 2) with + [[] -> 0]) #:with-msg "missing non\\-empty list case") + +(check-type + (match (list 1 2) with + [[] -> 0] + [[x y] -> (+ x y)]) : Int -> 3) + +(check-type + (match (list 1 2) with + [[x y] -> (+ x y)] + [[] -> 0]) : Int -> 3) + +(check-type + (match (nil {Int}) with + [[x y] -> (+ x y)] + [[] -> 0]) : Int -> 0) + +(check-type + (match (list 1 2 3) with + [[] -> nil] + [x :: rst -> rst]) : (List Int) -> (list 2 3)) + +(check-type + (match (list 1 2 3) with + [[] -> nil] + [x :: y :: rst -> rst]) : (List Int) -> (list 3)) + +(check-type + (match (nil {Int}) with + [[] -> nil] + [x :: y :: rst -> rst]) : (List Int) -> nil) + +(check-type + (match (list 1 2 3) with + [[] -> 0] + [x :: y :: rst -> (+ x y)]) : Int -> 3) + +(check-type + (match (list 1 2 3) with + [[] -> 0] + [[x] -> 2] + [x :: rst -> 3]) : Int -> 3) + +(check-type + (match (list 1) with + [[] -> 0] + [[x] -> 2] + [x :: rst -> 3]) : Int -> 2) + +(check-type + (match (list 1) with + [[] -> 0] + [x :: rst -> 3] + [[x] -> 2]) : Int -> 3) diff --git a/typed-lang-builder/examples/tests/mlish/loop.mlish b/typed-lang-builder/examples/tests/mlish/loop.mlish @@ -0,0 +1,121 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; datatype with no self-reference +(define-type (Test X) + (A X) + (B X X)) + +(typecheck-fail + (define-type (Test2 X) + (AA (Test2 X X))) + #:with-msg "Improper use of constructor Test2; expected 1 args, got 2") + +(typecheck-fail + (define-type (Test3 X) + (AA (→))) + #:with-msg "Improper usage of type constructor →") + +(typecheck-fail + (define-type (Test4 X) + (AA (+ 1 2))) + #:with-msg "\\(\\+ 1 2\\) is not a valid type") + +(check-type (A 1) : (Test Int)) +(check-type (B 1 2) : (Test Int)) + +(check-type + (match (A 1) with + [A x -> x] + [B x y -> (+ x y)]) : Int -> 1) + +(check-type + (match (B 1 2) with + [A x -> x] + [B x y -> (+ x y)]) : Int -> 3) + +;; datatype with self-reference +(define-type (Rec X) + N + (C X (Rec X))) + +; check inferred and explicit instantiation versions +(check-type N : (Rec Int) -> N) +(check-type (N {Int}) : (Rec Int) -> (N {Int})) +(check-type (C 1 N) : (Rec Int) -> (C 1 N)) + +(check-type + (match (N {Int}) with + [N -> 0] + [C x xs -> x]) : Int -> 0) + +(check-type + (match (C 1 N) with + [N -> 0] + [C x xs -> x]) : Int -> 1) + +;; mutually referential datatypes +(define-type (Loop1 X) + (L1 (Loop2 X))) +(define-type (Loop2 X) + (L2 (Loop1 X))) + +(define (looping-f [x : (Loop1 Y)] -> (Loop1 Y)) x) + +(define-type (ListA X) + NA + (CA X (ListB X))) +(define-type (ListB X) + NB + (CB X (ListA X))) + +(typecheck-fail + (define-type (ListC X) + NC + (CC X (ListA X X))) + #:with-msg + "Improper usage of type constructor ListA: \\(ListA X X\\), expected = 1 arguments") + +(typecheck-fail (CA 1 NA)) +(check-type (CA 1 NB) : (ListA Int)) +(check-type (CA 1 (CB 2 NA)) : (ListA Int)) +(typecheck-fail (CA 1 (CB 2 NB))) +(typecheck-fail (CB 1 NB)) +(check-type (CB 1 NA) : (ListB Int)) +(check-type (CB 1 (CA 2 NB)) : (ListB Int)) +(typecheck-fail (CB 1 (CA 2 NA))) + +(check-type + (match (CA 1 NB) with + [NA -> 0] + [CA x xs -> x]) : Int -> 1) + +(check-type + (match (CA 1 (CB 2 NA)) with + [NA -> 0] + [CA x xs -> + (match xs with + [NB -> 3] + [CB x xs -> x])]) : Int -> 2) + +;; "real world" mutually referential datatypes +(define-type (BankersDeque A) + [BD Int (List A) Int (List A)]) + +(define-type (ImplicitCatDeque A) + [Shallow (BankersDeque A)] + [Deep (BankersDeque A) + (ImplicitCatDeque (BankersDeque (CmpdElem (BankersDeque A)))) + (BankersDeque A) + (ImplicitCatDeque (BankersDeque (CmpdElem (BankersDeque A)))) + (BankersDeque A)]) + +(define-type (CmpdElem A) + [Simple (BankersDeque A)] + [Cmpd (BankersDeque A) + (ImplicitCatDeque + (BankersDeque (CmpdElem (BankersDeque A)))) (BankersDeque A)]) + +(define (id (icd : (ImplicitCatDeque Int)) → (ImplicitCatDeque Int)) + icd) + diff --git a/typed-lang-builder/examples/tests/mlish/match2.mlish b/typed-lang-builder/examples/tests/mlish/match2.mlish @@ -0,0 +1,298 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; alternate match that supports nested patterns + +(define-type (Test X) + (A X) + (B (× X X)) + (C (× X (× X X)))) + +(typecheck-fail + (match2 (B (tup 2 3)) with + [B x -> x]) + #:with-msg "clauses not exhaustive; missing: A, C") + +(typecheck-fail + (match2 (B (tup 2 3)) with + [A x -> x] + [C (x,y) -> y] + [B x -> x]) #:with-msg "branches have incompatible types: Int and \\(× Int Int\\)") + +(typecheck-fail + (match2 (B (tup 2 3)) with + [A x -> (tup x x)] + [C x -> x] + [B x -> x]) + #:with-msg "branches have incompatible types: \\(× Int Int\\) and \\(× Int \\(× Int Int\\)\\)") + +(check-type + (match2 (B (tup 2 3)) with + [A x -> (tup x x)] + [C (x,y) -> y] + [B x -> x]) : (× Int Int) -> (list 2 3)) + +(typecheck-fail + (match2 (A (tup 2 3)) with + [A x -> x]) #:with-msg "clauses not exhaustive; missing: B, C") + +(check-type + (match2 (A (tup 2 3)) with + [B (x,y) -> y] + [C (x,y) -> x] + [A x -> x]) : (× Int Int) -> (list 2 3)) + +(check-type + (match2 (A (tup 2 3)) with + [B (x,y) -> y] + [A x -> x] + [C (x,y) -> x]) : (× Int Int) -> (list 2 3)) + +(typecheck-fail + (match2 (A (tup 2 3)) with + [B (x,y) -> y] + [A x -> x] + [C x -> x]) #:with-msg "branches have incompatible types") + +(check-type + (match2 (A 1) with + [A x -> x] + [_ -> -1]) : Int -> 1) + +(typecheck-fail + (match2 (B 1) with + [B x -> x]) + #:with-msg "expected: \\(× X X\\)\n *given: Int") + +(check-type + (match2 (B (tup 2 3)) with + [B (tup x y) -> (+ x y)] + [_ -> -1]) : Int -> 5) + +(check-type + (match2 (C (tup 2 (tup 3 4))) with + [C (tup x (tup y z)) -> (+ x (+ y z))] + [_ -> -1]) : Int -> 9) + +(check-type + (match2 (C (tup 2 (tup 3 4))) with + [A x -> x] + [_ -> 100]) : Int -> 100) + + + +;; lists + +(typecheck-fail + (match2 (list 1) with + [list x -> x]) #:with-msg "missing nil clause") + +(typecheck-fail + (match2 (list 1) with + [nil -> 0] + [list x -> x]) + #:with-msg "missing clause for non-empty, arbitrary length list") + +(check-type + (match2 (list 1) with + [nil -> 0] + [x :: xs -> x]) : Int -> 1) + +(check-type + (match2 (list 1) with + [nil -> 0] + [list x -> x] + [x :: xs -> x]) : Int -> 1) + +(check-type + (match2 (list 1) with + [list -> 0] + [list x -> x] + [x :: xs -> x]) : Int -> 1) + +(check-type + (match2 (list 1) with + [list x -> x] + [_ -> 0]) : Int -> 1) + +(check-type + (match2 (list 1) with + [x :: xs -> x] + [nil -> 0]) : Int -> 1) + +(check-type + (match2 (list 1) with + [_ -> -1] + [list x -> x] + [nil -> 0]) : Int -> -1) + +(check-type + (match2 (list 1) with + [_ -> -1] + [list x -> x] + [list -> 0]) : Int -> -1) + +(check-type + (match2 (list 1) with + [_ -> 0]) : Int -> 0) + +(typecheck-fail + (match2 (list 1) with + [nil -> 0]) + #:with-msg "missing clause for non-empty, arbitrary length list") + +(check-type + (match2 (list 1 2) with + [list x y -> (+ x y)] + [_ -> 0]) : Int -> 3) + +(check-type + (match2 (list 1 2) with + [list -> 0] + [list x y -> (+ x y)] + [_ -> -1]) : Int -> 3) + +(check-type + (match2 (list (list 3 4) (list 5 6)) with + [list -> 0] + [list (list w x) (list y z) -> (+ (+ x y) (+ z w))] + [_ -> -1]) : Int -> 18) + +(check-type + (match2 (list (tup 3 4) (tup 5 6)) with + [list -> 0] + [list (tup w x) (tup y z) -> (+ (+ x y) (+ z w))] + [_ -> -1]) : Int -> 18) + +(check-type + (match2 (nil {Int}) with + [nil -> 0] + [list x y -> (+ x y)] + [_ -> -1]) : Int -> 0) + +(check-type + (match2 (list 1 2) with + [nil -> 0] + [list x y -> (+ x y)] + [_ -> -1]) : Int -> 3) + +(check-type + (match2 (list 1 2 3) with + [nil -> 0] + [list x y -> (+ x y)] + [_ -> -1]) : Int -> -1) + +;; 0-arity constructors +(define-type (Test2 X) + AA + (BB X)) + +(check-type + (match2 (BB 1) with + [AA -> 0] + [BB x -> x]) : Int -> 1) + +(check-type + (match2 (BB (AA {Int})) with + [AA -> 0] + [BB AA -> 1] + [_ -> 2]) : Int -> 1) + +;; drop parens around 0-arity constructors +(check-type + (match2 (BB 1) with + [AA -> 0] + [BB x -> x]) : Int -> 1) + +(check-type + (match2 (BB (AA {Int})) with + [AA -> 0] + [BB AA -> 1] + [_ -> 2]) : Int -> 1) + +;; nicer cons pattern syntax (::) +(check-type + (match2 (list 1 2) with + [nil -> -1] + [x :: xs -> x]) + : Int -> 1) + +(check-type + (match2 (list 1 2) with + [nil -> -1] + [x :: y :: xs -> y]) : Int -> 2) + +(check-type + (match2 (list (tup 1 2) (tup 3 4)) with + [nil -> -1] + [(tup x y) :: (tup a b) :: xs -> (+ a b)]) : Int -> 7) + +(check-type + (match2 (list (list 2 3 4) (list 5 6 7) (list 9 10)) with + [nil -> -1] + [x :: (y :: z :: zs) :: xs -> z]) : Int -> 6) + +(check-type + (match2 (list (list 2 3 4) (list 5 6 7) (list 9 10)) with + [nil -> -1] + [x :: (list a b c) :: xs -> c]) : Int -> 7) + +(typecheck-fail + (match2 (list (list #t #f)) with + [nil -> -1] + [(list x y) :: tl -> (+ x y)]) + #:with-msg "expected: Int\n *given: Bool") + +;; comma tup pattern syntax + +(check-type + (match2 (tup 1 2) with + [(x,y) -> (+ x y)]) : Int -> 3) + +(check-type + (match2 (tup 1 2 4) with + [(_,y,z) -> (+ z y)]) : Int -> 6) + +(check-type + (match2 (list (tup 1 2) (tup 3 4) (tup 5 6)) with + [(x,y) :: (a,b) :: rst -> (+ y a)] + [_ -> -1]) : Int -> 5) + +(check-type + (match2 (list (tup (BB 1) (AA {Int})) (tup (BB 2) (AA {Int}))) with + [((BB x),AA) :: ((BB y),AA) :: rst -> (+ y x)] + [_ -> -1]) : Int -> 3) + +(check-type + (match2 (tup (tup (tup 1 2) (tup 3)) (tup 4 (tup 6 7))) with + [(((x,y),z),(a,(b,c))) -> (+ c y)]) : Int -> 9) + +(check-type + (match2 (tup (tup (tup 1 2) (tup 3)) (tup 4 (tup 6 7))) with + [(((x,y),z),(_,(_,c))) -> (+ c y)]) : Int -> 9) + +(check-type + (match2 (tup (tup (tup 1 2) (tup 3)) (tup 4 (tup 6 7))) with + [(((_,y),_),(_,(_,c))) -> (+ c y)]) : Int -> 9) + +(typecheck-fail + (match2 (tup (BB 1) (BB 2)) with + [((BB x),(BB y)) -> (+ x y)]) + #:with-msg "clauses not exhaustive; missing: AA") + +;; TODO: should tail +#;(typecheck-fail + (match2 (tup (BB 1) (BB 2)) with + [((BB x),(BB y)) -> (+ x y)] + [(AA,AA) -> 0]) + #:with-msg "clauses not exhaustive; missing: AA") + +;; falls off; runtime match exception +#;(match2 (tup (BB 2) (AA {Int})) with + [((BB x),(BB y)) -> (+ x y)] + [(AA,AA) -> 0]) + +(check-type + (match2 (tup (BB 1) (BB 2)) with + [((BB x),(BB y)) -> (+ x y)] + [_ -> -1]) : Int -> 3) diff --git a/typed-lang-builder/examples/tests/mlish/matrix.mlish b/typed-lang-builder/examples/tests/mlish/matrix.mlish @@ -0,0 +1,73 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type-alias Matrix (Vector (Vector Int))) + +(define size 30) + +(define (vector-map [f : (→ X Y)] [v : (Vector X)] -> (Vector Y)) + (for/vector ([x (in-vector v)]) (f x))) + +(define (mkmatrix [rows : Int] [cols : Int] -> Matrix) + (for/vector ([i (in-range rows)] + [count (in-range 1 (* rows cols) cols)]) + (for/vector ([j (in-range cols)] + [x (in-naturals count)]) + x))) + +(check-type (mkmatrix 3 4) : Matrix + -> (vector (vector 1 2 3 4) + (vector 5 6 7 8) + (vector 9 10 11 12))) + +(check-type (mkmatrix 3 3) + : Matrix + -> (vector (vector 1 2 3) + (vector 4 5 6) + (vector 7 8 9))) + +(check-type (mkmatrix 4 3) + : Matrix + -> (vector (vector 1 2 3) + (vector 4 5 6) + (vector 7 8 9) + (vector 10 11 12))) + +(define (num-cols [mx : Matrix] -> Int) + (let ((row (vector-ref mx 0))) + (vector-length row))) + +(define (num-rows [mx : Matrix] -> Int) + (vector-length mx)) + +(define (vec-mult [v1 : (Vector Int)] [v2 : (Vector Int)] -> Int) + (for/sum ([x (in-vector v1)] + [y (in-vector v2)]) + (* x y))) + +(define (mmult [m1 : Matrix] [m2 : Matrix] -> Matrix) + (for/vector ([row (in-vector m1)]) + (for/vector ([col-num (in-range (num-cols m2))]) + (let ([col + (vector-map + (λ ([r : (Vector Int)]) (vector-ref r col-num)) + m2)]) + (vec-mult row col))))) + +(check-type (mmult (mkmatrix 3 3) (mkmatrix 3 3)) + : Matrix + -> (vector (vector 30 36 42) + (vector 66 81 96) + (vector 102 126 150))) + +(check-type (mmult (mkmatrix 2 3) (mkmatrix 3 2)) + : Matrix + -> (vector (vector 22 28) + (vector 49 64))) + +(check-type (mmult (mkmatrix 4 3) (mkmatrix 3 4)) + : Matrix + -> (vector (vector 38 44 50 56) + (vector 83 98 113 128) + (vector 128 152 176 200) + (vector 173 206 239 272))) diff --git a/typed-lang-builder/examples/tests/mlish/nbody.mlish b/typed-lang-builder/examples/tests/mlish/nbody.mlish @@ -0,0 +1,185 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define +pi+ 3.141592653589793) + +(check-type +pi+ : Float) + +(define +days-per-year+ 365.24) + +(define * fl*) + +(define +solar-mass+ (* 4.0 (* +pi+ +pi+))) + +(check-type +solar-mass+ : Float) + +(define +dt+ 0.01) + +(define-type Body (body Float ; x + Float ; y + Float ; z + Float ; vx + Float ; vy + Float ; vz + Float ; mass + )) + +(define *sun* + (body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+)) + +(define *jupiter* + (body 4.84143144246472090 + -1.16032004402742839 + -1.03622044471123109e-1 + (* 1.66007664274403694e-3 +days-per-year+) + (* 7.69901118419740425e-3 +days-per-year+) + (* -6.90460016972063023e-5 +days-per-year+) + (* 9.54791938424326609e-4 +solar-mass+))) + +(define *saturn* + (body 8.34336671824457987 + 4.12479856412430479 + -4.03523417114321381e-1 + (* -2.76742510726862411e-3 +days-per-year+) + (* 4.99852801234917238e-3 +days-per-year+) + (* 2.30417297573763929e-5 +days-per-year+) + (* 2.85885980666130812e-4 +solar-mass+))) + +(define *uranus* + (body 1.28943695621391310e1 + -1.51111514016986312e1 + -2.23307578892655734e-1 + (* 2.96460137564761618e-03 +days-per-year+) + (* 2.37847173959480950e-03 +days-per-year+) + (* -2.96589568540237556e-05 +days-per-year+) + (* 4.36624404335156298e-05 +solar-mass+))) + +(define *neptune* + (body 1.53796971148509165e+01 + -2.59193146099879641e+01 + 1.79258772950371181e-01 + (* 2.68067772490389322e-03 +days-per-year+) + (* 1.62824170038242295e-03 +days-per-year+) + (* -9.51592254519715870e-05 +days-per-year+) + (* 5.15138902046611451e-05 +solar-mass+))) + +(define *system* (list *sun* *jupiter* *saturn* *uranus* *neptune*)) + +(check-type *system* : (List Body)) + +(define (offset-momentum -> Unit) + (let loop-i : Unit + ([i *system*] [px 0.0] [py 0.0] [pz 0.0]) + (cond + [(isnil i) + (match (head *system*) with ; sun + [body x y z vx vy vz m -> + (let ([new + (body x y z + (fl/ (fl- 0.0 px) +solar-mass+) + (fl/ (fl- 0.0 py) +solar-mass+) + (fl/ (fl- 0.0 pz) +solar-mass+) + m)]) + (set! *system* (cons new (tail *system*))))])] + [else + (match (head i) with + [body x y z vx vy vz m -> + (loop-i (tail i) + (fl+ px (fl* vx m)) + (fl+ py (fl* vy m)) + (fl+ pz (fl* vz m)))])]))) + +(define (energy [o : (List Body)] -> Float) + (let loop-o : Float ([o o] [e 0.0]) + (cond + [(isnil o) e] + [else + (match (head o) with + [body x y z vx vy vz m -> + (let* ([e (fl+ e (fl* 0.5 + (fl* m + (fl+ (fl+ (fl* vx vx) + (fl* vy vy)) + (fl* vz vz)))))]) + (let loop-i : Float ([i (tail o)] [e e]) + (if (isnil i) + (loop-o (tail o) e) + (match (head i) with + [body x2 y2 z2 vx2 vy2 vz2 m2 -> + (let* ([dx (fl- x x2)] + [dy (fl- y y2)] + [dz (fl- z z2)] + [dist (flsqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) + (fl* dz dz)))] + [e (fl- e (fl/ (fl* m m2) dist))]) + (loop-i (tail i) e))]))))])]))) + +(define (advance [bs : (List Body)] -> (List Body)) + (if (isnil bs) + bs + (let ([new (advance2 bs)]) + (cons (head new) (advance (tail new)))))) +;; bs is non-null +(define (advance2 [bs : (List Body)] -> (List Body)) + (match (head bs) with + [body o1x o1y o1z vx vy vz om -> + (let loop-i : (List Body) + ([i (tail bs)] [res (nil {Body})] [vx vx] [vy vy] [vz vz]) + (cond + [(isnil i) + (cons + (body + (fl+ o1x (fl* +dt+ vx)) + (fl+ o1y (fl* +dt+ vy)) + (fl+ o1z (fl* +dt+ vz)) + vx vy vz om) + (reverse res))] + [else + (match (head i) with + [body i1x i1y i1z i1vx i1vy i1vz im -> + (let* ([dx (fl- o1x i1x)] + [dy (fl- o1y i1y)] + [dz (fl- o1z i1z)] + [dist2 (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz))] + [mag (fl/ +dt+ (fl* dist2 (flsqrt dist2)))] + [dxmag (fl* dx mag)] + [dymag (fl* dy mag)] + [dzmag (fl* dz mag)]) + (loop-i + (tail i) + (cons (body i1x i1y i1z + (fl+ i1vx (fl* dxmag om)) + (fl+ i1vy (fl* dymag om)) + (fl+ i1vz (fl* dzmag om)) + im) res) + (fl- vx (fl* dxmag im)) + (fl- vy (fl* dymag im)) + (fl- vz (fl* dzmag im))))])]))])) + +(check-type (real->decimal-string (energy *system*) 9) + : String -> "-0.169289903") + +(offset-momentum) + +(check-type (real->decimal-string (energy *system*) 9) + : String -> "-0.169075164") + +(check-type + (real->decimal-string + (energy (advance *system*)) + 9) + : String -> "-0.169074954") + +(check-type + (real->decimal-string + (energy (advance (advance *system*))) 9) + : String -> "-0.169074743") + +(check-type + (real->decimal-string + (energy + (for/fold ([bs *system*]) + ([i (in-range 10)]) + (advance bs))) + 9) + : String -> "-0.169073022") diff --git a/typed-lang-builder/examples/tests/mlish/polyrecur.mlish b/typed-lang-builder/examples/tests/mlish/polyrecur.mlish @@ -0,0 +1,117 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; tests of polymorphic recursion + +;; polymorphic recursion of functions +(define (polyf [lst : (List X)] -> (List X)) + (let ([x (polyf (list 1 2 3))] + [y (polyf (list #t #f))]) + (polyf lst))) + +;; polymorphic recursive type +;; from okasaki, ch10 +(define-type (Seq X) + Nil + (Cons X (Seq (× X X)))) + +(define (size [s : (Seq X)] -> Int) + (match s with + [Nil -> 0] + [Cons x ps -> (add1 (* 2 (size ps)))])) + +(check-type (size (Nil {Int})) : Int -> 0) +(check-type (size (Cons 1 Nil)) : Int -> 1) +(check-type (size (Cons 1 (Cons (tup 2 3) Nil))) : Int -> 3) +(check-type + (size (Cons 1 (Cons (tup 2 3) (Cons (tup (tup 4 5) (tup 6 7)) Nil)))) + : Int -> 7) + +;; implicit queue +(define-type (Digit X) + (Zero) + (One X) + (Two X X)) + +(define-type (ImplicitQueue X) + [Shallow (d : (Digit X))] + [Deep (f : (Digit X)) + (m : (ImplicitQueue (× X X))) + (r : (Digit X))]) + +(define (empty -> (ImplicitQueue X)) + (Shallow (Zero))) + +(define (iq-isEmpty [iq : (ImplicitQueue A)] → Bool) + (match iq with + [Shallow d -> + (match d with + [Zero -> #t] + [One x -> #f] + [Two x y -> #f])] + [Deep a b c -> #f])) + +(define (iq-snoc [iq : (ImplicitQueue A)] [y : A] → (ImplicitQueue A)) + (match iq with + [Shallow d -> + (match d with + [Zero -> (Shallow (One y))] + [One x -> (Deep (Two x y) (empty) Zero)] + [Two x y -> (empty)])] ;; Error + [Deep f m d -> + (match d with + [Zero -> (Deep f m (One y))] + [One x -> (Deep f (iq-snoc m (tup x y)) Zero)] + [Two x y -> (empty)])])) ; Error + +(check-type (iq-isEmpty (Shallow (Zero {Int}))) : Bool -> #t) + +(check-type (iq-isEmpty (iq-snoc (Shallow (Zero {Int})) 5)) : Bool -> #f) + +;; example from: +;; blogs.janestreet.com/ensuring-that-a-function-is-polymorphic-in-ocaml-3-12 + +(define-type (PerfectTree X) + (Leaf X) + (Node X (PerfectTree (× X X)))) +(define (flatten [t : (PerfectTree X)] -> (List X)) + (match t with + [Leaf x -> (list x)] + [Node x rst -> + (cons x + (for/fold ([acc nil]) ([p (in-list (flatten rst))]) + (match p with + [x y -> (cons x (cons y acc))])))])) + +(check-type (flatten (Leaf 1)) : (List Int) -> (list 1)) +(check-type (flatten (Node 1 (Leaf (tup 2 3)))) : (List Int) -> (list 1 2 3)) +(check-type + (flatten (Node 1 (Node (tup 2 3) (Leaf (tup (tup 4 5) (tup 6 7)))))) + : (List Int) -> (list 1 6 7 4 5 2 3)) + + +;; catch type constructor arity error; should not loop +(define-type (BankersDeque A) + [BD Int (List A) Int (List A)]) + +(typecheck-fail + (define-type (ImplicitCatDeque A) + [Shall (BankersDeque A)] + [Dp (BankersDeque A) + (ImplicitCatDeque (BankersDeque A) (CmpdElem (BankersDeque A))) + (BankersDeque A) + (ImplicitCatDeque (BankersDeque A) (CmpdElem (BankersDeque A))) + (BankersDeque A)]) + #:with-msg "Improper use of constructor ImplicitCatDeque; expected 1 args, got 2") + +#;(define-type (CmpdElem A) + [Simple (BankersDeque A)] + [Cmpd (BankersDeque A) + (ImplicitCatDeque (BankersDeque (CmpdElem (BankersDeque A)))) + (BankersDeque A)]) + + +#;(typecheck-fail + (λ ([icd : (ImplicitCatDeque A)]) icd) + #:with-msg + "type constructor ImplicitCatDeque expects 1 args, given 2") diff --git a/typed-lang-builder/examples/tests/mlish/queens.mlish b/typed-lang-builder/examples/tests/mlish/queens.mlish @@ -0,0 +1,186 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; function polymorphic in list element +(define-type (List X) + Nil + (Cons X (List X))) + +(typecheck-fail + (match (Cons 1 Nil) with + [Nil -> 1]) + #:with-msg "clauses not exhaustive; missing\\: Cons") +(typecheck-fail + (match (Cons 1 Nil) with + [Cons x xs -> 1]) + #:with-msg "clauses not exhaustive; missing: Nil") + +;; list fns ---------- + +; map: tests whether match and define properly propagate 'expected-type +(define (map [f : (→ X Y)] [lst : (List X)] → (List Y)) + (match lst with + [Nil -> Nil] + [Cons x xs -> (Cons (f x) (map f xs))])) +(check-type map : (→/test (→ X Y) (List X) (List Y))) +(check-type map : (→/test {Y X} (→ Y X) (List Y) (List X))) +(check-type map : (→/test (→ A B) (List A) (List B))) +(check-not-type map : (→/test (→ A B) (List B) (List A))) +(check-not-type map : (→/test (→ X X) (List X) (List X))) ; only 1 bound tyvar + +; map: alt signature syntax +(define (map2 f lst) + : (→ X Y) (List X) → (List Y) + (match lst with + [Nil -> Nil] + [Cons x xs -> (Cons (f x) (map2 f xs))])) +(check-type map2 : (→/test (→ X Y) (List X) (List Y))) +(check-type map2 : (→/test {Y X} (→ Y X) (List Y) (List X))) +(check-type map2 : (→/test (→ A B) (List A) (List B))) +(check-not-type map2 : (→/test (→ A B) (List B) (List A))) +(check-not-type map2 : (→/test (→ X X) (List X) (List X))) ; only 1 bound tyvar + +; nil without annotation; tests fn-first, left-to-right arg inference +; does work yet, need to add left-to-right inference in #%app +(check-type (map add1 Nil) : (List Int) ⇒ Nil) +(check-type (map add1 (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ (Cons 2 (Cons 3 (Cons 4 Nil)))) +(typecheck-fail (map add1 (Cons "1" Nil)) + #:with-msg "expected: Int\n *given: String") +(check-type (map (λ ([x : Int]) (+ x 2)) (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ (Cons 3 (Cons 4 (Cons 5 Nil)))) +;; ; doesnt work yet: all lambdas need annotations +;; (check-type (map (λ (x) (+ x 2)) (list 1 2 3)) : (List Int) ⇒ (list 3 4 5)) + +(define (filter [p? : (→ X Bool)] [lst : (List X)] → (List X)) + (match lst with + [Nil -> Nil] + [Cons x xs -> (if (p? x) + (Cons x (filter p? xs)) + (filter p? xs))])) +(define (filter/guard [p? : (→ X Bool)] [lst : (List X)] → (List X)) + (match lst with + [Nil -> Nil] + [Cons x xs #:when (p? x) -> (Cons x (filter p? xs))] + [Cons x xs -> (filter p? xs)])) +(check-type (filter zero? Nil) : (List Int) ⇒ Nil) +(check-type (filter zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ Nil) +(check-type (filter zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 0 Nil)) +(check-type + (filter + (λ ([x : Int]) (not (zero? x))) + (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) +(check-type (filter/guard zero? Nil) : (List Int) ⇒ Nil) +(check-type (filter/guard zero? (Cons 1 (Cons 2 (Cons 3 Nil)))) + : (List Int) ⇒ Nil) +(check-type (filter/guard zero? (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 0 Nil)) +(check-type + (filter/guard + (λ ([x : Int]) (not (zero? x))) + (Cons 0 (Cons 1 (Cons 2 Nil)))) + : (List Int) ⇒ (Cons 1 (Cons 2 Nil))) +; doesnt work yet: all lambdas need annotations +;(check-type (filter (λ (x) (not (zero? x))) (list 0 1 2)) : (List Int) ⇒ (list 1 2)) + +(define (foldr [f : (→ X Y Y)] [base : Y] [lst : (List X)] → Y) + (match lst with + [Nil -> base] + [Cons x xs -> (f x (foldr f base xs))])) +(define (foldl [f : (→ X Y Y)] [acc : Y] [lst : (List X)] → Y) + (match lst with + [Nil -> acc] + [Cons x xs -> (foldr f (f x acc) xs)])) + +(define (all? [p? : (→ X Bool)] [lst : (List X)] → Bool) + (match lst with + [Nil -> #t] + [Cons x xs #:when (p? x) -> (all? p? xs)] + [Cons x xs -> #f])) + +(define (tails [lst : (List X)] → (List (List X))) + (match lst with + [Nil -> (Cons Nil Nil)] + [Cons x xs -> (Cons lst (tails xs))])) + +(define (build-list [n : Int] [f : (→ Int X)] → (List X)) + (if (zero? (sub1 n)) + (Cons (f 0) Nil) + (Cons (f (sub1 n)) (build-list (sub1 n) f)))) + +(check-type (build-list 1 add1) + : (List Int) ⇒ (Cons 1 Nil)) +(check-type (build-list 3 add1) + : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 Nil)))) +(check-type (build-list 5 sub1) + : (List Int) ⇒ (Cons 3 (Cons 2 (Cons 1 (Cons 0 (Cons -1 Nil)))))) + +;; map + filter + fold + build example +(define INPUT (build-list 1000 number->string)) +(check-type (foldl + 0 (filter even? (map string->number INPUT))) : Int -> 249500) + +(define (append [lst1 : (List X)] [lst2 : (List X)] → (List X)) + (match lst1 with + [Nil -> lst2] + [Cons x xs -> (Cons x (append xs lst2))])) + +;; n-queens -------------------- +(define-type Queen (Q Int Int)) + +(define (safe? [q1 : Queen] [q2 : Queen] → Bool) + (match q1 with + [Q x1 y1 -> + (match q2 with + [Q x2 y2 -> + (not (or (= x1 x2) + (= y1 y2) + (= (abs (- x1 x2)) + (abs (- y1 y2)))))])])) + +(define (safe/list? [qs : (List Queen)] → Bool) + (match qs with + [Nil -> #t] + [Cons q1 rst -> + (all? (λ ([q2 : Queen]) (safe? q1 q2)) rst)])) + +(define (valid? [lst : (List Queen)] → Bool) + (all? safe/list? (tails lst))) + +(define (nqueens [n : Int] → (List Queen)) + (let* ([process-row + (λ ([r : Int] + [all-possible-so-far : (List (List Queen))]) + (foldr + (λ ([qs : (List Queen)] + [new-qss : (List (List Queen))]) + (append + (map + (λ ([c : Int]) (Cons (Q r c) qs)) + (build-list n add1)) + new-qss)) + Nil + all-possible-so-far))] + [all-possible + (foldl process-row + (Cons Nil Nil) + (build-list n add1))]) + (let ([solns (filter valid? all-possible)]) + (match solns with + [Nil -> Nil] + [Cons x xs -> x])))) + +(check-type nqueens : (→ Int (List Queen))) +(check-type (nqueens 1) : (List Queen) ⇒ (Cons (Q 1 1) Nil)) +(check-type (nqueens 2) : (List Queen) ⇒ Nil) +(check-type (nqueens 3) : (List Queen) ⇒ Nil) +(check-type (nqueens 4) + : (List Queen) + ⇒ (Cons (Q 3 1) (Cons (Q 2 4) + (Cons (Q 1 2) (Cons (Q 4 3) Nil))))) +(check-type (nqueens 5) + : (List Queen) + ⇒ (Cons (Q 4 2) (Cons (Q 3 4) + (Cons (Q 2 1) (Cons (Q 1 3) (Cons (Q 5 5) Nil)))))) diff --git a/typed-lang-builder/examples/tests/mlish/result.mlish b/typed-lang-builder/examples/tests/mlish/result.mlish @@ -0,0 +1,129 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt" "../../mlish-do.rkt") + +(define-type (Result A B) + (Ok A) + (Error B)) + +(define (ok [a : A] → (Result A B)) + (Ok a)) +(define (error [b : B] → (Result A B)) + (Error b)) + +(provide-type Result) +(provide ok) +(provide error) + +(check-type ok : (→/test A (Result A B))) +(check-type error : (→/test B (Result A B))) +(check-type (inst ok Int String) : (→ Int (Result Int String))) +(check-type (inst error String Int) : (→ String (Result Int String))) + +(check-type + (list (Ok 3) (Error "abject failure") (Ok 4)) + : (List (Result Int String)) + -> (list (Ok 3) (Error "abject failure") (Ok 4))) + +(define (result-bind [a : (Result A Er)] [f : (→ A (Result B Er))] + → (Result B Er)) + (match a with + [Ok v -> (f v)] + [Error er -> (Error er)])) + +(provide result-bind) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; read-tree, a function that parses a tree and uses the result monad. + +(require "trees.mlish") + +;; Parsing 42 in base 10: (rev-list->int 10 (list 2 4) 1 0) yields 42. +(define (rev-list->int [base : Int] [rev-list : (List Int)] [place : Int] [accum : Int] → Int) + (cond + [(isnil rev-list) accum] + [else (rev-list->int base + (tail rev-list) + (* base place) + (+ accum (* place (head rev-list))))])) + +(define (digit? [c : Char] → Bool) + (or (equal? c #\0) + (equal? c #\1) + (equal? c #\2) + (equal? c #\3) + (equal? c #\4) + (equal? c #\5) + (equal? c #\6) + (equal? c #\7) + (equal? c #\8) + (equal? c #\9))) + +(define (digit->int [c : Char] → Int) + (string->number (string c))) + +(define-type-alias (Read-Result A) (Result (× A (List Char)) String)) + +(define (read-int [str : (List Char)] [accum : (List Int)] → (Read-Result Int)) + (cond + [(isnil str) + (cond [(isnil accum) (error "expected an int, given nothing")] + [else (ok (tup (rev-list->int 10 accum 1 0) str))])] + [(digit? (head str)) + (read-int (tail str) (cons (digit->int (head str)) accum))] + [else + (ok (tup (rev-list->int 10 accum 1 0) str))])) + +(define (read-tree [str : (List Char)] → (Read-Result (Tree Int))) + (cond + [(isnil str) + (error "expected a tree of integers, given nothing")] + [(equal? (head str) #\( ) + (let ([do-ok (inst ok Unit String)] + [do-error (inst error String Unit)]) + (do result-bind + [tree1+str <- (read-tree (tail str))] + [(cond [(equal? (head (proj tree1+str 1)) #\space) + (do-ok (void))] + [else (do-error "expected a space")])] + [int+str <- (read-int (tail (proj tree1+str 1)) nil)] + [(cond [(equal? (head (proj int+str 1)) #\space) + (do-ok (void))] + [else (do-error "expected a space")])] + [tree2+str <- (read-tree (tail (proj int+str 1)))] + [(cond [(equal? (head (proj tree2+str 1)) #\) ) + (do-ok (void))] + [else (do-error "expected a `)`")])] + (ok + (tup (Node (proj tree1+str 0) + (proj int+str 0) + (proj tree2+str 0)) + (tail (proj tree2+str 1))))))] + [(digit? (head str)) + (do result-bind + [int+str <- (read-int str nil)] + (ok + (tup (Leaf (proj int+str 0)) + (proj int+str 1))))] + [else + (error "expected either a `(` or a digit")])) + +(check-type + (read-tree (string->list "42")) + : (Read-Result (Tree Int)) + -> (ok + (tup (Leaf 42) nil))) + +(check-type + (read-tree (string->list "x")) + : (Read-Result (Tree Int)) + -> (error + "expected either a `(` or a digit")) + +(check-type + (read-tree (string->list "(42 43 (44 45 46))")) + : (Read-Result (Tree Int)) + -> (ok + (tup (Node (Leaf 42) 43 (Node (Leaf 44) 45 (Leaf 46))) nil))) + + diff --git a/typed-lang-builder/examples/tests/mlish/sweet-map.rkt b/typed-lang-builder/examples/tests/mlish/sweet-map.rkt @@ -0,0 +1,20 @@ +#lang sweet-exp "../../mlish.rkt" + +define + sum [lst : (List Int)] → Int + match lst with + [] -> 0 + x :: xs -> + {x + sum(xs)} + +define + map [f : (→ X Y)] [lst : (List X)] → (List Y) + match lst with + [] -> nil + x :: xs -> + cons + f x + map f xs + +sum + map string->number (list "1" "2" "3") diff --git a/typed-lang-builder/examples/tests/mlish/term.mlish b/typed-lang-builder/examples/tests/mlish/term.mlish @@ -0,0 +1,295 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +;; from chap 6 of RW OCaml + +;; checks: +;; - nested recursive types (see expr) +;; - labeled adts +;; - records +;; - ho polymorphic fn argument + +(define-type BasicColor + Black + Red + Green + Yellow + Blue + Magenta + Cyan + White) + +(check-type Cyan : BasicColor) + +(check-type (list Blue Magenta Red) : (List BasicColor)) + +(define (basic-color->int [c : BasicColor] -> Int) + (match c with + [Black -> 0] [Red -> 1] [Green -> 2] [Yellow -> 3] + [Blue -> 4] [Magenta -> 5] [Cyan -> 6] [White -> 7])) + +(define (map [f : (→ X Y)] [lst : (List X)] -> (List Y)) + (if (isnil lst) + nil + (cons (f (head lst)) (map f (tail lst))))) + +(check-type (map basic-color->int (list Blue Red)) + : (List Int) -> (list 4 1)) + +(define (color-by-number [n : Int] [txt : String] -> String) + (format "\e[38;5;~am~a\e[0m" n txt)) + +(define blue + (color-by-number (basic-color->int Blue) "Blue")) + +(check-type blue : String -> "\e[38;5;4mBlue\e[0m") + +(printf "Hello ~a World!\n" blue) + +(define-type Weight Regular Bold) +(define-type Color + (Basic BasicColor Weight) + (RGB Int Int Int) + (Gray Int)) + +(check-type (list (RGB 250 70 70) (Basic Green Regular)) + : (List Color)) + +(define (color->int [c : Color] -> Int) + (match c with + [Basic bc w -> + (let ([base (match w with [Bold -> 8] [Regular -> 0])]) + (+ base (basic-color->int bc)))] + [RGB r g b -> + (+ 16 (+ b (+ (* g 6) (* r 36))))] + [Gray i -> (+ 232 i)])) + +(define (color-print [c : Color] [s : String] -> Unit) + (printf "~a\n" (color-by-number (color->int c) s))) + +(color-print (Basic Red Bold) "A bold red!") +(color-print (Gray 4) "A muted gray...") + +;; refactoring Color and Weight +(define-type NewColor + (NewBasic BasicColor) + (NewBold BasicColor) + (NewRGB Int Int Int) + (NewGray Int)) + +(typecheck-fail + (match (NewGray 1) with + [Basic bc w -> + (let ([base (match w with [Bold -> 8] [Regular -> 0])]) + (+ base (basic-color->int bc)))] + [RGB r g b -> + (+ 16 (+ b (+ (* g 6) (* r 36))))] + [Gray i -> (+ 232 i)]) + #:with-msg + "clauses not exhaustive; missing: NewGray, NewRGB, NewBold, NewBasic") + +(typecheck-fail + (match (NewGray 1) with + [NewBasic bc w -> + (let ([base (match w with [Bold -> 8] [Regular -> 0])]) + (+ base (basic-color->int bc)))] + [NewRGB r g b -> + (+ 16 (+ b (+ (* g 6) (* r 36))))] + [NewGray i -> (+ 232 i)]) + #:with-msg "clauses not exhaustive; missing: NewBold") + +(typecheck-fail + (match (NewGray 1) with + [NewBasic bc w -> + (let ([base (match w with [Bold -> 8] [Regular -> 0])]) + (+ base (basic-color->int bc)))] + [NewBold bc -> 1] + [NewRGB r g b -> + (+ 16 (+ b (+ (* g 6) (* r 36))))] + [NewGray i -> (+ 232 i)])) ; todo: better err msg for arity + +(check-type + (match (NewGray 1) with + [NewBasic bc -> (basic-color->int bc)] + [NewBold bc -> (+ 8 (basic-color->int bc))] + [NewRGB r g b -> + (+ 16 (+ b (+ (* g 6) (* r 36))))] + [NewGray i -> (+ 232 i)]) : Int) + +;; 2016-03-09: match currently does not support else +(define-type Details + (Logon [user : String] [credentials : String]) + (Heartbeat [status : String]) + (LogEntry [important? : Bool] [msg : String])) + +(define-type-alias SessionID String) +(define-type-alias Time String) +(define-type-alias Common (× SessionID Time)) + +(define-type-alias Msg (× Common Details)) + +(define (foldl [f : (→ X Y Y)] [init : Y] [lst : (List X)] -> Y) + (if (isnil lst) + init + (foldl f (f (head lst) init) (tail lst)))) + +(define (msgs-for-user [user : String] [msgs : (List Msg)] -> (List Msg)) + (match + (foldl + (λ ([m : Msg] [res : (× (List Msg) (List SessionID))]) + (match res with + [ms_out ids_out -> + (match m with + [common details -> + (match common with + [id t -> + (match details with + [Logon u c -> (if (string=? u user) + (tup (cons m ms_out) (cons id ids_out)) + res)] + [Heartbeat st -> (if (member id ids_out) + (tup (cons m ms_out) ids_out) + res)] + [LogEntry i? lmgs -> (if (member id ids_out) + (tup (cons m ms_out) ids_out) + res)])])])])) + (tup nil nil) + msgs) with + [msgs ids -> (reverse msgs)])) + +;; this is incomplete (and wrong, eg logentry has wrong arity) code in the book +(define (handle-msg [state : Int] [msg : Msg] -> String) + (match msg with + [common details -> + (match details with + [LogEntry i? lmsg -> lmsg] + [Logon u c -> u] + [Heartbeat s -> s])])) + +;; expr example +(define-type (Expr X) + (Base X) + (Const Bool) + (And (List (Expr X))) + (Or (List (Expr X))) + (Not (Expr X))) + +(define-type MailField To From CC Date Subject) + +(define-type-alias MailPred (×× [field : MailField] + [contains? : String])) + +(define (test [f : MailField] [c? : String] -> (Expr MailPred)) + (Base (rec [field = f] [contains? = c?]))) + +(check-type (rec [field = To] [contains = "doligez"]) + : (×× [field : MailField] [contains : String])) + +(check-type (get (rec [field = To] [contains = "doligez"]) field) + : MailField -> To) + +(check-type + (And (list (Or (list (Base (rec [field = To] [contains? = "doligez"])) + (Base (rec [field = CC] [contains? = "doligez"])))) + (Base (rec [field = Subject] [contains? = "runtime"])))) + : (Expr MailPred)) + +(define (andmap [f : (→ X Bool)] [lst : (List X)] -> Bool) + (if (isnil lst) + #t + (and (f (head lst)) (andmap f (tail lst))))) +(define (ormap [f : (→ X Bool)] [lst : (List X)] -> Bool) + (if (isnil lst) + #f + (or (f (head lst)) (ormap f (tail lst))))) + +(define (filter [p? : (→ X Bool)] [lst : (List X)] -> (List X)) + (if (isnil lst) + nil + (if (p? (head lst)) + (cons (head lst) (filter p? (tail lst))) + (filter p? (tail lst))))) + +(define (eval [e : (Expr X)] [eval-base : (→ X Bool)] -> Bool) + (let ([eval2 (λ ([e : (Expr X)]) (eval e eval-base))]) + (match e with + [Base base -> (eval-base base)] + [Const b -> b] + [And es -> (andmap eval2 es)] + [Or es -> (ormap eval2 es)] + [Not e -> (not (eval2 e))]))) + +(define (andfn [lst : (List (Expr X))] -> (Expr X)) + (if (member (Const #f) lst) + (Const #f) + (let ([lst2 + (filter (λ ([x : (Expr X)]) (not (equal? x (Const #t)))) lst)]) + (if (isnil lst2) + (Const #t) + (if (isnil (tail lst2)) + (head lst2) + (And lst2)))))) + +(define (orfn [lst : (List (Expr X))] -> (Expr X)) + (if (member (Const #t) lst) + (Const #t) + (let ([lst2 + (filter (λ ([x : (Expr X)]) (not (equal? x (Const #f)))) lst)]) + (if (isnil lst2) + (Const #f) + (if (isnil (tail lst2)) + (head lst2) + (And lst2)))))) + +(define (notfn [e : (Expr X)] -> (Expr X)) + (match e with + [Base b -> (Not e)] + [Const b -> (Const (not b))] + [And es -> (Not e)] + [Or es -> (Not e)] + [Not e2 -> (Not e)])) + +(define (simplify [e : (Expr X)] -> (Expr X)) + (match e with + [Base b -> e] + [Const x -> e] + [And es -> (andfn (map (inst simplify X) es))] + [Or es -> (orfn (map (inst simplify X) es))] + [Not e -> (notfn (simplify e))])) + +(check-type + (simplify (Not (And (list (Or (list (Base "it's snowing") + (Const #t))) + (Base "it's raining"))))) + : (Expr String) + -> (Not (Base "it's raining"))) + +(check-type + (simplify (Not (And (list (Or (list (Base "it's snowing") + (Const #t))) + (Not (Not (Base "it's raining"))))))) + : (Expr String) + -> (Not (Not (Not (Base "it's raining"))))) + +(define (notfn2 [e : (Expr X)] -> (Expr X)) + (match e with + [Const b -> (Const (not b))] + [Base b -> (Not e)] + [And es -> (Not e)] + [Or es -> (Not e)] + [Not e -> e])) + +(define (simplify2 [e : (Expr X)] -> (Expr X)) + (match e with + [Base b -> e] + [Const x -> e] + [And es -> (andfn (map (inst simplify2 X) es))] + [Or es -> (orfn (map (inst simplify2 X) es))] + [Not e -> (notfn2 (simplify2 e))])) + +(check-type + (simplify2 (Not (And (list (Or (list (Base "it's snowing") + (Const #t))) + (Not (Not (Base "it's raining"))))))) + : (Expr String) + -> (Not (Base "it's raining"))) diff --git a/typed-lang-builder/examples/tests/mlish/trees-tests.mlish b/typed-lang-builder/examples/tests/mlish/trees-tests.mlish @@ -0,0 +1,51 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") +(require "trees.mlish") + +(define (make [item : Int] [depth : Int] -> (Tree Int)) + (if (zero? depth) + (Leaf item) + (let ([item2 (* item 2)] + [depth2 (sub1 depth)]) + (Node (make (sub1 item2) depth2) + item + (make item2 depth2))))) + +(define tree1 (make 4 1)) +(define tree2 (make 3 2)) + +(check-type tree1 + : (Tree Int) -> (Node (Leaf 7) 4 (Leaf 8))) + +(check-type tree2 + : (Tree Int) + -> (Node + (Node (Leaf 9) 5 (Leaf 10)) + 3 + (Node (Leaf 11) 6 (Leaf 12)))) + +(define (sum [t : (Tree Int)] -> Int) + (match t with + [Leaf v -> v] + [Node l v r -> (+ (+ (sum l) v) (sum r))])) + +(check-type (sum tree1) : Int -> 19) +(check-type (sum tree2) : Int -> 56) + +(define (check/acc [t : (Tree Int)] [acc : Int] -> Int) + (match t with + [Leaf v -> + (+ acc v)] + [Node l v r -> + (check/acc l (- acc (check/acc r 0)))])) +(define (check [t : (Tree Int)] -> Int) + (check/acc t 0)) + +(define min-depth 4) + +(define (main [n : Int] -> Int) + (let* ([max-depth (max (+ min-depth 2) n)] + [stretch-depth (add1 max-depth)]) + (check (make 0 stretch-depth)))) + +(check-type (main 17) : Int -> 0) diff --git a/typed-lang-builder/examples/tests/mlish/trees.mlish b/typed-lang-builder/examples/tests/mlish/trees.mlish @@ -0,0 +1,8 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type (Tree X) + (Leaf X) + (Node (Tree X) X (Tree X))) + +(provide-type Tree Leaf Node) diff --git a/typed-lang-builder/examples/tests/mlish/value-restriction-example.mlish b/typed-lang-builder/examples/tests/mlish/value-restriction-example.mlish @@ -0,0 +1,25 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type (Option X) + None + (Some X)) + +(define (make-f → (→ A A)) + (let ([r (ref (None {A}))]) + (λ (x) + (let ([y (deref r)]) + (begin + (:= r (Some x)) + (match y with + [None -> x] + [Some y -> y])))))) +;; This has to fail, because if could succeed with the type (→ A A), +;; then it could cause unsoundness. +(typecheck-fail (make-f) #:with-msg "Could not infer instantiation of polymorphic function make-f.") +; ;; If f were defined as the result of (make-f), then it would result +; ;; in unsoundess if these two expressions were also accepted: +; (f 13) +; ;; Because this would typecheck as a String even though it returns 13, an Int: +; (f "foo") + diff --git a/typed-lang-builder/examples/tests/rackunit-typechecking.rkt b/typed-lang-builder/examples/tests/rackunit-typechecking.rkt @@ -0,0 +1,92 @@ +#lang racket/base +(require (for-syntax rackunit syntax/srcloc) rackunit macrotypes/typecheck) +(provide check-type typecheck-fail check-not-type check-props check-runtime-exn) + +(begin-for-syntax + (define (add-esc s) (string-append "\\" s)) + (define escs (map add-esc '("(" ")" "[" "]"))) + (define (replace-brackets str) + (regexp-replace* "\\]" (regexp-replace* "\\[" str "(") ")")) + (define (add-escs str) + (replace-brackets + (foldl (lambda (c s) (regexp-replace* c s (add-esc c))) str escs))) + (define (expected tys #:given [givens ""] #:note [note ""]) + (string-append + note ".*Expected.+argument\\(s\\) with type\\(s\\).+" + (add-escs tys) ".*Given:.*" + (string-join (map add-escs (string-split givens ", ")) ".*")))) + +(define-syntax (check-type stx) + (syntax-parse stx #:datum-literals (: ⇒ ->) + ;; duplicate code to avoid redundant expansions + [(_ e : τ-expected (~or ⇒ ->) v) + #:with e+ (expand/df #'(add-expected e τ-expected)) + #:with τ (typeof #'e+) + #:fail-unless (typecheck? #'τ ((current-type-eval) #'τ-expected)) + (format + "Expression ~a [loc ~a:~a] has type ~a, expected ~a" + (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) + (type->str #'τ) (type->str #'τ-expected)) + (syntax/loc stx (check-equal? e+ (add-expected v τ-expected)))] + [(_ e : τ-expected) + #:with τ (typeof (expand/df #'(add-expected e τ-expected))) + #:fail-unless + (typecheck? #'τ ((current-type-eval) #'τ-expected)) + (format + "Expression ~a [loc ~a:~a] has type ~a, expected ~a" + (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) + (type->str #'τ) (type->str #'τ-expected)) + #'(void)])) + +;; for checking properties other than types +(define-syntax (check-props stx) + (syntax-parse stx #:datum-literals (: ⇒ ->) + [(_ prop e : v (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e]))) + #:with props (or (syntax-property (expand/df #'e) (syntax->datum #'prop)) + #'()) + #:fail-unless (equal? (syntax->datum #'v) + (syntax->datum #'props)) + (format + "Expression ~a [loc ~a:~a:~a] does not have prop ~a, actual: ~a" + (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) (syntax-position #'e) + (syntax->datum #'v) (syntax->datum #'props)) + (syntax/loc stx (check-equal? e v2))])) + +(define-syntax (check-not-type stx) + (syntax-parse stx #:datum-literals (:) + [(_ e : not-τ) + #:with τ (typeof (expand/df #'e)) + #:fail-when + (typecheck? #'τ ((current-type-eval) #'not-τ)) + (format + "(~a:~a) Expression ~a has type ~a; should not typecheck with ~a" + (syntax-line stx) (syntax-column stx) + (syntax->datum #'e) (type->str #'τ) (type->str #'not-τ)) + #'(void)])) + +(define-syntax (typecheck-fail stx) + (syntax-parse stx #:datum-literals (:) + [(_ e (~optional (~seq #:with-msg msg-pat) #:defaults ([msg-pat #'""]))) + #:with msg:str + (eval-syntax (datum->syntax #'here (syntax->datum #'msg-pat))) + #:when (with-check-info* + (list (make-check-expected (syntax-e #'msg)) + (make-check-expression (syntax->datum stx)) + (make-check-location (build-source-location-list stx)) + (make-check-name 'typecheck-fail) + (make-check-params (list (syntax->datum #'e) (syntax-e #'msg)))) + (λ () + (check-exn + (λ (ex) + (and (or (exn:fail? ex) (exn:test:check? ex)) + ; check err msg matches + (regexp-match? (syntax-e #'msg) (exn-message ex)))) + (λ () + (expand/df #'e))))) + #'(void)])) + +(define-syntax (check-runtime-exn stx) + (syntax-parse stx + [(_ e) + #:with e- (expand/df #'e) + (syntax/loc stx (check-exn exn:fail? (lambda () e-)))])) diff --git a/tapl/tests/run-all-mlish-tests.rkt b/typed-lang-builder/examples/tests/run-all-mlish-tests.rkt diff --git a/typed-lang-builder/examples/tests/run-all-tests.rkt b/typed-lang-builder/examples/tests/run-all-tests.rkt @@ -0,0 +1,37 @@ +#lang racket + +;; stlc and extensions +(require "stlc-tests.rkt") +(require "stlc+lit-tests.rkt") +(require "ext-stlc-tests.rkt") +(require "stlc+tup-tests.rkt") +(require "stlc+reco+var-tests.rkt") +(require "stlc+cons-tests.rkt") +(require "stlc+box-tests.rkt") + +(require "stlc+rec-iso-tests.rkt") + +(require "exist-tests.rkt") + +;; subtyping +(require "stlc+sub-tests.rkt") +(require "stlc+reco+sub-tests.rkt") + +;; system F +(require "sysf-tests.rkt") + +(require "fsub-tests.rkt") ; sysf + reco-sub + +;; F_omega +(require "fomega-tests.rkt") +(require "fomega2-tests.rkt") +(require "fomega3-tests.rkt") + +(require macrotypes/examples/tests/stlc+occurrence-tests) +(require macrotypes/examples/tests/stlc+overloading-tests) + +;; type inference +(require macrotypes/examples/tests/infer-tests) + +;; type and effects +(require "stlc+effect-tests.rkt") diff --git a/tapl/tests/run-mlish-tests1.rkt b/typed-lang-builder/examples/tests/run-mlish-tests1.rkt diff --git a/tapl/tests/run-mlish-tests2.rkt b/typed-lang-builder/examples/tests/run-mlish-tests2.rkt diff --git a/tapl/tests/run-mlish-tests3.rkt b/typed-lang-builder/examples/tests/run-mlish-tests3.rkt diff --git a/tapl/tests/run-mlish-tests4.rkt b/typed-lang-builder/examples/tests/run-mlish-tests4.rkt diff --git a/typed-lang-builder/examples/tests/stlc+box-tests.rkt b/typed-lang-builder/examples/tests/stlc+box-tests.rkt @@ -0,0 +1,239 @@ +#lang s-exp "../stlc+box.rkt" +(require "rackunit-typechecking.rkt") + +(define x (ref 10)) +(check-type x : (Ref Int)) +(check-type (deref x) : Int ⇒ 10) +(check-type (:= x 20) : Unit) ; x still 10 because check-type does not evaluate +(check-type (begin (:= x 20) (deref x)) : Int ⇒ 20) +(check-type x : (Ref Int)) +(check-type (deref (ref 20)) : Int ⇒ 20) +(check-type (deref x) : Int ⇒ 20) + +(check-type ((λ ([b : (Ref Int)]) (deref b)) (ref 10)) : Int ⇒ 10) +(check-type ((λ ([b : (Ref Int)]) (begin (begin (:= b 20) (deref b)))) (ref 10)) : Int ⇒ 20) + +;; Ref err msgs +; wrong arity +(typecheck-fail + (λ ([lst : (Ref Int Int)]) lst) + #:with-msg + "Improper usage of type constructor Ref: \\(Ref Int Int\\), expected = 1 arguments") +(typecheck-fail + (λ ([lst : (Ref)]) lst) + #:with-msg + "Improper usage of type constructor Ref: \\(Ref\\), expected = 1 arguments") +(typecheck-fail + (deref 1) + #:with-msg + "Expected Ref type, got: Int") +(typecheck-fail + (:= 1 1) + #:with-msg + "Expected Ref type, got: Int") + +;; previous tests: ------------------------------------------------------------ +(typecheck-fail (cons 1 2)) +;(typecheck-fail (cons 1 nil)) ; works now +(check-type (cons 1 nil) : (List Int)) +(check-type (cons 1 (nil {Int})) : (List Int)) +(typecheck-fail nil) +(typecheck-fail (nil Int)) +(typecheck-fail (nil (Int))) +; passes bc ⇒-rhs is only used for its runtime value +(check-type (nil {Int}) : (List Int) ⇒ (nil {Bool})) +(check-not-type (nil {Bool}) : (List Int)) +(check-type (nil {Bool}) : (List Bool)) +(check-type (nil {(→ Int Int)}) : (List (→ Int Int))) +(define fn-lst (cons (λ ([x : Int]) (+ 10 x)) (nil {(→ Int Int)}))) +(check-type fn-lst : (List (→ Int Int))) +(check-type (isnil fn-lst) : Bool ⇒ #f) +(typecheck-fail (isnil (head fn-lst))) ; head lst is not List +(check-type (isnil (tail fn-lst)) : Bool ⇒ #t) +(check-type (head fn-lst) : (→ Int Int)) +(check-type ((head fn-lst) 25) : Int ⇒ 35) +(check-type (tail fn-lst) : (List (→ Int Int)) ⇒ (nil {(→ Int Int)})) + +;; previous tests: ------------------------------------------------------------ +;; define-type-alias +(define-type-alias Integer Int) +(define-type-alias ArithBinOp (→ Int Int Int)) + +(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) +(check-type + : ArithBinOp) +(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) + +(check-type "Stephen" : String) +(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [male? : Bool])) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) + : Int ⇒ 781) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) + : Bool ⇒ #t) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [my-name : String] [phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [my-phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [is-male? : Bool])) + + +(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) +(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) + (var coffee = (void) as (∨ [coffee : Unit])))) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + : (∨ [coffee : Unit] [tea : Unit])) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1])) ; not enough clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [teaaaaaa x => 2])) ; wrong clause +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [tea x => 2] + [coke x => 3])) ; too many clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => "1"] + [tea x => 2])) ; mismatched branch types +(check-type + (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) + [coffee x => x] + [tea x => 2]) : Int ⇒ 1) +(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) +(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) +(check-type + (case ((λ ([d : Drink]) d) + (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +(check-type + (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +;; previous tests: ------------------------------------------------------------ +;; tests for tuples ----------------------------------------------------------- +; fail bc tuple changed syntax +;(check-type (tup 1 2 3) : (× Int Int Int)) +;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) +; +;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) +;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") +;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) +;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large +;(typecheck-fail (proj 1 2)) ; not tuple + +;; ext-stlc.rkt tests --------------------------------------------------------- +;; should still pass + +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) +(typecheck-fail ((λ ([x : Unit]) x) 2)) +(typecheck-fail ((λ ([x : Unit])) void)) +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(typecheck-fail (begin)) +(check-type (begin 1) : Int) +;; 2016-03-06: begin terms dont need to be Unit +(check-type (begin 1 2 3) : Int) +#;(typecheck-fail + (begin 1 2 3) + #:with-msg "Expected expression 1 to have Unit type, got: Int") +(check-type (begin (void) 1) : Int ⇒ 1) + +;;ascription +(typecheck-fail (ann 1 : Bool)) +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(typecheck-fail (let ([x #f]) (+ x 1))) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) + +; letrec +(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) +(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/stlc+cons-tests.rkt b/typed-lang-builder/examples/tests/stlc+cons-tests.rkt @@ -0,0 +1,229 @@ +#lang s-exp "../stlc+cons.rkt" +(require "rackunit-typechecking.rkt") + +(typecheck-fail (cons 1 2) + #:with-msg "expected \\(List Int\\), given Int\n *expression: 2") +;(typecheck-fail (cons 1 nil) +; #:with-msg "nil: requires type annotation") +(check-type (cons 1 nil) : (List Int)) +(check-type (cons 1 (nil {Int})) : (List Int)) +(typecheck-fail nil #:with-msg "nil: no expected type, add annotations") +(typecheck-fail + (nil Int) + #:with-msg + "Improperly formatted type annotation: Int; should have shape {τ}, where τ is a valid type.") +(typecheck-fail + (nil (Int)) + #:with-msg + "Improperly formatted type annotation: \\(Int\\); should have shape {τ}, where τ is a valid type.") +(typecheck-fail + (λ ([lst : (List Int Int)]) lst) + #:with-msg + "Improper usage of type constructor List: \\(List Int Int\\), expected = 1 arguments") +(typecheck-fail + (λ ([lst : (List)]) lst) + #:with-msg + "Improper usage of type constructor List: \\(List\\), expected = 1 arguments") +;; passes bc ⇒-rhs is only used for its runtime value +(check-type (nil {Int}) : (List Int) ⇒ (nil {Bool})) +(check-not-type (nil {Bool}) : (List Int)) +(check-type (nil {Bool}) : (List Bool)) +(check-type (nil {(→ Int Int)}) : (List (→ Int Int))) +(define fn-lst (cons (λ ([x : Int]) (+ 10 x)) (nil {(→ Int Int)}))) +(check-type fn-lst : (List (→ Int Int))) +(check-type (isnil fn-lst) : Bool ⇒ #f) +(typecheck-fail + (isnil (head fn-lst)) + #:with-msg + "Expected List type, got: \\(→ Int Int\\)") +(check-type (isnil (tail fn-lst)) : Bool ⇒ #t) +(check-type (head fn-lst) : (→ Int Int)) +(check-type ((head fn-lst) 25) : Int ⇒ 35) +(check-type (tail fn-lst) : (List (→ Int Int)) ⇒ (nil {(→ Int Int)})) + +; more list errors +(typecheck-fail + (cons 1 1) + #:with-msg + "expected \\(List Int\\), given Int\n *expression: 1") + +;; previous tests: ------------------------------------------------------------ +;; define-type-alias +(define-type-alias Integer Int) +(define-type-alias ArithBinOp (→ Int Int Int)) + +(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) +(check-type + : ArithBinOp) +(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) + +;; records (ie labeled tuples) +(check-type "Stephen" : String) +(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [male? : Bool])) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) + : Int ⇒ 781) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) + : Bool ⇒ #t) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [my-name : String] [phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [my-phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [is-male? : Bool])) + + +(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) +(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) + (var coffee = (void) as (∨ [coffee : Unit])))) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + : (∨ [coffee : Unit] [tea : Unit])) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1])) ; not enough clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + ["teaaaaaa" x => 2])) ; wrong clause +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [tea x => 2] + [coke x => 3])) ; too many clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => "1"] + [tea x => 2])) ; mismatched branch types +(check-type + (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) + [coffee x => x] + [tea x => 2]) : Int ⇒ 1) +(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) +(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) +(check-type + (case ((λ ([d : Drink]) d) + (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +(check-type + (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +;; previous tests: ------------------------------------------------------------ +;; tests for tuples ----------------------------------------------------------- +; fail because changed tuple syntax +;(check-type (tup 1 2 3) : (× Int Int Int)) +;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) +; +;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) +;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") +;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) +;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large +;(typecheck-fail (proj 1 2)) ; not tuple + +;; ext-stlc.rkt tests --------------------------------------------------------- +;; should still pass + +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) +(typecheck-fail ((λ ([x : Unit]) x) 2)) +(typecheck-fail ((λ ([x : Unit])) void)) +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(typecheck-fail (begin)) +(check-type (begin 1) : Int) +;(typecheck-fail (begin 1 2 3)) +(check-type (begin (void) 1) : Int ⇒ 1) + +;;ascription +(typecheck-fail (ann 1 : Bool)) +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(typecheck-fail (let ([x #f]) (+ x 1))) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) + +;; letrec +(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) +(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; tests from stlc+lit-tests.rkt -------------------------- +;; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;;(typecheck-fail "one") ; literal now supported +;;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +;(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type +;;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/stlc+effect-tests.rkt b/typed-lang-builder/examples/tests/stlc+effect-tests.rkt @@ -0,0 +1,241 @@ +#lang s-exp "../stlc+effect.rkt" +(require "rackunit-typechecking.rkt") + +(check-props ν (ref 11) : '(88)) +(check-props ! (deref (ref 11)) : '(121)) +(check-props ν (deref (ref 11)) : '(170)) +(check-props ν ((λ ([x : Int]) (ref x)) 21) : '(221)) + +(define x (ref 10)) +(check-type x : (Ref Int)) +(check-type (deref x) : Int ⇒ 10) +(check-type (:= x 20) : Unit) ; x still 10 because check-type does not evaluate +(check-type (begin (:= x 20) (deref x)) : Int ⇒ 20) +(check-type x : (Ref Int)) +(check-type (deref (ref 20)) : Int ⇒ 20) +(check-type (deref x) : Int ⇒ 20) + +(check-type ((λ ([b : (Ref Int)]) (deref b)) (ref 10)) : Int ⇒ 10) +(check-type ((λ ([x : Int]) x) ((λ ([b : (Ref Int)]) (deref b)) (ref 10))) : Int ⇒ 10) +(check-type ((λ ([b : (Ref Int)]) (begin (begin (:= b 20) (deref b)))) (ref 10)) : Int ⇒ 20) + +;; Ref err msgs +; wrong arity +(typecheck-fail + (λ ([lst : (Ref Int Int)]) lst) + #:with-msg + "Improper usage of type constructor Ref: \\(Ref Int Int\\), expected = 1 arguments") +(typecheck-fail + (λ ([lst : (Ref)]) lst) + #:with-msg + "Improper usage of type constructor Ref: \\(Ref\\), expected = 1 arguments") +(typecheck-fail + (deref 1) + #:with-msg + "Expected Ref type, got: Int") +(typecheck-fail + (:= 1 1) + #:with-msg + "Expected Ref type, got: Int") + +;; previous tests: ------------------------------------------------------------ +(typecheck-fail (cons 1 2)) +;(typecheck-fail (cons 1 nil)) ; works now +(check-type (cons 1 nil) : (List Int)) +(check-type (cons 1 (nil {Int})) : (List Int)) +(typecheck-fail nil) +(typecheck-fail (nil Int)) +(typecheck-fail (nil (Int))) +; passes bc ⇒-rhs is only used for its runtime value +(check-type (nil {Int}) : (List Int) ⇒ (nil {Bool})) +(check-not-type (nil {Bool}) : (List Int)) +(check-type (nil {Bool}) : (List Bool)) +(check-type (nil {(→ Int Int)}) : (List (→ Int Int))) +(define fn-lst (cons (λ ([x : Int]) (+ 10 x)) (nil {(→ Int Int)}))) +(check-type fn-lst : (List (→ Int Int))) +(check-type (isnil fn-lst) : Bool ⇒ #f) +(typecheck-fail (isnil (head fn-lst))) ; head lst is not List +(check-type (isnil (tail fn-lst)) : Bool ⇒ #t) +(check-type (head fn-lst) : (→ Int Int)) +(check-type ((head fn-lst) 25) : Int ⇒ 35) +(check-type (tail fn-lst) : (List (→ Int Int)) ⇒ (nil {(→ Int Int)})) + +;; previous tests: ------------------------------------------------------------ +;; define-type-alias +(define-type-alias Integer Int) +(define-type-alias ArithBinOp (→ Int Int Int)) + +(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) +(check-type + : ArithBinOp) +(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) + +(check-type "Stephen" : String) +(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [male? : Bool])) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) + : Int ⇒ 781) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) + : Bool ⇒ #t) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [my-name : String] [phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [my-phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [is-male? : Bool])) + + +(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) +(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) + (var coffee = (void) as (∨ [coffee : Unit])))) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + : (∨ [coffee : Unit] [tea : Unit])) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1])) ; not enough clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [teaaaaaa x => 2])) ; wrong clause +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [tea x => 2] + [coke x => 3])) ; too many clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => "1"] + [tea x => 2])) ; mismatched branch types +(check-type + (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) + [coffee x => x] + [tea x => 2]) : Int ⇒ 1) +(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) +(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) +(check-type + (case ((λ ([d : Drink]) d) + (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +(check-type + (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +;; previous tests: ------------------------------------------------------------ +;; tests for tuples ----------------------------------------------------------- +; fail bc tuple changed syntax +;(check-type (tup 1 2 3) : (× Int Int Int)) +;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) +;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) +; +;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) +;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") +;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) +;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large +;(typecheck-fail (proj 1 2)) ; not tuple + +;; ext-stlc.rkt tests --------------------------------------------------------- +;; should still pass + +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) +(typecheck-fail ((λ ([x : Unit]) x) 2)) +(typecheck-fail ((λ ([x : Unit])) void)) +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(typecheck-fail (begin)) +(check-type (begin 1) : Int) +;(typecheck-fail (begin 1 2 3)) +(check-type (begin (void) 1) : Int ⇒ 1) + +;;ascription +(typecheck-fail (ann 1 : Bool)) +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(typecheck-fail (let ([x #f]) (+ x 1))) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) + +; letrec +(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) +(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/stlc+lit-tests.rkt b/typed-lang-builder/examples/tests/stlc+lit-tests.rkt @@ -0,0 +1,65 @@ +#lang s-exp "../stlc+lit.rkt" +(require "rackunit-typechecking.rkt") + +;; thunk +(check-type (λ () 1) : (→ Int)) + +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) + +(typecheck-fail "one" #:with-msg "Unsupported literal") +(typecheck-fail #f #:with-msg "Unsupported literal") + +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) + +(typecheck-fail + (λ ([x : →]) x) + #:with-msg "Improper usage of type constructor →: →, expected >= 1 arguments") +(typecheck-fail + (λ ([x : (→ →)]) x) + #:with-msg "Improper usage of type constructor →: →, expected >= 1 arguments") +(typecheck-fail + (λ ([x : (→)]) x) + #:with-msg "Improper usage of type constructor →: \\(→\\), expected >= 1 arguments") + +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) + +(typecheck-fail ((λ ([x : Bool]) x) 1) + #:with-msg "Bool: unbound identifier") +(typecheck-fail (λ ([x : (→ Bool Bool)]) x) + #:with-msg "Bool: unbound identifier") +(typecheck-fail (λ ([x : Bool]) x) + #:with-msg "Bool: unbound identifier") +(typecheck-fail + (λ ([f : Int]) (f 1 2)) + #:with-msg + "Expected → type, got: Int") + +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) + +(typecheck-fail + (+ 1 (λ ([x : Int]) x)) + #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: \\(λ \\(\\(x : Int\\)\\) x\\)") +(typecheck-fail + (λ ([x : (→ Int Int)]) (+ x x)) + #:with-msg "expected Int, given \\(→ Int Int\\)\n *expression: x") +(typecheck-fail + ((λ ([x : Int] [y : Int]) y) 1) + #:with-msg "wrong number of arguments: expected 2, given 1") + +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + +(typecheck-fail (λ ([x : (→ 1 2)]) x) #:with-msg "not a valid type") +(typecheck-fail (λ ([x : 1]) x) #:with-msg "not a valid type") +(typecheck-fail (λ ([x : (+ 1 2)]) x) #:with-msg "not a valid type") +(typecheck-fail (λ ([x : (λ ([y : Int]) y)]) x) #:with-msg "not a valid type") + +(typecheck-fail + (ann (ann 5 : Int) : (→ Int)) + #:with-msg "expected \\(→ Int\\), given Int\n *expression: \\(ann 5 : Int\\)") + diff --git a/typed-lang-builder/examples/tests/stlc+rec-iso-tests.rkt b/typed-lang-builder/examples/tests/stlc+rec-iso-tests.rkt @@ -0,0 +1,247 @@ +#lang s-exp "../stlc+rec-iso.rkt" +(require "rackunit-typechecking.rkt") + +(define-type-alias IntList (μ (X) (∨ [nil : Unit] [cons : (× Int X)]))) +(define-type-alias ILBody (∨ [nil : Unit] [cons : (× Int IntList)])) + +;; nil +(define nil (fld {IntList} (var nil = (void) as ILBody))) +(check-type nil : IntList) + +;; cons +(define cons (λ ([n : Int] [lst : IntList]) (fld {IntList} (var cons = (tup n lst) as ILBody)))) +(check-type cons : (→ Int IntList IntList)) +(check-type (cons 1 nil) : IntList) +(typecheck-fail (cons 1 2)) +(typecheck-fail (cons "1" nil)) + +;; isnil +(define isnil + (λ ([lst : IntList]) + (case (unfld {IntList} lst) + [nil n => #t] + [cons p => #f]))) +(check-type isnil : (→ IntList Bool)) +(check-type (isnil nil) : Bool ⇒ #t) +(check-type (isnil (cons 1 nil)) : Bool ⇒ #f) +(typecheck-fail (isnil 1)) +(typecheck-fail (isnil (cons 1 2))) +(check-type (λ ([f : (→ IntList Bool)]) (f nil)) : (→ (→ IntList Bool) Bool)) +(check-type ((λ ([f : (→ IntList Bool)]) (f nil)) isnil) : Bool ⇒ #t) + +;; hd +(define hd + (λ ([lst : IntList]) + (case (unfld {IntList} lst) + [nil n => 0] + [cons p => (proj p 0)]))) +(check-type hd : (→ IntList Int)) +(check-type (hd nil) : Int ⇒ 0) +(typecheck-fail (hd 1)) +(check-type (hd (cons 11 nil)) : Int ⇒ 11) + +;; tl +(define tl + (λ ([lst : IntList]) + (case (unfld {IntList} lst) + [nil n => lst] + [cons p => (proj p 1)]))) +(check-type tl : (→ IntList IntList)) +(check-type (tl nil) : IntList ⇒ nil) +(check-type (tl (cons 1 nil)) : IntList ⇒ nil) +(check-type (tl (cons 1 (cons 2 nil))) : IntList ⇒ (cons 2 nil)) +(typecheck-fail (tl 1)) + +;; some typecheck failure msgs +(typecheck-fail + (fld {Int} 1) + #:with-msg + "Expected μ type, got: Int") +(typecheck-fail + (unfld {Int} 1) + #:with-msg + "Expected μ type, got: Int") + +;; previous stlc+var tests ---------------------------------------------------- +;; define-type-alias +(define-type-alias Integer Int) +(define-type-alias ArithBinOp (→ Int Int Int)) +;(define-type-alias C Complex) ; error, Complex undefined + +(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) +(check-type + : ArithBinOp) +(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) + +;; records (ie labeled tuples) +; no records, only tuples +(check-type "Stephen" : String) +;(check-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : +; (× [: "name" String] [: "phone" Int] [: "male?" Bool])) +;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "name") +; : String ⇒ "Stephen") +;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "name") +; : String ⇒ "Stephen") +;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "phone") +; : Int ⇒ 781) +;(check-type (proj (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) "male?") +; : Bool ⇒ #t) +;(check-not-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : +; (× [: "my-name" String] [: "phone" Int] [: "male?" Bool])) +;(check-not-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : +; (× [: "name" String] [: "my-phone" Int] [: "male?" Bool])) +;(check-not-type (tup ["name" = "Stephen"] ["phone" = 781] ["male?" = #t]) : +; (× [: "name" String] [: "phone" Int] [: "is-male?" Bool])) + +;; variants +(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) +(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) + (var coffee = (void) as (∨ [coffee : Unit])))) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1])) ; not enough clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [teaaaaaa x => 2])) ; wrong clause +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [tea x => 2] + [coke x => 3])) ; too many clauses +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => "1"] + [tea x => 2])) ; mismatched branch types +(check-type + (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) + [coffee x => x] + [tea x => 2]) : Int ⇒ 1) +(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) +(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) +(check-type + (case ((λ ([d : Drink]) d) + (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +(check-type + (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +;; previous tests: ------------------------------------------------------------ +;; tests for tuples ----------------------------------------------------------- +(check-type (tup 1 2 3) : (× Int Int Int)) +(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) + +(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) +(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") +(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) +(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large +(typecheck-fail + (proj 1 2) + #:with-msg + "Expected × type, got: Int") + +;; ext-stlc.rkt tests --------------------------------------------------------- +;; should still pass + +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) +(typecheck-fail ((λ ([x : Unit]) x) 2)) +(typecheck-fail ((λ ([x : Unit])) void)) +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(typecheck-fail (begin)) +(check-type (begin 1) : Int) +;(typecheck-fail (begin 1 2 3)) +(check-type (begin (void) 1) : Int ⇒ 1) + +;;ascription +(typecheck-fail (ann 1 : Bool)) +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(typecheck-fail (let ([x #f]) (+ x 1))) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) + +; letrec +(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) +(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/stlc+reco+sub-tests.rkt b/typed-lang-builder/examples/tests/stlc+reco+sub-tests.rkt @@ -0,0 +1,113 @@ +#lang s-exp "../stlc+reco+sub.rkt" +(require "rackunit-typechecking.rkt") + +;; record subtyping tests +(check-type "coffee" : String) +(check-type (tup [coffee = 3]) : (× [coffee : Int])) ; element subtyping +(check-type (var coffee = 3 as (∨ [coffee : Nat])) : (∨ [coffee : Int])) ; element subtyping +;err +(typecheck-fail + (var cooffee = 3 as (∨ [coffee : Nat])) + #:with-msg "cooffee field does not exist") +(check-type (tup [coffee = 3]) : (× [coffee : Nat])) +(check-type (tup [coffee = 3]) : (× [coffee : Top])) +(check-type (var coffee = 3 as (∨ [coffee : Int])) : (∨ [coffee : Top])) ; element subtyping (twice) +(check-type (tup [coffee = 3]) : (× [coffee : Num])) +(check-not-type (tup [coffee = -3]) : (× [coffee : Nat])) +(check-type (tup [coffee = -3]) : (× [coffee : Num])) +(check-type (tup [coffee = -3] [tea = 3]) : (× [coffee : Int])) ; width subtyping +(check-type (tup [coffee = -3] [tea = 3]) : (× [coffee : Num])) ; width+element subtyping + +;; record + fns +(check-type (tup [plus = +]) : (× [plus : (→ Num Num Num)])) +(check-type + : (→ Num Num Num)) +(check-type (tup [plus = +]) : (× [plus : (→ Int Num Num)])) +(check-type (tup [plus = +]) : (× [plus : (→ Int Num Top)])) +(check-type (tup [plus = +] [mul = *]) : (× [plus : (→ Int Num Top)])) + +;; examples from tapl ch26, bounded quantification +(check-type (λ ([x : (× [a : Int])]) x) : (→ (× [a : Int]) (× [a : Int]))) + +(check-type ((λ ([x : (× [a : Int])]) x) (tup [a = 0])) + : (× [a : Int]) ⇒ (tup [a = 0])) +(check-type ((λ ([x : (× [a : Int])]) x) (tup [a = 0][b = #t])) + : (× [a : Int]) ⇒ (tup [a = 0][b = #t])) + +(check-type (proj ((λ ([x : (× [a : Int])]) x) (tup [a = 0][b = #t])) a) + : Int ⇒ 0) + +;; this should work! but needs bounded quantification, see fsub.rkt +(typecheck-fail (proj ((λ ([x : (× [a : Int])]) x) (tup [a = 0][b = #t])) b)) + +; conditional +(check-not-type (λ ([x : Int]) (if #t 1 -1)) : (→ Int Nat)) +(check-type (λ ([x : Int]) (if #t 1 -1)) : (→ Int Int)) +(check-not-type (λ ([x : Int]) (if #t -1 1)) : (→ Int Nat)) +(check-type (λ ([x : Int]) (if #t -1 1)) : (→ Int Int)) +(check-type (λ ([x : Bool]) (if x "1" 1)) : (→ Bool Top)) + +;; previous record tests ------------------------------------------------------ +;; records (ie labeled tuples) +(check-type "Stephen" : String) +(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [male? : Bool])) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) + : Int ⇒ 781) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) + : Bool ⇒ #t) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [my-name : String] [phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [my-phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [is-male? : Bool])) + + +;; previous basic subtyping tests ------------------------------------------------------ +(check-type 1 : Top) +(check-type 1 : Num) +(check-type 1 : Int) +(check-type 1 : Nat) +(check-type -1 : Top) +(check-type -1 : Num) +(check-type -1 : Int) +(check-not-type -1 : Nat) +(check-type ((λ ([x : Top]) x) 1) : Top ⇒ 1) +(check-type ((λ ([x : Top]) x) -1) : Top ⇒ -1) +(check-type ((λ ([x : Num]) x) -1) : Num ⇒ -1) +(check-type ((λ ([x : Int]) x) -1) : Int ⇒ -1) +(typecheck-fail ((λ ([x : Nat]) x) -1)) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([x : Int]) x) : (→ Int Num)) ; covariant output +(check-not-type (λ ([x : Int]) x) : (→ Int Nat)) +(check-type (λ ([x : Int]) x) : (→ Nat Int)) ; contravariant input +(check-not-type (λ ([x : Int]) x) : (→ Num Int)) + +;; previous tests ------------------------------------------------------------- +;; some change due to more specific types +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +;(typecheck-fail "one") ; unsupported literal +;(typecheck-fail #f) ; unsupported literal +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +; Bool now defined +;(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +;(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +;; changed test +(check-type ((λ ([f : (→ Num Num Num)] [x : Int] [y : Int]) (f x y)) + 1 2) : Num ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Num ⇒ 20) diff --git a/typed-lang-builder/examples/tests/stlc+reco+var-tests.rkt b/typed-lang-builder/examples/tests/stlc+reco+var-tests.rkt @@ -0,0 +1,232 @@ +#lang s-exp "../stlc+reco+var.rkt" +(require "rackunit-typechecking.rkt") + +;; define-type-alias +(define-type-alias Integer Int) +(define-type-alias ArithBinOp (→ Int Int Int)) +;(define-type-alias C Complex) ; error, Complex undefined + +(check-type ((λ ([x : Int]) (+ x 2)) 3) : Integer) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Int) +(check-type ((λ ([x : Integer]) (+ x 2)) 3) : Integer) +(check-type + : ArithBinOp) +(check-type (λ ([f : ArithBinOp]) (f 1 2)) : (→ (→ Int Int Int) Int)) + +; records (ie labeled tuples) +(check-type "Stephen" : String) +(check-type (tup) : (×)) +(check-type (tup [name = "Stephen"]) : (× [name : String])) +(check-type (proj (tup [name = "Stephen"]) name) : String ⇒ "Stephen") +(check-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [male? : Bool])) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) name) + : String ⇒ "Stephen") +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) phone) + : Int ⇒ 781) +(check-type (proj (tup [name = "Stephen"] [phone = 781] [male? = #t]) male?) + : Bool ⇒ #t) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [my-name : String] [phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [my-phone : Int] [male? : Bool])) +(check-not-type (tup [name = "Stephen"] [phone = 781] [male? = #t]) : + (× [name : String] [phone : Int] [is-male? : Bool])) + +;; record errors +(typecheck-fail + (proj 1 "a") + #:with-msg + "expected identifier") +(typecheck-fail + (proj 1 a) + #:with-msg + "Expected expression 1 to have × type, got: Int") + +;; variants +(check-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit])) +(check-not-type (var coffee = (void) as (∨ [coffee : Unit])) : (∨ [coffee : Unit] [tea : Unit])) +(typecheck-fail ((λ ([x : (∨ [coffee : Unit] [tea : Unit])]) x) + (var coffee = (void) as (∨ [coffee : Unit]))) + #:with-msg + "expected \\(∨ \\(coffee : Unit\\) \\(tea : Unit\\)\\), given \\(∨ \\(coffee : Unit\\)\\)") +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) : + (∨ [coffee : Unit] [tea : Unit])) +(check-type (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + : (∨ [coffee : Unit] [tea : Unit] [coke : Unit])) + +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1]) + #:with-msg "wrong number of case clauses") +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [teaaaaaa x => 2]) + #:with-msg "case clauses not exhaustive") +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => 1] + [tea x => 2] + [coke x => 3]) + #:with-msg "wrong number of case clauses") +(typecheck-fail + (case (var coffee = (void) as (∨ [coffee : Unit] [tea : Unit])) + [coffee x => "1"] + [tea x => 2]) + #:with-msg "branches have incompatible types: String and Int") +(check-type + (case (var coffee = 1 as (∨ [coffee : Int] [tea : Unit])) + [coffee x => x] + [tea x => 2]) : Int ⇒ 1) +(define-type-alias Drink (∨ [coffee : Int] [tea : Unit] [coke : Bool])) +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) +(check-type (λ ([x : Int]) (+ (+ x x) (+ x x))) : (→ Int Int)) +(check-type + (case ((λ ([d : Drink]) d) + (var coffee = 1 as (∨ [coffee : Int] [tea : Unit] [coke : Bool]))) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +(check-type + (case ((λ ([d : Drink]) d) (var coffee = 1 as Drink)) + [coffee x => (+ (+ x x) (+ x x))] + [tea x => 2] + [coke y => 3]) + : Int ⇒ 4) + +;; variant errors +(typecheck-fail + (var name = "Steve" as Int) + #:with-msg + "Expected the expected type to be a ∨ type, got: Int") +(typecheck-fail + (case 1 [racket x => 1]) + #:with-msg + "Expected ∨ type, got: Int") +(typecheck-fail + (λ ([x : (∨)]) x) + #:with-msg "Improper usage of type constructor ∨: \\(∨\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") +(typecheck-fail + (λ ([x : (∨ 1)]) x) + #:with-msg "Improper usage of type constructor ∨: \\(∨ 1\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") +(typecheck-fail + (λ ([x : (∨ [1 2])]) x) + #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(1 2\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") +(typecheck-fail + (λ ([x : (∨ [a 2])]) x) + #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a 2\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") +(typecheck-fail + (λ ([x : (∨ [a Int])]) x) + #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a Int\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") +(typecheck-fail + (λ ([x : (∨ [1 : Int])]) x) + #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(1 : Int\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") +(typecheck-fail + (λ ([x : (∨ [a : 1])]) x) + #:with-msg "Improper usage of type constructor ∨: \\(∨ \\(a : 1\\)\\), expected \\(∨ \\[label:id : τ:type\\] ...+\\)") + +;; previous tuple tests: ------------------------------------------------------------ +;; wont work anymore +;;(check-type (tup 1 2 3) : (× Int Int Int)) +;;(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) +;;(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) +;;(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) +;;(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) +;;(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) +;; +;;(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) +;;(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") +;;(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) +;;(typecheck-fail (proj (tup 1 "2" #f) 3)) ; index too large +;;(typecheck-fail (proj 1 2)) ; not tuple + +;; ext-stlc.rkt tests --------------------------------------------------------- +;; should still pass + +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) +(typecheck-fail ((λ ([x : Unit]) x) 2)) +(typecheck-fail ((λ ([x : Unit])) void)) +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(typecheck-fail (begin)) +(check-type (begin 1) : Int) +;(typecheck-fail (begin 1 2 3)) +(check-type (begin (void) 1) : Int ⇒ 1) + +;;ascription +(typecheck-fail (ann 1 : Bool)) +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) + +;; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(typecheck-fail (let ([x #f]) (+ x 1))) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) + +;; letrec +(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) +(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; tests from stlc+lit-tests.rkt -------------------------- +;; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +;(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/stlc+sub-tests.rkt b/typed-lang-builder/examples/tests/stlc+sub-tests.rkt @@ -0,0 +1,63 @@ +#lang s-exp "../stlc+sub.rkt" +(require "rackunit-typechecking.rkt") + +;; subtyping tests +(check-type 1 : Top) +(check-type 1 : Num) +(check-type 1 : Int) +(check-type 1 : Nat) +(check-type -1 : Top) +(check-type -1 : Num) +(check-type -1 : Int) +(check-not-type -1 : Nat) +(check-type ((λ ([x : Top]) x) 1) : Top ⇒ 1) +(check-type ((λ ([x : Top]) x) -1) : Top ⇒ -1) +(check-type ((λ ([x : Num]) x) -1) : Num ⇒ -1) +(check-type ((λ ([x : Int]) x) -1) : Int ⇒ -1) +(typecheck-fail ((λ ([x : Nat]) x) -1)) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([x : Int]) x) : (→ Int Num)) ; covariant output +(check-not-type (λ ([x : Int]) x) : (→ Int Nat)) +(check-type (λ ([x : Int]) x) : (→ Nat Int)) ; contravariant input +(check-not-type (λ ([x : Int]) x) : (→ Num Int)) + +(check-type ((λ ([f : (→ Int Int)]) (f -1)) add1) : Int ⇒ 0) +(check-type ((λ ([f : (→ Nat Int)]) (f 1)) add1) : Int ⇒ 2) +(typecheck-fail ((λ ([f : (→ Num Int)]) (f 1.1)) add1)) +(check-type ((λ ([f : (→ Nat Num)]) (f 1)) add1) : Num ⇒ 2) +(typecheck-fail ((λ ([f : (→ Num Num)]) (f 1.1)) add1)) + +(check-type + : (→ Num Num Num)) +(check-type + : (→ Int Num Num)) +(check-type + : (→ Int Int Num)) +(check-not-type + : (→ Top Int Num)) +(check-not-type + : (→ Top Int Int)) +(check-type + : (→ Nat Int Top)) + +;; previous tests ------------------------------------------------------------- +;; some change due to more specific types +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +(check-type "one" : String) +(check-type #f : Bool) +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Sym]) x) 1)) ; Sym is not valid type +(typecheck-fail (λ ([x : Sym]) x)) ; Sym is not valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +;(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +;; changed test +(check-type ((λ ([f : (→ Num Num Num)] [x : Int] [y : Int]) (f x y)) + 1 2) : Num ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Num ⇒ 20) + +(check-not-type (λ ([x : Int]) x) : Int) +(check-not-type (λ ([x : Int] [y : Int]) x) : (→ Int Int)) +(check-not-type (λ ([x : Int]) x) : (→ Int Int Int Int)) diff --git a/typed-lang-builder/examples/tests/stlc+tup-tests.rkt b/typed-lang-builder/examples/tests/stlc+tup-tests.rkt @@ -0,0 +1,107 @@ +#lang s-exp "../stlc+tup.rkt" +(require "rackunit-typechecking.rkt") + +;; tests for tuples +(check-type (tup 1 2 3) : (× Int Int Int)) +(check-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Unit String Bool (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Int Unit Bool (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Int String Unit (→ Int Int Int))) +(check-not-type (tup 1 "1" #f +) : (× Int String Bool (→ Int Int Unit))) + +(check-type (proj (tup 1 "2" #f) 0) : Int ⇒ 1) +(check-type (proj (tup 1 "2" #f) 1) : String ⇒ "2") +(check-type (proj (tup 1 "2" #f) 2) : Bool ⇒ #f) +(typecheck-fail (proj (tup 1 "2" #f) -1) #:with-msg "expected exact-nonnegative-integer") +(typecheck-fail (proj (tup 1 "2" #f) 3) #:with-msg "index too large") +(typecheck-fail + (proj 1 2) + #:with-msg + "proj: Expected × type, got: Int") + +;; ext-stlc.rkt tests --------------------------------------------------------- +;; should still pass + +;; new literals and base types +(check-type "one" : String) ; literal now supported +(check-type #f : Bool) ; literal now supported + +(check-type (λ ([x : Bool]) x) : (→ Bool Bool)) ; Bool is now valid type + +;; Unit +(check-type (void) : Unit) +(check-type void : (→ Unit)) +(typecheck-fail ((λ ([x : Unit]) x) 2)) +(typecheck-fail ((λ ([x : Unit])) void)) +(check-type ((λ ([x : Unit]) x) (void)) : Unit) + +;; begin +(typecheck-fail (begin)) +(check-type (begin 1) : Int) +;(typecheck-fail (begin 1 2 3)) +(check-type (begin (void) 1) : Int ⇒ 1) + +;;ascription +(typecheck-fail (ann 1 : Bool)) +(check-type (ann 1 : Int) : Int ⇒ 1) +(check-type ((λ ([x : Int]) (ann x : Int)) 10) : Int ⇒ 10) + +; let +(check-type (let () (+ 1 1)) : Int ⇒ 2) +(check-type (let ([x 10]) (+ 1 2)) : Int) +(typecheck-fail (let ([x #f]) (+ x 1))) +(check-type (let ([x 10] [y 20]) ((λ ([z : Int] [a : Int]) (+ a z)) x y)) : Int ⇒ 30) +(typecheck-fail (let ([x 10] [y (+ x 1)]) (+ x y))) ; unbound identifier + +(check-type (let* ([x 10] [y (+ x 1)]) (+ x y)) : Int ⇒ 21) +(typecheck-fail (let* ([x #t] [y (+ x 1)]) 1)) + +; letrec +(typecheck-fail (letrec ([(x : Int) #f] [(y : Int) 1]) y)) +(typecheck-fail (letrec ([(y : Int) 1] [(x : Int) #f]) x)) + +(check-type (letrec ([(x : Int) 1] [(y : Int) (+ x 1)]) (+ x y)) : Int ⇒ 3) + +;; recursive +(check-type + (letrec ([(countdown : (→ Int String)) + (λ ([i : Int]) + (if (= i 0) + "liftoff" + (countdown (- i 1))))]) + (countdown 10)) : String ⇒ "liftoff") + +;; mutually recursive +(check-type + (letrec ([(is-even? : (→ Int Bool)) + (λ ([n : Int]) + (or (zero? n) + (is-odd? (sub1 n))))] + [(is-odd? : (→ Int Bool)) + (λ ([n : Int]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) + (is-odd? 11)) : Bool ⇒ #t) + +;; tests from stlc+lit-tests.rkt -------------------------- +; most should pass, some failing may now pass due to added types/forms +(check-type 1 : Int) +;(check-not-type 1 : (Int → Int)) +;(typecheck-fail "one") ; literal now supported +;(typecheck-fail #f) ; literal now supported +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool now valid type, but arg has wrong type +;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is now valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) + diff --git a/typed-lang-builder/examples/tests/stlc-tests.rkt b/typed-lang-builder/examples/tests/stlc-tests.rkt @@ -0,0 +1,12 @@ +#lang s-exp "../stlc.rkt" +(require "rackunit-typechecking.rkt") + +;; cannot write any terms without base types, but can check some errors + +(typecheck-fail (λ ([x : Undef]) x) #:with-msg "Undef: unbound identifier") +(typecheck-fail (λ ([x : →]) x) + #:with-msg "Improper usage of type constructor →.+expected >= 1 arguments") +(typecheck-fail (λ ([x : (→)]) x) + #:with-msg "Improper usage of type constructor →.+expected >= 1 arguments") +(typecheck-fail (λ ([x : (→ →)]) x) + #:with-msg "Improper usage of type constructor →.+expected >= 1 arguments") +\ No newline at end of file diff --git a/typed-lang-builder/examples/tests/sysf-tests.rkt b/typed-lang-builder/examples/tests/sysf-tests.rkt @@ -0,0 +1,76 @@ +#lang s-exp "../sysf.rkt" +(require "rackunit-typechecking.rkt") + +(check-type (Λ (X) (λ ([x : X]) x)) : (∀ (X) (→ X X))) + +(check-type (Λ (X) (λ ([t : X] [f : X]) t)) : (∀ (X) (→ X X X))) ; true +(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (X) (→ X X X))) ; false +(check-type (Λ (X) (λ ([t : X] [f : X]) f)) : (∀ (Y) (→ Y Y Y))) ; false, alpha equiv + +(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ (t1) (∀ (t2) (→ t1 (→ t2 t2))))) + +(check-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ (t3) (∀ (t4) (→ t3 (→ t4 t4))))) + +(check-not-type (Λ (t1) (Λ (t2) (λ ([x : t1]) (λ ([y : t2]) y)))) + : (∀ (t4) (∀ (t3) (→ t3 (→ t4 t4))))) + +(check-type (inst (Λ (t) (λ ([x : t]) x)) Int) : (→ Int Int)) +(check-type (inst (Λ (t) 1) (→ Int Int)) : Int) +; first inst should be discarded +(check-type (inst (inst (Λ (t) (Λ (t) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int)) +; second inst is discarded +(check-type (inst (inst (Λ (t1) (Λ (t2) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int)) + +;; inst err +(typecheck-fail + (inst 1 Int) + #:with-msg + "Expected ∀ type, got: Int") + +;; polymorphic arguments +(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (t) (→ t t))) +(check-type (Λ (t) (λ ([x : t]) x)) : (∀ (s) (→ s s))) +(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (s) (∀ (t) (→ t t)))) +(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (t) (→ t t)))) +(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (s) (→ s s)))) +(check-type (Λ (s) (Λ (t) (λ ([x : t]) x))) : (∀ (r) (∀ (u) (→ u u)))) +(check-type (λ ([x : (∀ (t) (→ t t))]) x) : (→ (∀ (s) (→ s s)) (∀ (u) (→ u u)))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x))) +(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1)) +(check-type ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) : (∀ (u) (→ u u))) +(check-type + (inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) : (→ Int Int)) +(check-type + ((inst ((λ ([x : (∀ (t) (→ t t))]) x) (Λ (s) (λ ([y : s]) y))) Int) 10) + : Int ⇒ 10) +(check-type (λ ([x : (∀ (t) (→ t t))]) (inst x Int)) : (→ (∀ (t) (→ t t)) (→ Int Int))) +(check-type (λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) : (→ (∀ (t) (→ t t)) Int)) +(check-type ((λ ([x : (∀ (t) (→ t t))]) ((inst x Int) 10)) + (Λ (s) (λ ([y : s]) y))) + : Int ⇒ 10) + +; ∀ errs +(typecheck-fail (λ ([x : (∀ (y) (+ 1 y))]) x)) + +;; previous tests ------------------------------------------------------------- +(check-type 1 : Int) +(check-not-type 1 : (→ Int Int)) +(typecheck-fail "one") ; unsupported literal +(typecheck-fail #f) ; unsupported literal +(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int)) +(check-not-type (λ ([x : Int]) x) : Int) +(check-type (λ ([x : Int]) x) : (→ Int Int)) +(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int)) +(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1) +(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type +(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type +(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type +(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + : (→ (→ Int Int Int) Int Int Int)) +(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3) +(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int +(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int +(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args +(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20) diff --git a/typed-lang-builder/lang/reader.rkt b/typed-lang-builder/lang/reader.rkt @@ -0,0 +1,2 @@ +#lang s-exp syntax/module-reader +typed-lang-builder/typed-lang-builder diff --git a/typed-lang-builder/typed-lang-builder.rkt b/typed-lang-builder/typed-lang-builder.rkt @@ -0,0 +1,297 @@ +#lang racket/base + +(provide (except-out (all-from-out macrotypes/typecheck) -define-typed-syntax) + define-typed-syntax + (for-syntax syntax-parse/typed-syntax)) + +(require (rename-in + macrotypes/typecheck + [define-typed-syntax -define-typed-syntax] + )) + +(module typecheck+ racket/base + (provide (all-defined-out)) + (require (for-meta -1 (except-in macrotypes/typecheck #%module-begin))) + (define (raise-⇐-expected-type-error ⇐-stx body expected-type existing-type) + (raise-syntax-error + '⇐ + (format (string-append "body already has a type other than the expected type\n" + " body: ~s\n" + " expected-type: ~a\n" + " existing-type: ~a\n") + (syntax->datum body) + (type->str expected-type) + (type->str existing-type)) + ⇐-stx + body))) +(module syntax-classes racket/base + (provide (all-defined-out)) + (require (for-meta 0 (submod ".." typecheck+)) + (for-meta -1 (submod ".." typecheck+) (except-in macrotypes/typecheck #%module-begin)) + (for-meta -2 (except-in macrotypes/typecheck #%module-begin))) + (define-syntax-class --- + [pattern (~datum --------)]) + (define-syntax-class elipsis + [pattern (~literal ...)]) + (define-splicing-syntax-class props + [pattern (~and (~seq stuff ...) (~seq (~seq k:id v) ...))]) + (define-splicing-syntax-class ⇒-prop + #:datum-literals (⇒) + #:attributes (e-pat) + [pattern (~seq ⇒ tag:id tag-pat (tag-prop:⇒-prop) ...) + #:with e-tmp (generate-temporary) + #:with e-pat + #'(~and e-tmp + (~parse + (~and tag-prop.e-pat ... tag-pat) + (typeof #'e-tmp #:tag 'tag)))]) + (define-splicing-syntax-class ⇒-prop/conclusion + #:datum-literals (⇒) + #:attributes (tag tag-expr) + [pattern (~seq ⇒ tag:id tag-stx (tag-prop:⇒-prop/conclusion) ...) + #:with tag-expr + (for/fold ([tag-expr #'#`tag-stx]) + ([k (in-list (syntax->list #'[tag-prop.tag ...]))] + [v (in-list (syntax->list #'[tag-prop.tag-expr ...]))]) + (with-syntax ([tag-expr tag-expr] [k k] [v v]) + #'(assign-type tag-expr #:tag 'k v)))]) + (define-splicing-syntax-class ⇐-prop + #:datum-literals (⇐ :) + [pattern (~seq ⇐ : τ-stx) + #:with e-tmp (generate-temporary) + #:with τ-tmp (generate-temporary) + #:with τ-exp (generate-temporary) + #:with e-pat + #'(~and e-tmp + (~parse τ-exp (get-expected-type #'e-tmp)) + (~parse τ-tmp (typeof #'e-tmp)) + (~parse + (~post + (~fail #:when (and (not (typecheck? #'τ-tmp #'τ-exp)) + (get-orig #'e-tmp)) + (typecheck-fail-msg/1 #'τ-exp #'τ-tmp #'e-tmp))) + (get-orig #'e-tmp)))]) + (define-splicing-syntax-class ⇒-props + #:attributes (e-pat) + [pattern (~seq :⇒-prop)] + [pattern (~seq (p:⇒-prop) ...) + #:with e-pat #'(~and p.e-pat ...)]) + (define-splicing-syntax-class ⇐-props + #:attributes (τ-stx e-pat) + [pattern (~seq :⇐-prop)] + [pattern (~seq (p:⇐-prop) (p2:⇒-prop) ...) + #:with τ-stx #'p.τ-stx + #:with e-pat #'(~and p.e-pat p2.e-pat ...)]) + (define-splicing-syntax-class ⇒-props/conclusion + #:attributes ([tag 1] [tag-expr 1]) + [pattern (~seq p:⇒-prop/conclusion) + #:with [tag ...] #'[p.tag] + #:with [tag-expr ...] #'[p.tag-expr]] + [pattern (~seq (:⇒-prop/conclusion) ...)]) + (define-splicing-syntax-class id+props+≫ + #:datum-literals (≫) + #:attributes ([x- 1] [ctx 1]) + [pattern (~seq [x:id props:props ≫ x--:id]) + #:with [x- ...] #'[x--] + #:with [ctx ...] #'[[x props.stuff ...]]] + [pattern (~seq [x:id props:props ≫ x--:id] ooo:elipsis) + #:with [x- ...] #'[x-- ooo] + #:with [ctx ...] #'[[x props.stuff ...] ooo]]) + (define-splicing-syntax-class id-props+≫* + #:attributes ([x- 1] [ctx 1]) + [pattern (~seq ctx1:id+props+≫ ...) + #:with [x- ...] #'[ctx1.x- ... ...] + #:with [ctx ...] #'[ctx1.ctx ... ...]]) + (define-splicing-syntax-class inf + #:datum-literals (⊢ ⇒ ⇐ ≫ :) + #:attributes ([e-stx 1] [e-stx-orig 1] [e-pat 1]) + [pattern (~seq [[e-stx* ≫ e-pat*] props:⇒-props] ooo:elipsis ...) + #:with e-tmp (generate-temporary #'e-pat*) + #:with τ-tmp (generate-temporary 'τ) + #:with [e-stx ...] #'[e-stx* ooo ...] + #:with [e-stx-orig ...] #'[e-stx* ooo ...] + #:with [e-pat ...] + #'[(~post + (~seq + (~and props.e-pat + e-pat*) + ooo ...))]] + [pattern (~seq [[e-stx* ≫ e-pat*] props:⇐-props] ooo:elipsis ...) + #:with e-tmp (generate-temporary #'e-pat*) + #:with τ-tmp (generate-temporary 'τ) + #:with τ-exp-tmp (generate-temporary 'τ_expected) + #:with [e-stx ...] #'[(add-expected e-stx* props.τ-stx) ooo ...] + #:with [e-stx-orig ...] #'[e-stx* ooo ...] + #:with [e-pat ...] + #'[(~post + (~seq + (~and props.e-pat + e-pat*) + ooo ...))]] + ) + (define-splicing-syntax-class inf* + [pattern (~seq inf:inf ...) + #:with [e-stx ...] #'[inf.e-stx ... ...] + #:with [e-stx-orig ...] #'[inf.e-stx-orig ... ...] + #:with [e-pat ...] #'[inf.e-pat ... ...]]) + (define-splicing-syntax-class clause + #:attributes ([pat 1]) + #:datum-literals (⊢ ⇒ ⇐ ≫ τ⊑ :) + [pattern [⊢ (~and (~seq inf-stuff ...) (~seq inf:inf ...))] + #:with [:clause] #'[[() () ⊢ inf-stuff ...]]] + [pattern (~seq [⊢ (~and (~seq inf-stuff ...) (~seq inf:inf ...))] ooo:elipsis) + #:with [:clause] #'[[() () ⊢ inf-stuff ...] ooo]] + [pattern (~seq [(tvctx:id-props+≫*) (ctx:id-props+≫*) ⊢ inf:inf*] ooo:elipsis ...) + #:with tvctxss (cond [(stx-null? #'[tvctx.ctx ...]) #'(in-cycle (in-value '()))] + [else #'(in-list (syntax->list #'[(tvctx.ctx ...) ooo ...]))]) + #:with ctxss (cond [(stx-null? #'[ctx.ctx ...]) #'(in-cycle (in-value '()))] + [else #'(in-list (syntax->list #'[(ctx.ctx ...) ooo ...]))]) + #:with [pat ...] + #'[(~post + (~post + (~parse + [[(tvctx.x- ...) (ctx.x- ...) (inf.e-pat ...) _] ooo ...] + (for/list ([tvctxs tvctxss] + [ctxs ctxss] + [es (in-list (syntax->list #'[(inf.e-stx ...) ooo ...]))] + [origs (in-list (syntax->list #'[(inf.e-stx-orig ...) ooo ...]))]) + (infer #:tvctx tvctxs #:ctx ctxs (stx-map pass-orig es origs))))))]] + [pattern [a τ⊑ b] + #:with [pat ...] + #'[(~post + (~fail #:unless (typecheck? #'a #'b) + (typecheck-fail-msg/1/no-expr #'b #'a)))]] + [pattern [a τ⊑ b #:for e] + #:with [pat ...] + #'[(~post + (~fail #:unless (typecheck? #'a #'b) + (typecheck-fail-msg/1 #'b #'a #'e)))]] + [pattern (~seq [a τ⊑ b] ooo:elipsis) + #:with [pat ...] + #'[(~post + (~fail #:unless (typechecks? #'[a ooo] #'[b ooo]) + (typecheck-fail-msg/multi/no-exprs #'[b ooo] #'[a ooo])))]] + [pattern (~seq [a τ⊑ b #:for e] ooo:elipsis) + #:with [pat ...] + #'[(~post + (~fail #:unless (typechecks? #'[a ooo] #'[b ooo]) + (typecheck-fail-msg/multi #'[b ooo] #'[a ooo] #'[e ooo])))]] + [pattern [#:when condition:expr] + #:with [pat ...] + #'[(~fail #:unless condition)]] + [pattern [#:with pat*:expr expr:expr] + #:with [pat ...] + #'[(~post (~parse pat* expr))]] + [pattern [#:fail-unless condition:expr message:expr] + #:with [pat ...] + #'[(~post (~fail #:unless condition message))]] + ) + (define-syntax-class last-clause + #:datum-literals (⊢ ≫ ≻ ⇒ ⇐ :) + #:attributes ([pat 0] [stuff 1] [body 0]) + [pattern [⊢ [[pat ≫ e-stx] props:⇒-props/conclusion]] + #:with [stuff ...] #'[] + #:with body:expr + (for/fold ([body #'(quasisyntax/loc this-syntax e-stx)]) + ([k (in-list (syntax->list #'[props.tag ...]))] + [v (in-list (syntax->list #'[props.tag-expr ...]))]) + (with-syntax ([body body] [k k] [v v]) + #'(assign-type body #:tag 'k v)))] + [pattern [⊢ [[e-stx]]] + #:with :last-clause #'[⊢ [[_ ≫ e-stx] ⇐ : _]]] + [pattern [⊢ [[pat* ≫ e-stx] ⇐ : τ-pat]] + #:with stx (generate-temporary 'stx) + #:with τ (generate-temporary #'τ-pat) + #:with pat + #'(~and stx + pat* + (~parse τ (get-expected-type #'stx)) + (~post (~post (~fail #:unless (syntax-e #'τ) + (no-expected-type-fail-msg)))) + (~parse τ-pat #'τ)) + #:with [stuff ...] #'[] + #:with body:expr + #'(assign-type (quasisyntax/loc this-syntax e-stx) #`τ)] + [pattern [≻ e-stx] + #:with :last-clause #'[_ ≻ e-stx]] + [pattern [pat ≻ e-stx] + #:with [stuff ...] #'[] + #:with body:expr + #'(quasisyntax/loc this-syntax e-stx)] + [pattern [#:error msg:expr] + #:with :last-clause #'[_ #:error msg]] + [pattern [pat #:error msg:expr] + #:with [stuff ...] + #'[#:fail-unless #f msg] + #:with body:expr + ;; should never get here + #'(error msg)]) + (define-splicing-syntax-class pat #:datum-literals (⇐ :) + [pattern (~seq pat) + #:attr transform-body identity] + [pattern (~seq pat* left:⇐ : τ-pat) + #:with stx (generate-temporary 'stx) + #:with τ (generate-temporary #'τ-pat) + #:with b (generate-temporary 'body) + #:with pat + #'(~and stx + pat* + (~parse τ (get-expected-type #'stx)) + (~post (~post (~fail #:unless (syntax-e #'τ) + (no-expected-type-fail-msg)))) + (~parse τ-pat #'τ)) + #:attr transform-body + (lambda (body) + #`(let ([b #,body]) + (when (and (typeof b) + (not (typecheck? (typeof b) #'τ))) + (raise-⇐-expected-type-error #'left b #'τ (typeof b))) + (assign-type b #'τ)))]) + (define-syntax-class rule #:datum-literals (≫) + [pattern [pat:pat ≫ + clause:clause ... + :--- + last-clause:last-clause] + #:with body:expr ((attribute pat.transform-body) #'last-clause.body) + #:with norm + #'[(~and pat.pat + last-clause.pat + clause.pat ... ...) + last-clause.stuff ... + body]]) + (define-splicing-syntax-class stxparse-kws + [pattern (~seq (~or (~seq :keyword _) + (~seq :keyword)) + ...)]) + ) +(require (for-meta 1 'syntax-classes) + (for-meta 2 'syntax-classes)) + +(define-syntax define-typed-syntax + (lambda (stx) + (syntax-parse stx + [(def name:id + (~and (~seq kw-stuff ...) :stxparse-kws) + rule:rule + ...) + #'(-define-typed-syntax + name + kw-stuff ... + rule.norm + ...)]))) + +(begin-for-syntax + (define-syntax syntax-parse/typed-syntax + (lambda (stx) + (syntax-parse stx + [(stxparse + stx-id:id + (~and (~seq kw-stuff ...) :stxparse-kws) + rule:rule + ...) + #'(syntax-parse + stx-id + kw-stuff ... + rule.norm + ...)])))) +