acw/bang
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Compare commits

base: acw:rethink
Branches Tags
acw:master acw:handwritten-lexer acw:rethink
..
compare: acw:acbc62a170e5c8d045b0dc011a46f102dfb51127
Branches Tags
acw:handwritten-lexer acw:rethink acw:master

22 Commits
rethink ... acbc62a170

Author SHA1 Message Date
Adam Wick
acbc62a170 Try to get a builder going.
Some checks failed
Matrix / beta (push) Failing after 5s
Details
Matrix / nightly (push) Failing after 0s
Details
Matrix / stable (push) Failing after 0s
Details
Matrix / beta (pull_request) Failing after 2s
Details
Matrix / nightly (pull_request) Failing after 1s
Details
Matrix / stable (pull_request) Failing after 6s
Details
2025-11-24 18:36:29 -08:00
Adam Wick
2ef9ae8bdc Stuff and bother. 2025-11-24 18:31:44 -08:00
Adam Wick
90c5d6fef8 Tests. 2025-11-11 20:41:58 -08:00
Adam Wick
1bc560f684 Almost ... there. 2025-11-11 14:20:28 -08:00
Adam Wick
c795172692 All the unimplementeds are gone! 2025-11-11 13:42:19 -08:00
Adam Wick
45e49a4c84 This is now tidy for the bits that exst. 2025-11-11 11:07:29 -08:00
Adam Wick
05d7284551 Tidy, tidy, tidy. 2025-11-05 21:30:03 -08:00
Adam Wick
7bd242a641 Pattern parsing seems working. 2025-10-23 09:26:15 -07:00
Adam Wick
9ea6868938 Shifting and naming. 2025-10-11 14:46:02 -07:00
Adam Wick
55df27de98 Recovered. 2025-10-11 13:47:41 -07:00
Adam Wick
f6bf3dd639 Blocks and conditionals. 2025-10-03 22:37:20 -04:00
Adam Wick
c31be288ad Calls and infix expressions. 2025-09-28 11:42:11 -07:00
Adam Wick
4362d82034 Most base expressions work. 2025-09-26 09:24:56 -07:00
Adam Wick
e9fb4fcd0f Ignore proptest droppings. 2025-09-07 20:48:19 -07:00
Adam Wick
24e6bf6318 Start with hand writing the parser again. 2025-09-06 22:06:21 -07:00
Adam Wick
8657c009c8 de-lalrpop 2025-09-06 20:42:30 -07:00
Adam Wick
e250a49703 Cargo.lock 2025-09-06 20:42:25 -07:00
Adam Wick
1baeae1bf0 Some parsing test cases. 2025-09-06 20:41:36 -07:00
Adam Wick
129bf3c204 Add a separate arrow token. 2025-09-06 20:40:57 -07:00
Adam Wick
768b27a8f6 Meh. Type parsing. 2025-09-06 20:40:18 -07:00
Adam Wick
8e6ac7ecbd Ignore aider droppings. 2025-09-06 20:39:52 -07:00
Adam Wick
a663d8f1fb Start a Rust implementation, which is broken with gitignore. 2025-08-22 10:18:38 -07:00
50 changed files with 7340 additions and 2280 deletions
Expand all files Collapse all files

26
.github/workflows/builder.yml vendored Normal file
View File

@@ -0,0 +1,26 @@
name: Matrix
on:
- pull_request
- push
jobs:
main:
strategy:
matrix:
rust:
- stable
- beta
- nightly
name: ${{matrix.rust}}
runs-on: x86_64-linux
steps:
- uses: actions/checkout@v4
- uses: dtolnay/rust-toolchain@v1
with:
toolchain: ${{matrix.rust}}
components: rustfmt, clippy
- run: rustup --version
- run: rustc -vV
- run: cargo clippy -- --deny clippy::pedantic
- run: cargo fmt --all -- --check
- run: cargo test

9
.gitignore vendored
View File

@@ -5,7 +5,10 @@
*.bak *.bak
hsrc/Syntax/Lexer.hs hsrc/Syntax/Lexer.hs
hsrc/Syntax/Parser.hs hsrc/Syntax/Parser.hs
bang
.cabal-sandbox/
dist/ # Added by cargo
cabal.sandbox.config /proptest-regressions
/target
.aider*

690
Cargo.lock generated Normal file
View File

@@ -0,0 +1,690 @@
# This file is automatically @generated by Cargo.
# It is not intended for manual editing.
version = 4
[[package]]
name = "ahash"
version = "0.8.12"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "5a15f179cd60c4584b8a8c596927aadc462e27f2ca70c04e0071964a73ba7a75"
dependencies = [
"cfg-if",
"getrandom",
"once_cell",
"version_check",
"zerocopy",
]
[[package]]
name = "allocator-api2"
version = "0.2.21"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "683d7910e743518b0e34f1186f92494becacb047c7b6bf616c96772180fef923"
[[package]]
name = "ariadne"
version = "0.5.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "36f5e3dca4e09a6f340a61a0e9c7b61e030c69fc27bf29d73218f7e5e3b7638f"
dependencies = [
"concolor",
"unicode-width 0.1.14",
"yansi",
]
[[package]]
name = "arrayvec"
version = "0.5.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "23b62fc65de8e4e7f52534fb52b0f3ed04746ae267519eef2a83941e8085068b"
[[package]]
name = "autocfg"
version = "1.5.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "c08606f8c3cbf4ce6ec8e28fb0014a2c086708fe954eaa885384a6165172e7e8"
[[package]]
name = "bang"
version = "0.1.0"
dependencies = [
"ariadne",
"internment",
"itertools",
"memmap2",
"pretty",
"proptest",
"proptest-derive",
"thiserror",
]
[[package]]
name = "bit-set"
version = "0.8.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "08807e080ed7f9d5433fa9b275196cfc35414f66a0c79d864dc51a0d825231a3"
dependencies = [
"bit-vec",
]
[[package]]
name = "bit-vec"
version = "0.8.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "5e764a1d40d510daf35e07be9eb06e75770908c27d411ee6c92109c9840eaaf7"
[[package]]
name = "bitflags"
version = "1.3.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a"
[[package]]
name = "bitflags"
version = "2.10.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "812e12b5285cc515a9c72a5c1d3b6d46a19dac5acfef5265968c166106e31dd3"
[[package]]
name = "cfg-if"
version = "1.0.4"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "9330f8b2ff13f34540b44e946ef35111825727b38d33286ef986142615121801"
[[package]]
name = "concolor"
version = "0.1.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "0b946244a988c390a94667ae0e3958411fa40cc46ea496a929b263d883f5f9c3"
dependencies = [
"bitflags 1.3.2",
"concolor-query",
"is-terminal",
]
[[package]]
name = "concolor-query"
version = "0.3.3"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "88d11d52c3d7ca2e6d0040212be9e4dbbcd78b6447f535b6b561f449427944cf"
dependencies = [
"windows-sys 0.45.0",
]
[[package]]
name = "dashmap"
version = "5.5.3"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "978747c1d849a7d2ee5e8adc0159961c48fb7e5db2f06af6723b80123bb53856"
dependencies = [
"cfg-if",
"hashbrown 0.14.5",
"lock_api",
"once_cell",
"parking_lot_core",
]
[[package]]
name = "either"
version = "1.15.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "48c757948c5ede0e46177b7add2e67155f70e33c07fea8284df6576da70b3719"
[[package]]
name = "equivalent"
version = "1.0.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "877a4ace8713b0bcf2a4e7eec82529c029f1d0619886d18145fea96c3ffe5c0f"
[[package]]
name = "errno"
version = "0.3.14"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "39cab71617ae0d63f51a36d69f866391735b51691dbda63cf6f96d042b63efeb"
dependencies = [
"libc",
"windows-sys 0.61.2",
]
[[package]]
name = "fastrand"
version = "2.3.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "37909eebbb50d72f9059c3b6d82c0463f2ff062c9e95845c43a6c9c0355411be"
[[package]]
name = "fnv"
version = "1.0.7"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "3f9eec918d3f24069decb9af1554cad7c880e2da24a9afd88aca000531ab82c1"
[[package]]
name = "foldhash"
version = "0.1.5"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "d9c4f5dac5e15c24eb999c26181a6ca40b39fe946cbe4c263c7209467bc83af2"
[[package]]
name = "getrandom"
version = "0.3.4"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "899def5c37c4fd7b2664648c28120ecec138e4d395b459e5ca34f9cce2dd77fd"
dependencies = [
"cfg-if",
"libc",
"r-efi",
"wasip2",
]
[[package]]
name = "hashbrown"
version = "0.14.5"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "e5274423e17b7c9fc20b6e7e208532f9b19825d82dfd615708b70edd83df41f1"
[[package]]
name = "hashbrown"
version = "0.15.5"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "9229cfe53dfd69f0609a49f65461bd93001ea1ef889cd5529dd176593f5338a1"
dependencies = [
"allocator-api2",
"equivalent",
"foldhash",
]
[[package]]
name = "hermit-abi"
version = "0.5.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "fc0fef456e4baa96da950455cd02c081ca953b141298e41db3fc7e36b1da849c"
[[package]]
name = "internment"
version = "0.8.6"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "636d4b0f6a39fd684effe2a73f5310df16a3fa7954c26d36833e98f44d1977a2"
dependencies = [
"ahash",
"dashmap",
"hashbrown 0.15.5",
"once_cell",
]
[[package]]
name = "is-terminal"
version = "0.4.17"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "3640c1c38b8e4e43584d8df18be5fc6b0aa314ce6ebf51b53313d4306cca8e46"
dependencies = [
"hermit-abi",
"libc",
"windows-sys 0.61.2",
]
[[package]]
name = "itertools"
version = "0.14.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "2b192c782037fadd9cfa75548310488aabdbf3d2da73885b31bd0abd03351285"
dependencies = [
"either",
]
[[package]]
name = "libc"
version = "0.2.177"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "2874a2af47a2325c2001a6e6fad9b16a53b802102b528163885171cf92b15976"
[[package]]
name = "linux-raw-sys"
version = "0.11.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "df1d3c3b53da64cf5760482273a98e575c651a67eec7f77df96b5b642de8f039"
[[package]]
name = "lock_api"
version = "0.4.14"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "224399e74b87b5f3557511d98dff8b14089b3dadafcab6bb93eab67d3aace965"
dependencies = [
"scopeguard",
]
[[package]]
name = "memmap2"
version = "0.9.9"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "744133e4a0e0a658e1374cf3bf8e415c4052a15a111acd372764c55b4177d490"
dependencies = [
"libc",
]
[[package]]
name = "num-traits"
version = "0.2.19"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "071dfc062690e90b734c0b2273ce72ad0ffa95f0c74596bc250dcfd960262841"
dependencies = [
"autocfg",
]
[[package]]
name = "once_cell"
version = "1.21.3"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "42f5e15c9953c5e4ccceeb2e7382a716482c34515315f7b03532b8b4e8393d2d"
[[package]]
name = "parking_lot_core"
version = "0.9.12"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "2621685985a2ebf1c516881c026032ac7deafcda1a2c9b7850dc81e3dfcb64c1"
dependencies = [
"cfg-if",
"libc",
"redox_syscall",
"smallvec",
"windows-link",
]
[[package]]
name = "ppv-lite86"
version = "0.2.21"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "85eae3c4ed2f50dcfe72643da4befc30deadb458a9b590d720cde2f2b1e97da9"
dependencies = [
"zerocopy",
]
[[package]]
name = "pretty"
version = "0.12.5"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "0d22152487193190344590e4f30e219cf3fe140d9e7a3fdb683d82aa2c5f4156"
dependencies = [
"arrayvec",
"termcolor",
"typed-arena",
"unicode-width 0.2.2",
]
[[package]]
name = "proc-macro2"
version = "1.0.103"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "5ee95bc4ef87b8d5ba32e8b7714ccc834865276eab0aed5c9958d00ec45f49e8"
dependencies = [
"unicode-ident",
]
[[package]]
name = "proptest"
version = "1.9.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "bee689443a2bd0a16ab0348b52ee43e3b2d1b1f931c8aa5c9f8de4c86fbe8c40"
dependencies = [
"bit-set",
"bit-vec",
"bitflags 2.10.0",
"num-traits",
"rand",
"rand_chacha",
"rand_xorshift",
"regex-syntax",
"rusty-fork",
"tempfile",
"unarray",
]
[[package]]
name = "proptest-derive"
version = "0.6.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "095a99f75c69734802359b682be8daaf8980296731f6470434ea2c652af1dd30"
dependencies = [
"proc-macro2",
"quote",
"syn",
]
[[package]]
name = "quick-error"
version = "1.2.3"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "a1d01941d82fa2ab50be1e79e6714289dd7cde78eba4c074bc5a4374f650dfe0"
[[package]]
name = "quote"
version = "1.0.42"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "a338cc41d27e6cc6dce6cefc13a0729dfbb81c262b1f519331575dd80ef3067f"
dependencies = [
"proc-macro2",
]
[[package]]
name = "r-efi"
version = "5.3.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "69cdb34c158ceb288df11e18b4bd39de994f6657d83847bdffdbd7f346754b0f"
[[package]]
name = "rand"
version = "0.9.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "6db2770f06117d490610c7488547d543617b21bfa07796d7a12f6f1bd53850d1"
dependencies = [
"rand_chacha",
"rand_core",
]
[[package]]
name = "rand_chacha"
version = "0.9.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "d3022b5f1df60f26e1ffddd6c66e8aa15de382ae63b3a0c1bfc0e4d3e3f325cb"
dependencies = [
"ppv-lite86",
"rand_core",
]
[[package]]
name = "rand_core"
version = "0.9.3"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "99d9a13982dcf210057a8a78572b2217b667c3beacbf3a0d8b454f6f82837d38"
dependencies = [
"getrandom",
]
[[package]]
name = "rand_xorshift"
version = "0.4.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "513962919efc330f829edb2535844d1b912b0fbe2ca165d613e4e8788bb05a5a"
dependencies = [
"rand_core",
]
[[package]]
name = "redox_syscall"
version = "0.5.18"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "ed2bf2547551a7053d6fdfafda3f938979645c44812fbfcda098faae3f1a362d"
dependencies = [
"bitflags 2.10.0",
]
[[package]]
name = "regex-syntax"
version = "0.8.8"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "7a2d987857b319362043e95f5353c0535c1f58eec5336fdfcf626430af7def58"
[[package]]
name = "rustix"
version = "1.1.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "cd15f8a2c5551a84d56efdc1cd049089e409ac19a3072d5037a17fd70719ff3e"
dependencies = [
"bitflags 2.10.0",
"errno",
"libc",
"linux-raw-sys",
"windows-sys 0.61.2",
]
[[package]]
name = "rusty-fork"
version = "0.3.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "cc6bf79ff24e648f6da1f8d1f011e9cac26491b619e6b9280f2b47f1774e6ee2"
dependencies = [
"fnv",
"quick-error",
"tempfile",
"wait-timeout",
]
[[package]]
name = "scopeguard"
version = "1.2.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "94143f37725109f92c262ed2cf5e59bce7498c01bcc1502d7b9afe439a4e9f49"
[[package]]
name = "smallvec"
version = "1.15.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "67b1b7a3b5fe4f1376887184045fcf45c69e92af734b7aaddc05fb777b6fbd03"
[[package]]
name = "syn"
version = "2.0.110"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "a99801b5bd34ede4cf3fc688c5919368fea4e4814a4664359503e6015b280aea"
dependencies = [
"proc-macro2",
"quote",
"unicode-ident",
]
[[package]]
name = "tempfile"
version = "3.23.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "2d31c77bdf42a745371d260a26ca7163f1e0924b64afa0b688e61b5a9fa02f16"
dependencies = [
"fastrand",
"getrandom",
"once_cell",
"rustix",
"windows-sys 0.61.2",
]
[[package]]
name = "termcolor"
version = "1.4.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "06794f8f6c5c898b3275aebefa6b8a1cb24cd2c6c79397ab15774837a0bc5755"
dependencies = [
"winapi-util",
]
[[package]]
name = "thiserror"
version = "2.0.17"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "f63587ca0f12b72a0600bcba1d40081f830876000bb46dd2337a3051618f4fc8"
dependencies = [
"thiserror-impl",
]
[[package]]
name = "thiserror-impl"
version = "2.0.17"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "3ff15c8ecd7de3849db632e14d18d2571fa09dfc5ed93479bc4485c7a517c913"
dependencies = [
"proc-macro2",
"quote",
"syn",
]
[[package]]
name = "typed-arena"
version = "2.0.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "6af6ae20167a9ece4bcb41af5b80f8a1f1df981f6391189ce00fd257af04126a"
[[package]]
name = "unarray"
version = "0.1.4"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "eaea85b334db583fe3274d12b4cd1880032beab409c0d774be044d4480ab9a94"
[[package]]
name = "unicode-ident"
version = "1.0.22"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "9312f7c4f6ff9069b165498234ce8be658059c6728633667c526e27dc2cf1df5"
[[package]]
name = "unicode-width"
version = "0.1.14"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "7dd6e30e90baa6f72411720665d41d89b9a3d039dc45b8faea1ddd07f617f6af"
[[package]]
name = "unicode-width"
version = "0.2.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "b4ac048d71ede7ee76d585517add45da530660ef4390e49b098733c6e897f254"
[[package]]
name = "version_check"
version = "0.9.5"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "0b928f33d975fc6ad9f86c8f283853ad26bdd5b10b7f1542aa2fa15e2289105a"
[[package]]
name = "wait-timeout"
version = "0.2.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "09ac3b126d3914f9849036f826e054cbabdc8519970b8998ddaf3b5bd3c65f11"
dependencies = [
"libc",
]
[[package]]
name = "wasip2"
version = "1.0.1+wasi-0.2.4"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "0562428422c63773dad2c345a1882263bbf4d65cf3f42e90921f787ef5ad58e7"
dependencies = [
"wit-bindgen",
]
[[package]]
name = "winapi-util"
version = "0.1.11"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "c2a7b1c03c876122aa43f3020e6c3c3ee5c05081c9a00739faf7503aeba10d22"
dependencies = [
"windows-sys 0.61.2",
]
[[package]]
name = "windows-link"
version = "0.2.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "f0805222e57f7521d6a62e36fa9163bc891acd422f971defe97d64e70d0a4fe5"
[[package]]
name = "windows-sys"
version = "0.45.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "75283be5efb2831d37ea142365f009c02ec203cd29a3ebecbc093d52315b66d0"
dependencies = [
"windows-targets",
]
[[package]]
name = "windows-sys"
version = "0.61.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "ae137229bcbd6cdf0f7b80a31df61766145077ddf49416a728b02cb3921ff3fc"
dependencies = [
"windows-link",
]
[[package]]
name = "windows-targets"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "8e5180c00cd44c9b1c88adb3693291f1cd93605ded80c250a75d472756b4d071"
dependencies = [
"windows_aarch64_gnullvm",
"windows_aarch64_msvc",
"windows_i686_gnu",
"windows_i686_msvc",
"windows_x86_64_gnu",
"windows_x86_64_gnullvm",
"windows_x86_64_msvc",
]
[[package]]
name = "windows_aarch64_gnullvm"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "597a5118570b68bc08d8d59125332c54f1ba9d9adeedeef5b99b02ba2b0698f8"
[[package]]
name = "windows_aarch64_msvc"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "e08e8864a60f06ef0d0ff4ba04124db8b0fb3be5776a5cd47641e942e58c4d43"
[[package]]
name = "windows_i686_gnu"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "c61d927d8da41da96a81f029489353e68739737d3beca43145c8afec9a31a84f"
[[package]]
name = "windows_i686_msvc"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "44d840b6ec649f480a41c8d80f9c65108b92d89345dd94027bfe06ac444d1060"
[[package]]
name = "windows_x86_64_gnu"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "8de912b8b8feb55c064867cf047dda097f92d51efad5b491dfb98f6bbb70cb36"
[[package]]
name = "windows_x86_64_gnullvm"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "26d41b46a36d453748aedef1486d5c7a85db22e56aff34643984ea85514e94a3"
[[package]]
name = "windows_x86_64_msvc"
version = "0.42.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "9aec5da331524158c6d1a4ac0ab1541149c0b9505fde06423b02f5ef0106b9f0"
[[package]]
name = "wit-bindgen"
version = "0.46.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "f17a85883d4e6d00e8a97c586de764dabcc06133f7f1d55dce5cdc070ad7fe59"
[[package]]
name = "yansi"
version = "1.0.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "cfe53a6657fd280eaa890a3bc59152892ffa3e30101319d168b781ed6529b049"
[[package]]
name = "zerocopy"
version = "0.8.27"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "0894878a5fa3edfd6da3f88c4805f4c8558e2b996227a3d864f47fe11e38282c"
dependencies = [
"zerocopy-derive",
]
[[package]]
name = "zerocopy-derive"
version = "0.8.27"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "88d2b8d9c68ad2b9e4340d7832716a4d21a22a1154777ad56ea55c51a9cf3831"
dependencies = [
"proc-macro2",
"quote",
"syn",
]

17
Cargo.toml Normal file
View File

@@ -0,0 +1,17 @@
[package]
name = "bang"
version = "0.1.0"
edition = "2024"
[dependencies]
ariadne = { version = "0.5.1", features = ["auto-color"] }
internment = { version = "0.8.6", features = ["arc", "arena"] }
itertools = "0.14.0"
memmap2 = "0.9.8"
pretty = { version = "0.12.5", features = ["termcolor"] }
proptest = "1.7.0"
proptest-derive = "0.6.0"
thiserror = "2.0.12"
[lints.rust]
unexpected_cfgs = { level = "warn", check-cfg = ['cfg(coverage)'] }

30
LICENSE
View File

@@ -1,30 +0,0 @@
Copyright (c) 2016, Adam Wick
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Adam Wick nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
Setup.hs
View File

@@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

50
bang.cabal
View File

@@ -1,50 +0,0 @@
name: bang
version: 0.1.0.0
synopsis: A fun little language to explore building a compiler. Again.
homepage: http://github.com/acw/bang
license: BSD3
license-file: LICENSE
author: Adam Wick <awick@uhsure.com>
maintainer: Adam Wick <awick@uhsure.com>
category: Development
build-type: Simple
cabal-version: >= 1.10
executable bang
main-is: Main.hs
build-depends:
array >= 0.5.1.1 && < 0.9,
base >= 4.7 && < 5.0,
bytestring >= 0.10.6 && < 0.13,
containers >= 0.5.4 && < 0.8,
GraphSCC >= 1.0.4 && < 1.4,
lens >= 4.14 && < 4.16,
llvm-pretty >= 0.4.0.1 && < 0.8,
optparse-applicative >= 0.12.1.0 && < 0.15,
pretty >= 1.1.3.3 && < 1.4,
text >= 1.2.2.1 && < 1.5
hs-source-dirs: src
build-tools: alex, happy
ghc-options: -Wall
default-language: Haskell2010
other-extensions: CPP,
DeriveDataTypeable,
DeriveFunctor,
FlexibleInstances,
GeneralizedNewtypeDeriving,
MagicHash,
MultiParamTypeClasses,
OverloadedStrings,
TemplateHaskell,
UndecidableInstances
other-modules:
Bang.CommandLine,
Bang.Syntax.Lexer,
Bang.Syntax.Location,
Bang.Syntax.Name,
Bang.Syntax.Parser,
Bang.Syntax.Token,
Paths_bang

55
hsrc/Main.hs Normal file
View File

@@ -0,0 +1,55 @@
import Control.Exception
import Control.Monad
import qualified Data.ByteString as S
import System.Environment
import System.Exit
import System.IO.Error
import Syntax.AST
import Syntax.Lexer
import Syntax.Parser
import Syntax.ParserCore
main :: IO ()
main = do
args <- getArgs
case args of
[file] -> do
ast <- loadModule file
putStrLn "Successful parse!"
putStrLn (show ast)
["-lex",path] -> do
mtxt <- tryJust (guard . isDoesNotExistError) $ S.readFile path
case mtxt of
Left _ -> fail $ "Unable to open file: " ++ path
Right txt -> do
case runParser path txt pullTokens of
Left err -> printError err >> exitWith (ExitFailure 1)
Right ress -> do
mapM_ putStrLn ress
putStrLn "Successful lex."
["-parse",path] -> do
ast <- loadModule path
putStrLn "Successful parse!"
putStrLn (show ast)
_ -> fail "Unacceptable arguments."
pullTokens :: Parser [String]
pullTokens = do
tok <- scan
case tok of
Lexeme pos tok' -> do
let res = show pos ++ " " ++ show tok'
if tok' == TokEOF
then return [res]
else return (res :) `ap` pullTokens
loadModule :: FilePath -> IO (Module Position)
loadModule path = do
mtxt <- tryJust (guard . isDoesNotExistError) $ S.readFile path
case mtxt of
Left _ -> fail $ "Unable to open file: " ++ path
Right txt ->
case runParser path txt parseModule of
Left err -> printError err >> exitWith (ExitFailure 1)
Right ast -> return ast

0
src/Makefile → hsrc/Makefile
View File

109
hsrc/Syntax/AST.hs Normal file
View File

@@ -0,0 +1,109 @@
module Syntax.AST where
import Syntax.ParserCore
data Show a => Module a = Module {
modName :: QualifiedName
, modImports :: [Import]
, modDecls :: [Decl a]
}
deriving (Show)
data QualifiedName = QualifiedName {
qnPrefixes :: [String]
, qnName :: String
}
deriving (Show)
gensym :: Parser QualifiedName
gensym = do
name <- genstr
return (QualifiedName [] name)
data Import = Import {
imName :: QualifiedName
, imQualified :: Bool
, imList :: Maybe [ImportName]
, imAs :: Maybe QualifiedName
}
deriving (Show)
data ImportName = ImportNamed QualifiedName
| ImportRenamed QualifiedName QualifiedName
deriving (Show)
data Show a => Decl a =
DeclData a [Type] QualifiedName [QualifiedName] [DataClause a]
| DeclType a [Type]
| DeclNewtype a [Type]
| DeclClass a [Type] QualifiedName [QualifiedName] [ClassClause a]
| DeclInstance a [Type]
| DeclValue a [Type] Type QualifiedName (Expr a)
| DeclExport a (Decl a)
deriving (Show)
addTypeRestrictions :: Show a => [Type] -> Decl a -> Decl a
addTypeRestrictions rs (DeclData s _ a b c) = DeclData s rs a b c
addTypeRestrictions rs (DeclType s _) = DeclType s rs
addTypeRestrictions rs (DeclNewtype s _) = DeclNewtype s rs
addTypeRestrictions rs (DeclClass s _ a b c) = DeclClass s rs a b c
addTypeRestrictions rs (DeclInstance s _) = DeclInstance s rs
addTypeRestrictions rs (DeclValue s _ n a b) = DeclValue s rs n a b
addTypeRestrictions rs (DeclExport s d) =
DeclExport s (addTypeRestrictions rs d)
data DataClause a = DataClause a QualifiedName [Maybe QualifiedName] [Type]
deriving (Show)
data ClassClause a = ClassClause a QualifiedName Type (Maybe (Expr a))
deriving (Show)
data Show a => Expr a =
Const a ConstVal
| VarRef a QualifiedName
| Cond a (Expr a) (Expr a) (Expr a)
| App a (Expr a) [Expr a]
| Block a [Stmt a]
| Lambda a [QualifiedName] (Expr a)
| Let a Type QualifiedName (Expr a) (Expr a)
deriving (Show)
getSpecial :: Show a => Expr a -> a
getSpecial (Const a _) = a
getSpecial (VarRef a _) = a
getSpecial (Cond a _ _ _) = a
getSpecial (App a _ _) = a
getSpecial (Block a _) = a
getSpecial (Lambda a _ _) = a
getSpecial (Let a _ _ _ _) = a
data Show a => Stmt a =
SExpr a (Expr a)
| SBind a QualifiedName (Stmt a)
| SLet a Type QualifiedName (Expr a)
| SCase a (Expr a) [(Pattern,Maybe (Expr a),Stmt a)]
deriving (Show)
data Pattern =
ListNull
| PConst ConstVal
| PVar QualifiedName
| PNamed QualifiedName Pattern
| PAp Pattern Pattern
deriving (Show)
data Kind = Star | KFun Kind Kind
deriving (Eq,Show)
data Type = TVar QualifiedName Kind
| TCon QualifiedName Kind
| TAp Type Type
| TGen Int
deriving (Show)
data ConstVal = ConstInteger Int String
| ConstFloat String
| ConstChar String
| ConstString String
| ConstEmpty
deriving (Show)

129
hsrc/Syntax/Lexer.x Normal file
View File

@@ -0,0 +1,129 @@
{
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS -w #-}
module Syntax.Lexer where
import qualified Codec.Binary.UTF8.Generic as UTF8
import qualified Data.ByteString as S
import MonadLib
import Syntax.ParserCore
}
-- Digits
$decdigit = 0-9
$hexdigit = [0-9a-fA-f]
$octdigit = 0-7
$bindigit = [01]
-- Identifier Characters
$typestart = [A-Z\_]
$valstart = [a-z\_]
$identrest = [a-zA-Z0-9\_\.]
$opident = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_\|]
$escape_char = [abfnrtv'\"\\]
:-
-- Whitespace
$white+ ;
"/*".*"*/" ;
-- Numbers
$decdigit+ { emitS (buildInt 10) }
"0x"$hexdigit+ { emitS (buildInt 16) }
"0o"$octdigit+ { emitS (buildInt 8) }
"0b"$bindigit+ { emitS (buildInt 2) }
$decdigit+"."$decdigit+ ("e""-"?$decdigit+)? { emitS TokFloat}
$decdigit+"e""-"?$decdigit+ { emitS TokFloat}
-- Identifier
$typestart $identrest* { emitS TokTypeIdent }
"prim%" $typestart $identrest* { emitS TokTypeIdent }
$valstart $identrest* { emitS TokValIdent }
"prim%" $valstart $identrest* { emitS TokValIdent }
$opident+ { emitS TokOpIdent }
":"+ { emitS TokOpIdent }
-- Characters and Strings
['].['] { emitS TokChar }
['] [\\] $escape_char ['] { emitS TokChar }
[\"] ([^\"] | [\n] | ([\\] $escape_char))* [\"] { emitS TokString }
-- Symbols
"(" { emitT LParen }
")" { emitT RParen }
"[" { emitT LSquare }
"]" { emitT RSquare }
"{" { emitT LBrace }
"}" { emitT RBrace }
";" { emitT Semi }
"," { emitT Comma }
"`" { emitT BTick }
[\\] { emitT LLambda }
{
type AlexInput = (Position,Char,S.ByteString)
emitT :: Token -> AlexInput -> Int -> Parser Lexeme
emitT tok (pos,_,_) _ = return $! Lexeme pos tok
emitS :: (String -> Token) -> AlexInput -> Int -> Parser Lexeme
emitS mk (pos,c,bs) len = return $! Lexeme pos (mk input)
where input = UTF8.toString (S.take len bs)
scan :: Parser Lexeme
scan = do
inp@(pos,_,_) <- alexGetInput
sc <- alexGetStartCode
case alexScan inp sc of
AlexEOF -> return $! Lexeme pos TokEOF
AlexError inp' -> do
let posStr = pprtPosition pos
alexError $ posStr ++ ": Lexical error."
AlexSkip inp' len' -> alexSetInput inp' >> scan
AlexToken inp' len action -> do
alexSetInput inp'
action inp len
alexGetInput :: Parser AlexInput
alexGetInput = do
s <- get
return (psPos s, psChar s, psInput s)
alexSetInput :: AlexInput -> Parser ()
alexSetInput (pos,c,bs) = do
s <- get
set $! s {
psPos = pos
, psChar = c
, psInput = bs
}
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p,_,bs) = do
(c,bs') <- UTF8.uncons bs
return (c, (movePos p c, c, bs'))
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (_,c,_) = c
alexError :: String -> Parser a
alexError = raiseL
alexGetStartCode :: Parser Int
alexGetStartCode = psLexCode `fmap` get
alexSetStartCode :: Int -> Parser ()
alexSetStartCode code = do
s <- get
set $! s { psLexCode = code }
begin code _ _ = alexSetStartCode code >> scan
buildInt :: Int -> String -> Token
buildInt base val = TokInt (base, val)
}

14
hsrc/Syntax/Makefile Normal file
View File

@@ -0,0 +1,14 @@
CURDIR := $(TOPDIR)/hsrc/Syntax
SYNFILES := Lexer ParserCore AST Parser
SYNFILES_PREFIXED := $(addprefix $(CURDIR)/,$(SYNFILES))
OBJECTS += $(addsuffix .o,$(SYNFILES_PREFIXED))
HS_SOURCES += $(addsuffix .hs,$(SYNFILES_PREFIXED))
EXTRA_CLEAN += $(CURDIR)/Lexer.hs $(CURDIR)/Lexer.info \
$(CURDIR)/Parser.hs $(CURDIR)/Parser.info
.SECONDARY: $(CURDIR)/Lexer.hs $(CURDIR)/Parser.hs
$(CURDIR)/Parser.d: $(CURDIR)/Lexer.d

509
hsrc/Syntax/Parser.y Normal file
View File

@@ -0,0 +1,509 @@
{
{-# OPTIONS_GHC -w #-}
-- vim: filetype=haskell
module Syntax.Parser where
import Syntax.AST
import Syntax.Lexer
import Syntax.ParserCore
import MonadLib
import qualified Codec.Binary.UTF8.Generic as UTF8
}
%token
-- reserved words
'module' { Lexeme $$ (TokValIdent "module" ) }
'export' { Lexeme $$ (TokValIdent "export" ) }
'import' { Lexeme $$ (TokValIdent "import" ) }
'datatype' { Lexeme $$ (TokValIdent "datatype") }
'type' { Lexeme $$ (TokValIdent "type" ) }
'newtype' { Lexeme $$ (TokValIdent "newtype" ) }
'class' { Lexeme $$ (TokValIdent "class" ) }
'instance' { Lexeme $$ (TokValIdent "instance") }
'qualified' { Lexeme $$ (TokValIdent "qualified") }
'as' { Lexeme $$ (TokValIdent "as") }
'let' { Lexeme $$ (TokValIdent "let") }
'in' { Lexeme $$ (TokValIdent "in") }
'case' { Lexeme $$ (TokValIdent "case") }
'of' { Lexeme $$ (TokValIdent "of") }
'restrict' { Lexeme $$ (TokValIdent "restrict") }
-- symbols
'=' { Lexeme $$ (TokOpIdent "=") }
'|' { Lexeme $$ (TokOpIdent "|") }
'->' { Lexeme $$ (TokOpIdent "->") }
'@' { Lexeme $$ (TokOpIdent "@") }
'::' { Lexeme $$ (TokOpIdent "::") }
'\\' { Lexeme $$ LLambda }
'(' { Lexeme $$ LParen }
')' { Lexeme $$ RParen }
'[' { Lexeme $$ LSquare }
']' { Lexeme $$ RSquare }
'{' { Lexeme $$ LBrace }
'}' { Lexeme $$ RBrace }
';' { Lexeme $$ Semi }
',' { Lexeme $$ Comma }
'`' { Lexeme $$ BTick }
-- identifiers
TYPE_IDENT { Lexeme _ (TokTypeIdent _) }
VAL_IDENT { Lexeme _ (TokValIdent _) }
OP_IDENT { Lexeme _ (TokOpIdent _) }
-- values
INTVAL { Lexeme _ (TokInt _) }
FLOATVAL { Lexeme _ (TokFloat _) }
CHARVAL { Lexeme _ (TokChar _) }
STRVAL { Lexeme _ (TokString _) }
%monad { Parser } { (>>=) } { return }
%name parseModule top_module
%tokentype { Lexeme }
%lexer { lexer } { Lexeme initPosition TokEOF }
%%
top_module :: { Module Position } : 'module' TYPE_IDENT module_decls {
let (imports,items) = $3
in Module (makeQualified $2) imports items
}
module_decls :: { ([Import], [Decl Position]) }
: module_decls module_decl { $1 `pappend` $2 }
| module_decl { $1 }
module_decl :: { ([Import], [Decl Position]) }
: import_decl ';' { ([$1], []) }
| decl ';' { ([], [$1]) }
-- Import Declarations ------------------------------------------------------
import_decl :: { Import }
: 'import' mqualified TYPE_IDENT mimport_list mas
{ Import (makeQualified $3) $2 $4 $5 }
mqualified :: { Bool }
: { False }
| 'qualified' { True }
mimport_list :: { Maybe [ImportName] }
: { Nothing }
| '(' ')' { Just [] }
| '(' import_list ')' { Just $2 }
mas :: { Maybe QualifiedName }
: { Nothing }
| 'as' TYPE_IDENT { Just (makeQualified $2) }
import_list :: { [ImportName] }
: import_name { [$1] }
| import_list ',' import_name { $1 ++ [$3] }
import_name :: { ImportName }
: either_ident { ImportNamed $1 }
| either_ident 'as' either_ident { ImportRenamed $1 $3 }
either_ident :: { QualifiedName }
: TYPE_IDENT { makeQualified $1 }
| VAL_IDENT { makeQualified $1 }
-- Actual Declarations ------------------------------------------------------
-- A declaration starts with an optional export flag and an optional type
-- restriction flag, and then has the declaration. We apply the restrictions /
-- exports post-hoc because we're lazy.
decl :: { Decl Position }
: optional_decl_flags decl2 { $1 $2 }
optional_decl_flags :: { Decl Position -> Decl Position }
: { id }
| opt_export { $1 }
| opt_restrict { $1 }
| opt_export opt_restrict { $1 . $2 }
| opt_restrict opt_export { $1 . $2 }
opt_export :: { Decl Position -> Decl Position }
: 'export' { DeclExport $1 }
opt_restrict :: { Decl Position -> Decl Position }
: 'restrict' '(' type_restrictions ')' { addTypeRestrictions $3 }
type_restrictions :: { [Type] }
: type_restriction { [$1] }
| type_restrictions ',' type_restriction { $1 ++ [$3] }
type_restriction :: { Type }
: TYPE_IDENT VAL_IDENT
{ TAp (TVar (makeQualified $1) Star) (TVar (makeQualified $2) Star) }
| type_restriction VAL_IDENT
{ TAp $1 (TVar (makeQualified $2) Star) }
decl2 :: { Decl Position }
: data_decl { $1 }
| type_decl { $1 }
| newtype_decl { $1 }
| class_decl { $1 }
| instance_decl { $1 }
| value_decl { $1 }
-- Data Declarations --------------------------------------------------------
data_decl :: { Decl Position }
: 'datatype' TYPE_IDENT type_args '=' data_clauses
{ DeclData $1 [] (makeQualified $2) $3 $5 }
type_args :: { [QualifiedName] }
: { [] }
| type_args VAL_IDENT { $1 ++ [makeQualified $2] }
data_clauses :: { [DataClause Position] }
: data_clause { [] }
| data_clauses '|' data_clause { $1 ++ [$3] }
data_clause :: { DataClause Position }
: constructor_name '(' ')'
{ DataClause $2 $1 [] [] }
| constructor_name '(' constructor_args ')'
{ DataClause $2 $1 (map fst $3) (map snd $3) }
constructor_name :: { QualifiedName }
: TYPE_IDENT { makeQualified $1 }
| '(' OP_IDENT ')' { makeQualified $2 }
constructor_args :: { [(Maybe QualifiedName,Type)] }
: constructor_arg { [$1] }
| constructor_args ',' constructor_arg { $1 ++ [$3] }
constructor_arg :: { (Maybe QualifiedName,Type) }
: bang_type { (Nothing, $1) }
| VAL_IDENT '::' bang_type { (Just (makeQualified $1), $3) }
-- Type Declarations --------------------------------------------------------
type_decl :: { Decl Position }
: 'type' { undefined }
-- Newtype Declarations -----------------------------------------------------
newtype_decl :: { Decl Position }
: 'newtype' { undefined }
-- Class Declarations -------------------------------------------------------
class_decl :: { Decl Position }
: 'class' type_ident class_args '{' class_items '}'
{ DeclClass $1 [] $2 $3 $5 }
class_args :: { [QualifiedName] }
: VAL_IDENT { [makeQualified $1] }
| class_args VAL_IDENT { $1 ++ [makeQualified $2] }
class_items :: { [ClassClause Position] }
: class_item { [$1] }
| class_items class_item { $1 ++ [$2] }
class_item :: { ClassClause Position }
: value_ident maybe_clargs cl_retarg maybe_body ';'
{% case ($2, $4) of
(Nothing, Nothing) -> return (ClassClause $5 $1 $3 Nothing)
(Just as, Nothing) ->
let types = map snd as
in return (ClassClause $5 $1 (buildFunType types $3) Nothing)
(Nothing, Just bd) -> return (ClassClause $5 $1 $3 (Just bd))
(Just as, Just bd) ->
let types = map snd as
names = sequence (map fst as)
in case names of
Nothing ->
raiseP "Can't have class implementation without argument names."
Just nms -> return (ClassClause $5 $1 (buildFunType types $3)
(Just $ Lambda $5 nms bd))
}
maybe_clargs :: { Maybe [(Maybe QualifiedName, Type)] }
: { Nothing }
| '(' clargs ')' { Just $2 }
clargs :: { [(Maybe QualifiedName, Type)] }
: class_arg { [$1] }
| clargs ',' class_arg { $1 ++ [$3] }
class_arg :: { (Maybe QualifiedName, Type) }
: value_ident '::' bang_type { (Just $1, $3) }
| bang_type { (Nothing, $1) }
cl_retarg :: { Type }
: '::' bang_type { $2 }
maybe_body :: { Maybe (Expr Position) }
: { Nothing }
| '=' expression { Just $2 }
| '{' statements '}' { Just (Block $1 $2) }
type_ident :: { QualifiedName }
: TYPE_IDENT { makeQualified $1 }
| '(' OP_IDENT ')' { makeQualified $2 }
-- Instance Declarations ----------------------------------------------------
instance_decl :: { Decl Position }
: 'instance' { undefined }
-- Value Declaration --------------------------------------------------------
value_decl :: { Decl Position }
: value_ident optional_args optional_type value_body
{% postProcessDeclVal DeclValue $1 $2 $3 $4 }
optional_args :: { Maybe [(QualifiedName, Maybe Type)] }
: '(' optional_args2 ')' { Just $2 }
| { Nothing }
optional_args2 :: { [(QualifiedName, Maybe Type)] }
: optional_arg { [$1] }
| optional_args2 ',' optional_arg { $1 ++ [$3] }
optional_arg :: { (QualifiedName, Maybe Type) }
: value_ident optional_type { ($1, $2) }
optional_type :: { Maybe Type }
: { Nothing }
| '::' bang_type { Just $2 }
value_ident :: { QualifiedName }
: VAL_IDENT { makeQualified $1 }
| '(' OP_IDENT ')' { makeQualified $2 }
| '(' '|' ')' { makeQualified (Lexeme $2 (TokOpIdent "|")) }
value_body :: { (Position, Expr Position) }
: '=' expression { ($1, $2) }
| '{' statements '}' { ($1, Block $1 $2) }
-- Types in Bang ------------------------------------------------------------
primary_type :: { Type }
: TYPE_IDENT { TVar (makeQualified $1) Star }
| VAL_IDENT { TVar (makeQualified $1) Star }
| '(' bang_type ')' { $2 }
type_application_type :: { Type }
: type_application_type primary_type
{ TAp $1 $2 }
| primary_type
{ $1 }
function_type :: { Type }
: function_type '->' type_application_type
{ TAp (TVar (QualifiedName ["--INTERNAL--"] "->") Star) $3 }
| type_application_type
{ $1 }
list_type :: { Type }
: '[' list_type ']'
{ TAp (TVar (QualifiedName ["Data","List"] "List") Star) $2 }
| function_type
{ $1 }
bang_type :: { Type }
: list_type { $1 }
-- Statements in bang
statements :: { [Stmt Position] }
: { [] }
| statements statement { $1 ++ [$2] }
statement :: { Stmt Position }
: assignment_statement ';' { $1 }
| case_statement { $1 }
| expression ';' { SExpr $2 $1 }
assignment_statement :: { Stmt Position }
: value_ident '=' expression -- FIXME: Too restrictive!
{ SBind $2 $1 (SExpr $2 $3) }
| 'let' value_ident optional_args optional_type value_body
{% postProcessDeclVal (\ s _ t n e -> SLet s t n e) $2 $3 $4 $5 }
case_statement :: { Stmt Position }
: 'case' expression '{' case_items '}'
{ SCase $1 $2 $4 }
case_items :: { [(Pattern,Maybe (Expr Position),(Stmt Position))] }
: case_item { [$1] }
| case_items case_item { $1 ++ [$2] }
case_item :: { (Pattern, Maybe (Expr Position), (Stmt Position)) }
: pattern mguard '->' statement { ($1, $2, $4) }
mguard :: { Maybe (Expr Position) }
: { Nothing }
| '|' expression { Just $2 }
-- Patterns for pattern matching
infix_operator :: { QualifiedName }
: OP_IDENT { makeQualified $1 }
| '`' VAL_IDENT '`' { makeQualified $2 }
pattern_primary :: { Pattern }
: TYPE_IDENT { PVar (makeQualified $1) }
| VAL_IDENT { PVar (makeQualified $1) }
| '[' ']' { PVar (QualifiedName ["Data","List"] "NULL") }
| INTVAL { let (Lexeme _ (TokInt (base, val))) = $1
in PConst (ConstInteger base val) }
| FLOATVAL { let (Lexeme _ (TokFloat val)) = $1
in PConst (ConstFloat val) }
| CHARVAL { let (Lexeme _ (TokChar val)) = $1
in PConst (ConstChar val) }
| STRVAL { let (Lexeme _ (TokString val)) = $1
in PConst (ConstString val) }
| '(' pattern ')' { $2 }
pattern_infix :: { Pattern }
: pattern_infix infix_operator pattern_primary { PAp (PAp $1 (PVar $2)) $3 }
| pattern_primary { $1 }
pattern_ap :: { Pattern }
: pattern_ap pattern_infix { PAp $1 $2 }
| pattern_infix { $1 }
pattern_name :: { Pattern }
: value_ident '@' pattern_name { PNamed $1 $3 }
| pattern_ap { $1 }
pattern :: { Pattern }
: pattern_name { $1 }
-- Expressions in bang
primary_expression :: { Expr Position }
: '(' expression ')' { $2 }
| '[' ']' { VarRef $1 (QualifiedName ["Data","List"] "NULL") }
| INTVAL { let (Lexeme src (TokInt (base, val))) = $1
in Const src (ConstInteger base val) }
| FLOATVAL { let (Lexeme src (TokFloat val)) = $1
in Const src (ConstFloat val) }
| CHARVAL { let (Lexeme src (TokChar val)) = $1
in Const src (ConstChar val) }
| STRVAL { let (Lexeme src (TokString val)) = $1
in Const src (ConstString val) }
| TYPE_IDENT { let l@(Lexeme src (TokTypeIdent name)) = $1
in VarRef src (makeQualified l) }
| VAL_IDENT { let l@(Lexeme src (TokValIdent name)) = $1
in VarRef src (makeQualified l) }
let_expression :: {Expr Position}
: 'let' value_ident optional_args optional_type value_body 'in' let_expression
{% postProcessDeclVal (\ s _ t n b -> Let s t n b $7) $2 $3 $4 $5 }
| primary_expression { $1 }
conditional_expression :: { Expr Position }
: let_expression { $1 }
infix_expression :: { Expr Position }
: infix_expression infix_operator conditional_expression
{ App (getSpecial $1) (VarRef (getSpecial $1) $2) [$1, $3] }
| conditional_expression
{ $1 }
lambda_expression :: { Expr Position }
: '\\' arguments '->' infix_expression
{ Lambda $1 $2 $4 }
| infix_expression
{ $1 }
arguments :: { [QualifiedName] }
: value_ident { [$1] }
| arguments ',' value_ident { $1 ++ [$3] }
application_expression :: { Expr Position }
: application_expression '(' app_args ')'
{ App $2 $1 $3 }
| application_expression '(' ')'
{ App $2 $1 [] }
| lambda_expression
{ $1 }
app_args :: { [Expr Position] }
: expression { [$1] }
| app_args ',' expression { $1 ++ [$3] }
block_expression :: { Expr Position }
: '{' statements '}' { Block $1 $2 }
| application_expression { $1 }
expression :: { Expr Position }
: block_expression { $1 }
{
lexer :: (Lexeme -> Parser a) -> Parser a
lexer k = scan >>= k
happyError :: Parser a
happyError = raiseP "Parse Error"
pappend :: ([a],[b]) -> ([a],[b]) -> ([a],[b])
pappend (a,b) (c,d) = (a++c,b++d)
makeQualified :: Lexeme -> QualifiedName
makeQualified (Lexeme _ (TokTypeIdent str)) = makeQualified' str
makeQualified (Lexeme _ (TokValIdent str)) = makeQualified' str
makeQualified (Lexeme _ (TokOpIdent str)) = makeQualified' str
makeQualified _ = error "makeQualified bad arg"
makeQualified' :: String -> QualifiedName
makeQualified' str = QualifiedName prefixes name
where
(prefixes,name) = loop str
loop val =
let (pre,rest) = span (/= '.') val
in if rest == ""
then ([], pre)
else let (pres, name) = loop (tail rest)
in (pre:pres, name)
postProcessDeclVal ::
(Position -> [Type] -> Type -> QualifiedName -> Expr Position -> a) ->
QualifiedName ->
Maybe [(QualifiedName, Maybe Type)] ->
Maybe Type ->
(Position, Expr Position) ->
Parser a
postProcessDeclVal builder name margs mrettype (src, body) = do
final_type <- case mrettype of
Nothing -> do
name <- gensym
return (TVar name Star)
Just x ->
return x
case margs of
Nothing ->
return (builder src [] final_type name body)
Just [] ->
fail "Need to figure out empty arg items."
Just args -> do
let anames = map fst args
atypes <- forM (map snd args) $ \ x ->
case x of
Nothing -> do
name <- gensym
return (TVar name Star)
Just x ->
return x
let ftype = buildFunType atypes final_type
return (builder src [] ftype name (Lambda src anames body))
buildFunType :: [Type] -> Type -> Type
buildFunType [] finaltype = finaltype
buildFunType (first:rest) finaltype =
TAp (TAp arrow first) (buildFunType rest finaltype)
where arrow = (TVar (makeQualified' "Data.Function") Star)
}

149
hsrc/Syntax/ParserCore.hs Normal file
View File

@@ -0,0 +1,149 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Syntax.ParserCore where
import Control.Applicative(Applicative)
import qualified Data.ByteString as S
import MonadLib
import System.IO
-- --------------------------------------------------------------------------
-- Positions
--
data Position = Position {
posOff :: !Int
, posLine :: !Int
, posCol :: !Int
, posFile :: !FilePath
}
deriving (Show)
initPosition :: FilePath -> Position
initPosition = Position 0 1 1
movePos :: Position -> Char -> Position
movePos (Position o l c f) '\t' = Position (o+1) l (c+8) f
movePos (Position o l _ f) '\n' = Position (o+1) (l+1) 0 f
movePos (Position o l c f) _ = Position (o+1) l (c+1) f
pprtPosition :: Position -> String
pprtPosition p = posFile p ++ ":" ++ show (posLine p) ++ ":" ++ show (posCol p)
-- --------------------------------------------------------------------------
-- Tokens
--
data Token = LParen | RParen
| LSquare | RSquare
| LBrace | RBrace
| Bar | Semi | Comma | BTick | LLambda
| TokTypeIdent String
| TokValIdent String
| TokOpIdent String
| TokInt (Int,String)
| TokFloat String
| TokChar String
| TokString String
| TokEOF
deriving (Eq, Show)
-- --------------------------------------------------------------------------
-- Lexemes
--
data Lexeme = Lexeme {
lexPos :: !Position
, lexTok :: Token
}
deriving (Show)
instance Eq Lexeme where
a == b = lexTok a == lexTok b
-- --------------------------------------------------------------------------
-- Errors
--
data ErrorType =
LexerError
| ParserError
deriving (Show)
data Error = Error ErrorType String Position
deriving (Show)
printError :: Error -> IO ()
printError (Error etype str pos) = hPutStrLn stderr errstr
where
errstr = pprtPosition pos ++ ":" ++ etypeStr ++ ": " ++ str
etypeStr = case etype of
LexerError -> "LEX"
ParserError -> "PARSE"
-- --------------------------------------------------------------------------
-- ParserState
--
data ParserState = ParserState {
psInput :: !S.ByteString
, psChar :: !Char
, psPos :: !Position
, psLexCode :: !Int
, psGenNum :: !Int
}
deriving (Show)
initParserState :: FilePath -> S.ByteString -> ParserState
initParserState path bs = ParserState {
psInput = bs
, psChar = '\n'
, psPos = initPosition path
, psLexCode = 0
, psGenNum = 0
}
-- --------------------------------------------------------------------------
-- Parser
--
newtype Parser a = Parser {
unParser :: StateT ParserState (ExceptionT Error Id) a
} deriving (Functor, Applicative, Monad)
instance StateM Parser ParserState where
get = Parser get
set = Parser . set
instance ExceptionM Parser Error where
raise = Parser . raise
instance RunExceptionM Parser Error where
try m = Parser (try (unParser m))
-- |Raise a lexer error
raiseL :: String -> Parser a
raiseL msg = do
st <- get
raise (Error LexerError msg (psPos st))
-- |Raise a parser error
raiseP :: String -> Parser a
raiseP msg = do
st <- get
raise (Error ParserError msg (psPos st))
-- |Run the parser over the given file
runParser :: FilePath -> S.ByteString -> Parser a -> Either Error a
runParser path bs (Parser m) =
case runM m (initParserState path bs) of
Right (a,_) -> Right a
Left err -> Left err
genstr :: Parser String
genstr = do
st <- get
set st{ psGenNum = psGenNum st + 1 }
return $ "--gen" ++ show (psGenNum st)

43
src/Bang/AST.hs
View File

@@ -1,43 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST
( Module
, ppModule
, mkModule
, moduleName, moduleDeclarations
, module Bang.AST.Declaration
, module Bang.AST.Expression
, module Bang.AST.Name
, module Bang.AST.Type
)
where
import Bang.AST.Declaration
import Bang.AST.Expression
import Bang.AST.Name
import Bang.AST.Type
import Control.Lens(view)
import Control.Lens.TH(makeLenses)
import Text.PrettyPrint.Annotated(Doc, empty, text, (<+>), ($+$))
data Module = Module {
_moduleName :: Name
, _moduleDeclarations :: [[Declaration]]
}
mkModule :: Name -> [[Declaration]] -> Module
mkModule = Module
makeLenses ''Module
ppModule :: Module -> Doc a
ppModule m = text "module" <+> ppName (view moduleName m) $+$
dump (view moduleName m) (view moduleDeclarations m)
where
dump _ [] = empty
dump prev ([]:rest) = dump prev rest
dump prev ((x:rest):lr)
| prev == view declName x =
ppDeclaration x $+$ dump prev (rest:lr)
| otherwise =
text "" $+$ dump (view declName x) ((x:rest):lr)

114
src/Bang/AST/Declaration.hs
View File

@@ -1,114 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Declaration
( Declaration(..)
, ppDeclaration
, declName
-- * Type Declarations
, TypeDeclaration
, ppTypeDeclaration
, mkTypeDecl
, tdName, tdLocation, tdType
-- * Value Declarations
, ValueDeclaration
, ppValueDeclaration
, mkValueDecl
, vdName, vdLocation
, vdDeclaredType, vdValue
)
where
import Bang.AST.Expression(Expression, ppExpression)
import Bang.AST.Name(Name, ppName)
import Bang.AST.Type(Type(TypePrim), ppType)
import Bang.Syntax.Location(Location)
import Bang.Utils.FreeVars(CanHaveFreeVars(..))
import Control.Lens(Lens', view, set, lens)
import Control.Lens(makeLenses)
import Data.Set(delete, union)
import Text.PrettyPrint.Annotated(Doc, text, (<+>), ($+$), (<>), empty, space)
data TypeDeclaration = TypeDeclaration
{ _tdName :: Name
, _tdLocation :: Location
, _tdType :: Type
}
deriving (Show)
class MkTypeDecl a where
mkTypeDecl :: Name -> Location -> Type -> a
ppTypeDeclaration :: TypeDeclaration -> Doc a
ppTypeDeclaration td = prefix <> text "type" <+> ppName (_tdName td) <+>
text "=" <+> ppType (_tdType td)
where
prefix | TypePrim _ <- _tdType td = text "primitive" <> space
| otherwise = empty
instance MkTypeDecl TypeDeclaration where
mkTypeDecl = TypeDeclaration
instance MkTypeDecl Declaration where
mkTypeDecl n l t = DeclType (TypeDeclaration n l t)
instance CanHaveFreeVars TypeDeclaration where
freeVariables td = delete (_tdName td) (freeVariables (_tdType td))
-- -----------------------------------------------------------------------------
data ValueDeclaration = ValueDeclaration
{ _vdName :: Name
, _vdLocation :: Location
, _vdDeclaredType :: Maybe Type
, _vdValue :: Expression
}
deriving (Show)
class MkValueDecl a where
mkValueDecl :: Name -> Location -> Maybe Type -> Expression -> a
ppValueDeclaration :: ValueDeclaration -> Doc a
ppValueDeclaration vd = typedecl $+$ valuedecl
where
typedecl
| Just t <- _vdDeclaredType vd =
ppName (_vdName vd) <+> text "::" <+> ppType t
| otherwise = empty
valuedecl = ppName (_vdName vd) <+> text "=" <+> ppExpression (_vdValue vd)
instance MkValueDecl ValueDeclaration where
mkValueDecl n l mt e = ValueDeclaration n l mt e
instance MkValueDecl Declaration where
mkValueDecl n l mt e = DeclVal (ValueDeclaration n l mt e)
instance CanHaveFreeVars ValueDeclaration where
freeVariables vd = delete (_vdName vd) (union valTypes typeTypes)
where
valTypes = freeVariables (_vdValue vd)
typeTypes = freeVariables (_vdDeclaredType vd)
-- -----------------------------------------------------------------------------
data Declaration = DeclType TypeDeclaration
| DeclVal ValueDeclaration
deriving (Show)
ppDeclaration :: Declaration -> Doc a
ppDeclaration (DeclType d) = ppTypeDeclaration d
ppDeclaration (DeclVal d) = ppValueDeclaration d
instance CanHaveFreeVars Declaration where
freeVariables (DeclType td) = freeVariables td
freeVariables (DeclVal vd) = freeVariables vd
makeLenses ''TypeDeclaration
makeLenses ''ValueDeclaration
declName :: Lens' Declaration Name
declName = lens getter setter
where
getter (DeclType d) = view tdName d
getter (DeclVal d) = view vdName d
setter (DeclType d) x = DeclType (set tdName x d)
setter (DeclVal d) x = DeclVal (set vdName x d)

163
src/Bang/AST/Expression.hs
View File

@@ -1,163 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Expression
( Expression(..)
, ppExpression
-- * Constant Expressions
, ConstantExpression
, ppConstantExpression
, mkConstExp
, constLocation
, constValue
, ConstantValue(..)
, ppConstantValue
-- * References
, ReferenceExpression
, ppReferenceExpression
, mkRefExp
, refLocation
, refName
-- * Lambdas
, LambdaExpression
, ppLambdaExpression
, mkLambdaExp
, lambdaLocation
, lambdaArgumentNames
, lambdaBody
-- * Empty Expressions
, emptyExpression
, isEmptyExpression
)
where
import Bang.Syntax.Location(Location, fakeLocation)
import Bang.AST.Name(Name, ppName, nothingName)
import Bang.Utils.FreeVars(CanHaveFreeVars(..))
import Bang.Utils.Pretty(text')
import Control.Lens(view)
import Control.Lens.TH(makeLenses)
import Data.Set(empty, singleton, fromList, (\\))
import Data.Text.Lazy(Text)
import Text.PrettyPrint.Annotated(Doc, text, hsep, (<>), (<+>))
-- -----------------------------------------------------------------------------
data ConstantValue = ConstantInt Word Text
| ConstantChar Text
| ConstantString Text
| ConstantFloat Text
deriving (Show)
ppConstantValue :: ConstantValue -> Doc a
ppConstantValue cv =
case cv of
ConstantInt 2 t -> text "0b" <> text' t
ConstantInt 8 t -> text "0o" <> text' t
ConstantInt 10 t -> text' t
ConstantInt 16 t -> text "0x" <> text' t
ConstantInt _ _ -> error "Internal error: bad base for constant"
ConstantChar c -> text' c
ConstantString s -> text' s
ConstantFloat f -> text' f
data ConstantExpression = ConstantExpression
{ _constLocation :: Location
, _constValue :: ConstantValue
}
deriving (Show)
class MkConstExp a where
mkConstExp :: Location -> ConstantValue -> a
instance MkConstExp ConstantExpression where
mkConstExp = ConstantExpression
instance MkConstExp Expression where
mkConstExp l v = ConstExp (mkConstExp l v)
instance CanHaveFreeVars ConstantExpression where
freeVariables _ = empty
ppConstantExpression :: ConstantExpression -> Doc a
ppConstantExpression = ppConstantValue . _constValue
-- -----------------------------------------------------------------------------
data ReferenceExpression = ReferenceExpression
{ _refLocation :: Location
, _refName :: Name
}
deriving (Show)
ppReferenceExpression :: ReferenceExpression -> Doc a
ppReferenceExpression = ppName . _refName
class MkRefExp a where
mkRefExp :: Location -> Name -> a
instance MkRefExp ReferenceExpression where
mkRefExp = ReferenceExpression
instance MkRefExp Expression where
mkRefExp l n = RefExp (ReferenceExpression l n)
instance CanHaveFreeVars ReferenceExpression where
freeVariables r = singleton (_refName r)
-- -----------------------------------------------------------------------------
data LambdaExpression = LambdaExpression
{ _lambdaLocation :: Location
, _lambdaArgumentNames :: [Name]
, _lambdaBody :: Expression
}
deriving (Show)
class MkLambdaExp a where
mkLambdaExp :: Location -> [Name] -> Expression -> a
ppLambdaExpression :: LambdaExpression -> Doc a
ppLambdaExpression le =
text "λ" <+> hsep (map ppName (_lambdaArgumentNames le)) <+> text "->" <+>
ppExpression (_lambdaBody le)
instance MkLambdaExp LambdaExpression where
mkLambdaExp = LambdaExpression
instance MkLambdaExp Expression where
mkLambdaExp l a b = LambdaExp (LambdaExpression l a b)
instance CanHaveFreeVars LambdaExpression where
freeVariables l = freeVariables (_lambdaBody l) \\
fromList (_lambdaArgumentNames l)
-- -----------------------------------------------------------------------------
data Expression = ConstExp ConstantExpression
| RefExp ReferenceExpression
| LambdaExp LambdaExpression
deriving (Show)
instance CanHaveFreeVars Expression where
freeVariables (ConstExp e) = freeVariables e
freeVariables (RefExp e) = freeVariables e
freeVariables (LambdaExp e) = freeVariables e
ppExpression :: Expression -> Doc a
ppExpression (ConstExp e) = ppConstantExpression e
ppExpression (RefExp e) = ppReferenceExpression e
ppExpression (LambdaExp e) = ppLambdaExpression e
makeLenses ''ConstantExpression
makeLenses ''ReferenceExpression
makeLenses ''LambdaExpression
emptyExpression :: Expression
emptyExpression = mkRefExp fakeLocation nothingName
isEmptyExpression :: Expression -> Bool
isEmptyExpression (RefExp e) = view refLocation e == fakeLocation &&
view refName e == nothingName
isEmptyExpression _ = False

59
src/Bang/AST/Name.hs
View File

@@ -1,59 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Name(
NameEnvironment(..)
, Name
, nothingName
, mkName
, ppName
, nameText
, nameEnvironment
, nameLocation
, nameIndex
)
where
import Control.Lens(view)
import Control.Lens.TH(makeLenses)
import Data.Text.Lazy(Text, unpack)
import Data.Word(Word)
import Bang.Syntax.Location(Location, fakeLocation)
import Bang.Utils.Pretty(text', word)
import Text.PrettyPrint.Annotated(Doc, colon, (<>))
data NameEnvironment = ModuleEnv | TypeEnv | VarEnv
deriving (Eq, Ord, Show)
data Name = Name
{ _nameText :: Text
, _nameEnvironment :: NameEnvironment
, _nameLocation :: Location
, _nameIndex :: Word
}
makeLenses ''Name
nothingName :: Name
nothingName = Name ":<nothing>:" VarEnv fakeLocation 0
mkName :: Text -> NameEnvironment -> Location -> Word -> Name
mkName = Name
ppName :: Name -> Doc a
ppName n = text' (view nameText n) <> colon <> word (view nameIndex n)
instance Eq Name where
a == b = view nameIndex a == view nameIndex b
a /= b = view nameIndex a /= view nameIndex b
instance Ord Name where
compare a b = compare (view nameIndex a) (view nameIndex b)
max a b = if a < b then b else a
min a b = if a < b then a else b
(<) a b = (<) (view nameIndex a) (view nameIndex b)
(>) a b = (>) (view nameIndex a) (view nameIndex b)
(<=) a b = (<=) (view nameIndex a) (view nameIndex b)
(>=) a b = (>=) (view nameIndex a) (view nameIndex b)
instance Show Name where
show n = unpack (view nameText n) ++ ":" ++ show (view nameIndex n)

217
src/Bang/AST/Type.hs
View File

@@ -1,217 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.AST.Type
( Type(..)
, ppType
, Kind(..)
, ppKind
, Kinded(..)
-- * the unit time
, UnitType
, ppUnitType
-- * primitive types
, PrimitiveType
, ppPrimitiveType
, mkPrimType
, ptLocation, ptName
-- * reference types
, ReferenceType
, ppReferenceType
, mkTypeRef
, rtLocation, rtKind, rtName
-- * lambda types
, FunctionType
, ppFunctionType
, mkFunType
, ftLocation, ftKind, ftArgumentType, ftResultType
-- * type application
, TypeApplication
, ppTypeApplication
, mkTypeApp
, taLocation, taKind, taLeftType, taRightType
)
where
import Bang.AST.Name(Name, ppName)
import Bang.Syntax.Location(Location)
import Bang.Utils.FreeVars(CanHaveFreeVars(..))
import Bang.Utils.Pretty(text')
import Control.Lens.TH(makeLenses)
import Data.Set(union, empty, singleton)
import Data.Text.Lazy(Text)
import Text.PrettyPrint.Annotated(Doc, (<+>), (<>), text)
data Kind = Star
| Unknown
| KindArrow Kind Kind
deriving (Show, Eq)
ppKind :: Kind -> Doc a
ppKind Star = text "*"
ppKind Unknown = text "?"
ppKind (KindArrow a b) = ppKind a <+> text "->" <+> ppKind b
class Kinded a where
kind :: a -> Kind
-- -----------------------------------------------------------------------------
data UnitType = UnitType
deriving (Show)
instance Kinded UnitType where
kind _ = Star
instance CanHaveFreeVars UnitType where
freeVariables _ = empty
ppUnitType :: UnitType -> Doc a
ppUnitType _ = text "()"
-- -----------------------------------------------------------------------------
data PrimitiveType = PrimitiveType
{ _ptLocation :: Location
, _ptName :: Text
}
deriving (Show)
class MkPrimType a where
mkPrimType :: Location -> Text -> a
instance Kinded PrimitiveType where
kind _ = Star
instance MkPrimType PrimitiveType where
mkPrimType = PrimitiveType
instance MkPrimType Type where
mkPrimType l t = TypePrim (PrimitiveType l t)
instance CanHaveFreeVars PrimitiveType where
freeVariables _ = empty
ppPrimitiveType :: PrimitiveType -> Doc a
ppPrimitiveType pt = text "llvm:" <> text' (_ptName pt)
-- -----------------------------------------------------------------------------
data ReferenceType = ReferenceType
{ _rtLocation :: Location
, _rtKind :: Kind
, _rtName :: Name
}
deriving (Show)
instance Kinded ReferenceType where
kind = _rtKind
ppReferenceType :: ReferenceType -> Doc a
ppReferenceType = ppName . _rtName
class MkTypeRef a where
mkTypeRef :: Location -> Kind -> Name -> a
instance MkTypeRef ReferenceType where
mkTypeRef = ReferenceType
instance MkTypeRef Type where
mkTypeRef l k n = TypeRef (ReferenceType l k n)
instance CanHaveFreeVars ReferenceType where
freeVariables r = singleton (_rtName r)
-- -----------------------------------------------------------------------------
data FunctionType = FunctionType
{ _ftLocation :: Location
, _ftKind :: Kind
, _ftArgumentType :: Type
, _ftResultType :: Type
}
deriving (Show)
class MkFunType a where
mkFunType :: Location -> Type -> Type -> a
instance MkFunType FunctionType where
mkFunType l a r = FunctionType l Star a r
instance MkFunType Type where
mkFunType l a r = TypeFun (FunctionType l Star a r)
ppFunctionType :: FunctionType -> Doc a
ppFunctionType ft =
ppType (_ftArgumentType ft) <+> text "->" <+> ppType (_ftResultType ft)
instance Kinded FunctionType where
kind = _ftKind
instance CanHaveFreeVars FunctionType where
freeVariables ft = freeVariables (_ftArgumentType ft) `union`
freeVariables (_ftResultType ft)
-- -----------------------------------------------------------------------------
data TypeApplication = TypeApplication
{ _taLocation :: Location
, _taKind :: Kind
, _taLeftType :: Type
, _taRightType :: Type
}
deriving (Show)
class MkTypeApp a where
mkTypeApp :: Location -> Type -> Type -> a
instance MkTypeApp TypeApplication where
mkTypeApp l s t = TypeApplication l Unknown s t
instance MkTypeApp Type where
mkTypeApp l s t = TypeApp (TypeApplication l Unknown s t)
instance Kinded TypeApplication where
kind = _taKind
ppTypeApplication :: TypeApplication -> Doc a
ppTypeApplication ta =
ppType (_taLeftType ta) <+> ppType (_taRightType ta)
instance CanHaveFreeVars TypeApplication where
freeVariables ta = freeVariables (_taLeftType ta) `union`
freeVariables (_taRightType ta)
-- -----------------------------------------------------------------------------
data Type = TypeUnit UnitType
| TypePrim PrimitiveType
| TypeRef ReferenceType
| TypeFun FunctionType
| TypeApp TypeApplication
deriving (Show)
ppType :: Type -> Doc a
ppType (TypeUnit t) = ppUnitType t
ppType (TypePrim t) = ppPrimitiveType t
ppType (TypeRef t) = ppReferenceType t
ppType (TypeFun t) = ppFunctionType t
ppType (TypeApp t) = ppTypeApplication t
instance Kinded Type where
kind (TypeUnit x) = kind x
kind (TypePrim x) = kind x
kind (TypeRef x) = kind x
kind (TypeFun x) = kind x
kind (TypeApp x) = kind x
instance CanHaveFreeVars Type where
freeVariables (TypeUnit t) = freeVariables t
freeVariables (TypePrim t) = freeVariables t
freeVariables (TypeRef t) = freeVariables t
freeVariables (TypeFun t) = freeVariables t
freeVariables (TypeApp t) = freeVariables t
makeLenses ''PrimitiveType
makeLenses ''ReferenceType
makeLenses ''FunctionType
makeLenses ''TypeApplication

122
src/Bang/CommandLine.hs
View File

@@ -1,122 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.CommandLine(
Verbosity(..)
, CommandsWithInputFile(..)
, CommandsWithOutputFile(..)
, CommandsWithVerbosity(..)
, BangCommand(..)
, ParserOptions(..)
, getCommand
, helpString
)
where
import Control.Applicative((<|>))
import Control.Lens(Lens')
import Control.Lens.TH(makeLenses)
import Data.Monoid((<>))
import Options.Applicative(Parser, ParserInfo, ParserPrefs(..), flag,
short, long, strOption, command, subparser, info,
progDesc, execParser, helper, metavar, str, argument,
showDefault, value, help)
import Options.Applicative.Help(parserHelp)
class CommandsWithInputFile opts where
inputFile :: Lens' opts FilePath
class CommandsWithOutputFile opts where
outputFile :: Lens' opts FilePath
class CommandsWithVerbosity opts where
verbosity :: Lens' opts Verbosity
-- -----------------------------------------------------------------------------
data Verbosity = Silent | Normal | Verbose
deriving (Eq, Show)
verboseOption :: Parser Verbosity
verboseOption = flag Normal Silent (short 'q' <> long "quiet")
<|> flag Normal Verbose (short 'v' <> long "verbose")
optOutputFile :: Parser FilePath
optOutputFile = strOption (short 'o' <> long "output-file" <> metavar "FILE"
<> help "The file to output as a result of this action."
<> value "/dev/stdout" <> showDefault)
-- -----------------------------------------------------------------------------
data ParserOptions = ParserOptions {
_parseInputFile :: FilePath
, _parseOutputFile :: FilePath
, _parseVerbosity :: Verbosity
}
deriving (Show)
makeLenses ''ParserOptions
parseParseOptions :: Parser ParserOptions
parseParseOptions = ParserOptions <$> argument str (metavar "FILE")
<*> optOutputFile
<*> verboseOption
instance CommandsWithInputFile ParserOptions where
inputFile = parseInputFile
instance CommandsWithOutputFile ParserOptions where
outputFile = parseOutputFile
instance CommandsWithVerbosity ParserOptions where
verbosity = parseVerbosity
-- -----------------------------------------------------------------------------
data TypeCheckOptions = TypeCheckOptions {
_tcheckInputFile :: FilePath
, _tcheckOutputFile :: FilePath
, _tcheckVerbosity :: Verbosity
}
deriving (Show)
makeLenses ''TypeCheckOptions
parseTypeCheckOptions :: Parser TypeCheckOptions
parseTypeCheckOptions = TypeCheckOptions <$> argument str (metavar "FILE")
<*> optOutputFile
<*> verboseOption
instance CommandsWithInputFile TypeCheckOptions where
inputFile = tcheckInputFile
instance CommandsWithOutputFile TypeCheckOptions where
outputFile = tcheckOutputFile
instance CommandsWithVerbosity TypeCheckOptions where
verbosity = tcheckVerbosity
-- -----------------------------------------------------------------------------
data BangCommand = Help
| Parse ParserOptions
| TypeCheck TypeCheckOptions
| Version
deriving (Show)
bangOperation :: Parser BangCommand
bangOperation = subparser $
command "help" (pure Help `withInfo` "Describe common commands.") <>
command "version" (pure Version `withInfo` "Display version information.") <>
command "parse" (parseParse `withInfo` "Parse a file into its AST.") <>
command "typeCheck" (parseTCheck `withInfo` "Type check a file.")
where
parseParse = Parse <$> parseParseOptions
parseTCheck = TypeCheck <$> parseTypeCheckOptions
withInfo :: Parser a -> String -> ParserInfo a
withInfo opts desc = info (helper <*> opts) (progDesc desc)
helpString :: String
helpString = show (parserHelp (ParserPrefs "" False False True 80) bangOperation)
getCommand :: IO BangCommand
getCommand = execParser (bangOperation `withInfo` "Run a bang language action.")

11
src/Bang/Error.hs
View File

@@ -1,11 +0,0 @@
module Bang.Error(
exit
)
where
import System.Exit(ExitCode(..), exitWith)
exit :: String -> IO b
exit x =
do putStrLn ("ERROR: " ++ x)
exitWith (ExitFailure 1)

176
src/Bang/Monad.hs
View File

@@ -1,176 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Bang.Monad(
Compiler
, BangError(..)
, BangWarning(..)
, runCompiler
, runPass
, getPassState, setPassState, mapPassState, overPassState, viewPassState
, registerName, registerNewName, genName, genTypeRef, genVarRef
, warn, err, err'
)
where
import Bang.AST.Expression(Expression, mkRefExp)
import Bang.AST.Name(NameEnvironment(..), Name, mkName, nameIndex)
import Bang.AST.Type(Kind(..), Type, mkTypeRef)
import Bang.CommandLine(BangCommand, CommandsWithInputFile(..))
import Bang.Error(exit)
import Bang.Syntax.Location(Location(..), Origin(..),
unknownLocation, ppLocation)
import Bang.Utils.Pretty(BangDoc)
import Control.Exception(tryJust)
import Control.Lens(Lens', over, set, view)
import Control.Lens.TH(makeLenses)
import Control.Monad(guard, when)
import Data.Text.Lazy(Text, pack)
import qualified Data.Text.Lazy.IO as T
import System.Exit(ExitCode(..), exitWith)
import System.IO.Error(isDoesNotExistError)
import Text.PrettyPrint.Annotated(text, ($+$), nest, render)
class BangError e where
ppError :: e -> (Maybe Location, BangDoc)
class BangWarning w where
ppWarning :: w -> (Maybe Location, BangDoc)
data CompilerState state = CompilerState {
_csNextIdent :: !Word
, _csPromoteWarnings :: !Bool
, _csWarnings :: [BangDoc]
, _csPassState :: !state
}
makeLenses ''CompilerState
initialState :: BangCommand -> CompilerState ()
initialState _ = CompilerState 1 False [] ()
-- -----------------------------------------------------------------------------
newtype Compiler s a =
Compiler { unCompiler :: CompilerState s -> IO (CompilerState s, a) }
instance Applicative (Compiler s) where
pure a = Compiler (\ st -> return (st, a))
mf <*> ma = Compiler (\ st ->
do (st', f) <- unCompiler mf st
(st'', a) <- unCompiler ma st'
return (st'', f a))
instance Functor (Compiler s) where
fmap f m = return f <*> m
instance Monad (Compiler s) where
return a = Compiler (\ st -> return (st, a))
m >>= k = Compiler (\ st ->
do (st', a) <- unCompiler m st
unCompiler (k a) st')
runCompiler :: CommandsWithInputFile o =>
BangCommand -> o ->
(Origin -> Text -> Compiler () a) ->
IO a
runCompiler cmd opts action =
do let path = view inputFile opts
orig = File path
mtxt <- tryJust (guard . isDoesNotExistError) (T.readFile path)
case mtxt of
Left _ -> exit ("Unable to open file '" ++ path ++ "'")
Right txt -> snd `fmap` unCompiler (action orig txt) (initialState cmd)
runPass :: s2 -> (Compiler s2 a) -> Compiler s1 (s2, a)
runPass s2 action =
Compiler (\ cst1 ->
do let cst2 = set csPassState s2 cst1
s1 = view csPassState cst1
(cst2', v) <- unCompiler action cst2
let retval = (view csPassState cst2', v)
return (set csPassState s1 cst2', retval))
getPassState :: Compiler s s
getPassState = Compiler (\ st -> return (st, view csPassState st))
setPassState :: Lens' s b -> b -> Compiler s ()
setPassState passLens v =
Compiler (\ st -> return (set (csPassState . passLens) v st, ()))
mapPassState :: (s -> s) -> Compiler s ()
mapPassState f = Compiler (\ st -> return (over csPassState f st, ()))
overPassState :: Lens' s b -> (b -> b) -> Compiler s ()
overPassState passLens f =
Compiler (\ st -> return (over (csPassState . passLens) f st, ()))
viewPassState :: Lens' s b -> Compiler s b
viewPassState l = Compiler (\ st -> return (st, view (csPassState . l) st))
-- -----------------------------------------------------------------------------
registerName :: Name -> Compiler s Name
registerName name =
Compiler (\ st ->
do let current = view csNextIdent st
return (over csNextIdent (+1) st, set nameIndex current name))
registerNewName :: NameEnvironment -> Text -> Compiler s Name
registerNewName env name =
Compiler (\ st ->
do let current = view csNextIdent st
res = mkName name env unknownLocation current
return (over csNextIdent (+1) st, res))
genName :: NameEnvironment -> Compiler s Name
genName env =
Compiler (\ st ->
do let current = view csNextIdent st
str = "gen:" ++ show current
res = mkName (pack str) env unknownLocation current
return (over csNextIdent (+1) st, res))
genTypeRef :: Kind -> Compiler s Type
genTypeRef k = mkTypeRef unknownLocation k `fmap` genName TypeEnv
genVarRef :: Compiler s Expression
genVarRef = mkRefExp unknownLocation `fmap` genName VarEnv
-- -----------------------------------------------------------------------------
data WErrorWarning w = WErrorWarning w
instance BangWarning w => BangError (WErrorWarning w) where
ppError (WErrorWarning w) =
let (loc, wdoc) = ppWarning w
edoc = text "Warning lifted to error by -WError:" $+$ nest 3 wdoc
in (loc, edoc)
warn :: BangWarning w => w -> Compiler s ()
warn w = Compiler (\ st ->
if view csPromoteWarnings st
then runError (WErrorWarning w) False >> return (st, ())
else runWarning w >> return (st, ()))
err :: BangError w => w -> Compiler s a
err w = Compiler (\ _ -> runError w True >> undefined)
err' :: BangError e => e -> Compiler s ()
err' e = Compiler (\ st -> runError e False >> return (st, ()))
runWarning :: BangWarning w => w -> IO ()
runWarning w = putStrLn (go (ppWarning w))
where
go (Nothing, doc) = render doc
go (Just a, doc) = render (ppLocation a $+$ nest 3 doc)
runError :: BangError w => w -> Bool -> IO ()
runError e die =
do putStrLn (go (ppError e))
when die $ exitWith (ExitFailure 1)
where
go (Nothing, doc) = render doc
go (Just a, doc) = render (ppLocation a $+$ nest 3 doc)

118
src/Bang/Syntax/Lexer.x
View File

@@ -1,118 +0,0 @@
-- -*- mode: haskell -*-
-- vi: set ft=haskell :
{
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS -w #-}
module Bang.Syntax.Lexer(
AlexReturn(..)
, AlexInput(..)
, alexScan
)
where
import Bang.Syntax.Location(Location(..), Located(..), Origin(..),
Position(..), advanceWith, advanceWith',
locatedAt, initialPosition)
import Bang.Syntax.Token(Token(..), Fixity(..))
import Data.Char(isAscii, ord)
import Data.Int(Int64)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Maybe(fromMaybe)
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
import Data.Word(Word8)
}
-- Digits
$decdigit = 0-9
$hexdigit = [0-9a-fA-f]
$octdigit = 0-7
$bindigit = [01]
-- Identifier Characters
$typestart = [A-Z\_]
$valstart = [a-z\_]
$identrest = [a-zA-Z0-9\_\.]
$opident = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_\|:]
$escape_char = [abfnrtv'\"\\] --"
:-
-- Whitespace
$white+ ;
"/*"[.\n]*"*/" ;
-- Numbers
$decdigit+ { emitI 0 (IntTok 10) }
"0x"$hexdigit+ { emitI 2 (IntTok 16) }
"0o"$octdigit+ { emitI 2 (IntTok 8) }
"0b"$bindigit+ { emitI 2 (IntTok 2) }
$decdigit+"."$decdigit+ ("e""-"?$decdigit+)? { emitS FloatTok}
$decdigit+"e""-"?$decdigit+ { emitS FloatTok}
-- Identifier
$typestart $identrest* { emitS TypeIdent }
$valstart $identrest* { emitS ValIdent }
$opident+ { emitO }
-- Characters and Strings
['].['] { emitS CharTok }
['] [\\] $escape_char ['] { emitS CharTok }
[\"] ([^\"] | [\n] | ([\\] $escape_char))* [\"] { emitS StringTok } --"
-- Symbols
"(" { emitT "(" }
")" { emitT ")" }
"[" { emitT "[" }
"]" { emitT "]" }
"{" { emitT "{" }
"}" { emitT "}" }
";" { emitT ";" }
"," { emitT "," }
"`" { emitT "`" }
[\\] { emitT "\\" }
{
type AlexAction = Origin -> Map Text Fixity -> Int -> AlexInput -> Located Token
data AlexInput = AlexInput !Position Text
emitT :: Text -> AlexAction
emitT t = emitS (const (Special t))
emitS :: (Text -> Token) -> AlexAction
emitS mk src _ len (AlexInput pos t) = token `locatedAt` loc
where
txt = T.take (fromIntegral len) t
token = mk txt
loc = Location src pos (pos `advanceWith'` txt)
emitI :: Int64 -> (Text -> Token) -> AlexAction
emitI dropCount mk src _ len (AlexInput pos t) = token `locatedAt` loc
where
baseText = T.take (fromIntegral len) t
txt = T.drop dropCount baseText
token = mk txt
loc = Location src pos (pos `advanceWith'` baseText)
emitO :: AlexAction
emitO src fixTable len (AlexInput pos t) =
case Map.lookup baseText fixTable of
Nothing -> OpIdent (LeftAssoc 9) baseText `locatedAt` loc
Just f -> OpIdent f baseText `locatedAt` loc
where
baseText = T.take (fromIntegral len) t
loc = Location src pos (pos `advanceWith'` baseText)
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
alexGetByte (AlexInput p t) =
do (c, rest) <- T.uncons t
return (byteForChar c, (AlexInput (p `advanceWith` c) rest))
where
byteForChar c | isAscii c = fromIntegral (ord c)
| otherwise = 0
}

105
src/Bang/Syntax/Location.hs
View File

@@ -1,105 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.Syntax.Location(
Position, posRow, posColumn, posOffset
, ppPosition
, initialPosition
, advanceWith, advanceWith'
, Origin(..)
, ppOrigin
, Location(Location)
, locSource, locStart, locEnd
, ppLocation
, Located(..)
, locatedAt
, unknownLocation
, fakeLocation
)
where
import Bang.Utils.Pretty(BangDoc, word)
import Control.Lens
import Control.Lens.TH(makeLenses)
import Data.Monoid((<>))
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
import Text.PrettyPrint.Annotated(colon, parens, text)
data Position = Position {
_posRow :: Word
, _posColumn :: Word
, _posOffset :: Word
}
deriving (Show)
makeLenses ''Position
ppPosition :: Position -> BangDoc
ppPosition (Position r c _) = word r <> colon <> word c
initialPosition :: Position
initialPosition = Position 1 1 0
instance Eq Position where
a == b = _posOffset a == _posOffset b
advanceWith :: Position -> Char -> Position
advanceWith (Position r c o) '\t' = Position r (c+8) (o+1)
advanceWith (Position r _ o) '\n' = Position (r+1) 1 (o+1)
advanceWith (Position r c o) _ = Position r (c+1) (o+1)
advanceWith' :: Position -> Text -> Position
advanceWith' pos txt =
case T.uncons txt of
Nothing -> pos
Just (c, rest) -> advanceWith' (pos `advanceWith` c) rest
data Origin = Unknown
| Generated
| Interactive
| File FilePath
deriving (Eq, Show)
ppOrigin :: Origin -> BangDoc
ppOrigin x =
case x of
Unknown -> text "<unknown>"
Generated -> text "<generated>"
Interactive -> text "<interactive>"
File f -> text f
data Location = Location {
_locSource :: Origin
, _locStart :: Position
, _locEnd :: Position
}
deriving (Eq, Show)
makeLenses ''Location
ppLocation :: Location -> BangDoc
ppLocation loc
| start == end = ppOrigin src <> colon <> ppPosition start
| view posRow start == view posRow end =
ppOrigin src <> colon <> word (view posRow start) <> colon <>
word (view posColumn start) <> text "–" <> word (view posColumn end)
| otherwise =
ppOrigin src <> colon <> parens (ppPosition start) <> text "–" <>
parens (ppPosition end)
where
src = view locSource loc
start = view locStart loc
end = view locEnd loc
data Located a = Located !Location a
instance Show a => Show (Located a) where
show (Located l x) = show x ++ " `locatedAt` " ++ show l
locatedAt :: a -> Location -> Located a
locatedAt a p = Located p a
unknownLocation :: Location
unknownLocation = Location Unknown initialPosition initialPosition
fakeLocation :: Location
fakeLocation = Location Generated initialPosition initialPosition

32
src/Bang/Syntax/Name.hs
View File

@@ -1,32 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
module Bang.Syntax.Name(
Name
, nameId
, nameString
, nameGenerated
)
where
import Control.Lens.TH(makeLenses)
data Name = Name {
_nameId :: !Word
, _nameString :: !String
, _nameGenerated :: !Bool
}
makeLenses ''Name
instance Eq Name where
a == b = _nameId a == _nameId b
a /= b = _nameId a /= _nameId b
instance Ord Name where
compare a b = compare (_nameId a) (_nameId b)
max a b = if a > b then a else b
min a b = if a > b then b else a
a < b = _nameId a < _nameId b
a <= b = _nameId a <= _nameId b
a > b = _nameId a > _nameId b
a >= b = _nameId a >= _nameId b

253
src/Bang/Syntax/Parser.y
View File

@@ -1,253 +0,0 @@
-- -*- mode: haskell -*-
-- vi: set ft=haskell :
{
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTION_GHC -w #-}
module Bang.Syntax.Parser(
runParser
, parseModule
)
where
import Bang.Monad(err)
import Bang.AST(Name, Module, NameEnvironment(..), mkModule, mkName, emptyExpression)
import Bang.AST.Declaration(Declaration, mkTypeDecl, mkValueDecl)
import Bang.AST.Expression(ConstantValue(..), Expression, mkConstExp, mkRefExp, mkLambdaExp)
import Bang.AST.Type(Type, Kind(..), mkTypeRef, mkFunType, mkTypeApp, mkPrimType)
import Bang.Syntax.Location(Located(..), Origin, Position)
import Bang.Syntax.ParserError(ParserError(..))
import Bang.Syntax.ParserMonad(Parser, addFixities, parseError, runNextToken, runParser)
import Bang.Syntax.Token(Token(..), Fixity(..))
import Control.Monad(forM)
import Data.List(union)
import Data.Text.Lazy(Text)
}
%name top_module
%tokentype { Located Token }
%monad { Parser }
%error { parseError }
%lexer { runNextToken } { Located _ EOFTok }
%token
'::' { Located $$ (OpIdent _ "::") }
'=' { Located $$ (OpIdent _ "=") }
',' { Located $$ (OpIdent _ ",") }
'->' { Located $$ (OpIdent _ "->") }
'infixl' { Located $$ (ValIdent "infixl") }
'infixr' { Located $$ (ValIdent "infixr") }
'infix' { Located $$ (ValIdent "infix") }
'module' { Located $$ (ValIdent "module") }
'primitive' { Located $$ (ValIdent "primitive") }
'type' { Located $$ (ValIdent "type") }
Integer { Located _ (IntTok _ _) }
Float { Located _ (FloatTok _) }
Char { Located _ (CharTok _) }
String { Located _ (StringTok _) }
OpIdent { Located _ (OpIdent _ _) }
TypeIdent { Located _ (TypeIdent _) }
ValIdent { Located _ (ValIdent _) }
OPL0 { Located _ (OpIdent (LeftAssoc 0) _) }
OPR0 { Located _ (OpIdent (RightAssoc 0) _) }
OPN0 { Located _ (OpIdent (NonAssoc 0) _) }
OPL1 { Located _ (OpIdent (LeftAssoc 1) _) }
OPR1 { Located _ (OpIdent (RightAssoc 1) _) }
OPN1 { Located _ (OpIdent (NonAssoc 1) _) }
OPL2 { Located _ (OpIdent (LeftAssoc 2) _) }
OPR2 { Located _ (OpIdent (RightAssoc 2) _) }
OPN2 { Located _ (OpIdent (NonAssoc 2) _) }
OPL3 { Located _ (OpIdent (LeftAssoc 3) _) }
OPR3 { Located _ (OpIdent (RightAssoc 3) _) }
OPN3 { Located _ (OpIdent (NonAssoc 3) _) }
OPL4 { Located _ (OpIdent (LeftAssoc 4) _) }
OPR4 { Located _ (OpIdent (RightAssoc 4) _) }
OPN4 { Located _ (OpIdent (NonAssoc 4) _) }
OPL5 { Located _ (OpIdent (LeftAssoc 5) _) }
OPR5 { Located _ (OpIdent (RightAssoc 5) _) }
OPN5 { Located _ (OpIdent (NonAssoc 5) _) }
OPL6 { Located _ (OpIdent (LeftAssoc 6) _) }
OPR6 { Located _ (OpIdent (RightAssoc 6) _) }
OPN6 { Located _ (OpIdent (NonAssoc 6) _) }
OPL7 { Located _ (OpIdent (LeftAssoc 7) _) }
OPR7 { Located _ (OpIdent (RightAssoc 7) _) }
OPN7 { Located _ (OpIdent (NonAssoc 7) _) }
OPL8 { Located _ (OpIdent (LeftAssoc 8) _) }
OPR8 { Located _ (OpIdent (RightAssoc 8) _) }
OPN8 { Located _ (OpIdent (NonAssoc 8) _) }
OPL9 { Located _ (OpIdent (LeftAssoc 9) _) }
OPR9 { Located _ (OpIdent (RightAssoc 9) _) }
OPN9 { Located _ (OpIdent (NonAssoc 9) _) }
%right OPL0
%left OPR0
%nonassoc OPN0
%right OPL1
%left OPR1
%nonassoc OPN1
%right OPL2
%left OPR2
%nonassoc OPN2
%right OPL3
%left OPR3
%nonassoc OPN3
%right OPL4
%left OPR4
%nonassoc OPN4
%right OPL5
%left OPR5
%nonassoc OPN5
%right OPL6
%left OPR6
%nonassoc OPN6
%right OPL7
%left OPR7
%nonassoc OPN7
%right OPL8
%left OPR8
%nonassoc OPN8
%right OPL9
%left OPR9
%nonassoc OPN9
%%
top_module :: { Module }
: 'module' TypeIdent listopt(Declaration)
{%
do let Located src (TypeIdent rawName) = $2
return (mkModule (mkName rawName ModuleEnv src 0) [$3]) }
Declaration :: { Maybe Declaration }
: ValueDeclaration { Just $1 }
| FixityDeclaration { Nothing }
| TypeDeclaration { Just $1 }
ValueDeclaration :: { Declaration }
: list1(ValIdent) '=' Expression
{%
case $1 of
[] ->
err (InternalError $2 "ValDeclLHS")
[Located src (ValIdent rawName)] ->
do let name = mkName rawName VarEnv src 0
return (mkValueDecl name src Nothing $3)
((Located src (ValIdent rawName)) : args) ->
do let name = mkName rawName VarEnv src 0
argNames = map (\ (Located arsrc (ValIdent argName)) ->
mkName argName VarEnv arsrc 0)
args
return (mkValueDecl name src Nothing
(mkLambdaExp $2 argNames $3))
}
FixityDeclaration :: { () }
: 'infixl' Integer sep(',',OpIdent)
{% addFixities $1 LeftAssoc $2 $3 }
| 'infixr' Integer sep(',',OpIdent)
{% addFixities $1 RightAssoc $2 $3 }
| 'infix' Integer sep(',',OpIdent)
{% addFixities $1 NonAssoc $2 $3 }
TypeDeclaration :: { Declaration }
: ValIdent '::' Type
{%
do let Located src (ValIdent rawName) = $1
name = mkName rawName VarEnv src 0
return (mkValueDecl name src (Just $3) emptyExpression) }
| 'type' TypeIdent '=' Type
{%
do let Located src (TypeIdent rawName) = $2
name = mkName rawName TypeEnv src 0
return (mkTypeDecl name src $4) }
| 'primitive' 'type' TypeIdent '=' String
{%
do let Located nsrc (TypeIdent rawName) = $3
Located tsrc (StringTok rawText) = $5
name = mkName rawName TypeEnv nsrc 0
return (mkTypeDecl name $2 (mkPrimType tsrc rawText)) }
-- -----------------------------------------------------------------------------
Type :: { Type }
: RawType { $1 }
RawType :: { Type }
: RawType '->' BaseType { mkFunType $2 $1 $3 }
| BaseType { $1 }
BaseType :: { Type }
: TypeIdent {%
let Located src (TypeIdent rawName) = $1
name = mkName rawName TypeEnv src 0
in return (mkTypeRef src Unknown name) }
| ValIdent {%
let Located src (ValIdent rawName) = $1
name = mkName rawName TypeEnv src 0
in return (mkTypeRef src Unknown name) }
-- -----------------------------------------------------------------------------
Expression :: { Expression }
: BaseExpression { $1 }
BaseExpression :: { Expression }
: OpIdent {%
let Located src (OpIdent _ rawName) = $1
name = mkName rawName VarEnv src 0
in return (mkRefExp src name) }
| ValIdent {%
let Located src (ValIdent rawName) = $1
name = mkName rawName VarEnv src 0
in return (mkRefExp src name) }
| Integer { let Located src (IntTok base val) = $1
in mkConstExp src (ConstantInt base val) }
| String { let Located src (StringTok val) = $1
in mkConstExp src (ConstantString val) }
| Float { let Located src (FloatTok val) = $1
in mkConstExp src (ConstantFloat val) }
| Char { let Located src (CharTok val) = $1
in mkConstExp src (ConstantChar val) }
-- -----------------------------------------------------------------------------
opt(p)
: {- empty -} { Nothing }
| p { Just $1 }
sep(p,q)
: {- empty -} { [] }
| sep_body(p,q) { reverse $1 }
sep1(p,q)
: sep_body(p,q) { reverse $1 }
sep_body(p,q)
: q { [$1] }
| sep_body(p,q) p q { $3 : $1 }
list(p)
: {- empty -} { [] }
| list_body(p) { reverse $1 }
list1(p)
: list_body(p) { reverse $1 }
list_body(p)
: p { [$1] }
| list_body(p) p { $2 : $1 }
listopt(p)
: {- empty -} { [] }
| listopt(p) p { case $2 of
Nothing -> $1
Just x -> $1 ++ [x]
}
{
parseModule :: Parser Module
parseModule = top_module
}

43
src/Bang/Syntax/ParserError.hs
View File

@@ -1,43 +0,0 @@
module Bang.Syntax.ParserError(
ParserError(..)
)
where
import Data.Text.Lazy(Text)
import Bang.Monad(BangError(..))
import Bang.Syntax.Location(Location, ppLocation)
import Bang.Syntax.Token(Token, ppToken)
import Bang.Utils.Pretty(BangDoc, text')
import Text.PrettyPrint.Annotated((<+>), ($+$), text, quotes, text, nest)
data ParserError = LexError Location Text
| ParseError Location Token
| RedefinitionError Location Location Text
| InternalError Location Text
| UnboundVariable Location Text
| UnexpectedEOF
deriving (Show)
instance BangError ParserError where
ppError = prettyError
prettyError :: ParserError -> (Maybe Location, BangDoc)
prettyError e =
case e of
LexError l t ->
(Just l, text "Lexical error around token" <+> quotes (text' t))
ParseError l t ->
(Just l, text "Parser error around token" <+> quotes (ppToken t))
RedefinitionError errLoc origLoc t ->
let line1 = text "Variable" <+> quotes (text' t) <+> text "is redefined: "
line2 = text "Original definition:" <+> ppLocation origLoc
line3 = text "Redefinition:" <+> ppLocation errLoc
in (Nothing, line1 $+$ nest 3 (line2 $+$ line3))
InternalError loc t ->
(Just loc, text' t)
UnboundVariable loc t ->
(Just loc, text "Unbound variable" <+> quotes (text' t))
UnexpectedEOF ->
(Nothing, text "Unexpected end of file.")

129
src/Bang/Syntax/ParserMonad.hs
View File

@@ -1,129 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Bang.Syntax.ParserMonad(
Parser
, runParser
, addFixities
, parseError
, runNextToken
)
where
import Bang.Monad(Compiler, err, runPass,
setPassState, overPassState, viewPassState)
import Bang.Syntax.Lexer(AlexReturn(..), AlexInput(..), alexScan)
import Bang.Syntax.Location(Location(..), Located(..),
Origin(..), initialPosition,
advanceWith', locatedAt)
import Bang.Syntax.ParserError(ParserError(..))
import Bang.Syntax.Token(Token(..), Fixity)
import Control.Lens.TH(makeLenses)
import Control.Monad(forM_)
import Data.Char(digitToInt, isSpace)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy as T
data ParserState = ParserState {
_psPrecTable :: Map Text Fixity
, _psOrigin :: Origin
, _psLexerState :: AlexInput
}
makeLenses ''ParserState
type Parser a = Compiler ParserState a
runParser :: Origin -> Text -> Parser a -> Compiler ps a
runParser origin stream action = snd `fmap` runPass pstate action
where
initInput = AlexInput initialPosition stream
pstate = ParserState Map.empty origin initInput
-- -----------------------------------------------------------------------------
addFixities :: Location ->
(Word -> Fixity) -> Located Token -> [Located Token] ->
Parser ()
addFixities src fixityBuilder lval names =
do value <- processInteger lval
let fixity = fixityBuilder value
forM_ names $ \ tok ->
overPassState psPrecTable (Map.insert (tokenName tok) fixity)
where
processInteger x =
case x of
Located _ (IntTok base text) ->
return (makeNumeric base text 0)
_ ->
err (InternalError src "Non-number in fixity?")
--
makeNumeric base text acc =
case T.uncons text of
Nothing -> acc
Just (x, rest) ->
let acc' = (acc * base) + charValue x
in makeNumeric base rest acc'
--
charValue = fromIntegral . digitToInt
--
tokenName t =
case t of
Located _ (TypeIdent x) -> x
Located _ (ValIdent x) -> x
Located _ (OpIdent _ x) -> x
_ ->
error "Internal error (tokenName in Parser.y)"
getFixities :: Parser (Map Text Fixity)
getFixities = viewPassState psPrecTable
-- -----------------------------------------------------------------------------
runNextToken :: (Located Token -> Parser a) ->
Parser a
runNextToken parseAction = go =<< getLexerState
where
go state@(AlexInput initPos _) =
case alexScan state 0 of
AlexEOF ->
do orig <- getOrigin
parseAction (EOFTok `locatedAt` Location orig initPos initPos)
AlexError (AlexInput pos text) ->
do let (as, bs) = T.break isSpace text
pos' = advanceWith' pos as
input' = AlexInput pos' bs
setLexerState input'
orig <- getOrigin
parseAction (ErrorTok as `locatedAt` Location orig initPos initPos)
AlexSkip input' _ ->
go input'
AlexToken input' len lexAction ->
do setLexerState input'
src <- getOrigin
table <- getFixities
parseAction (lexAction src table len state)
-- -----------------------------------------------------------------------------
getOrigin :: Parser Origin
getOrigin = viewPassState psOrigin
getLexerState :: Parser AlexInput
getLexerState = viewPassState psLexerState
setLexerState :: AlexInput -> Parser ()
setLexerState = setPassState psLexerState
-- -----------------------------------------------------------------------------
parseError :: Located Token -> Parser a
parseError t =
case t of
Located _ EOFTok -> err UnexpectedEOF
Located p (ErrorTok tok) -> err (LexError p tok)
Located p tok -> err (ParseError p tok)

217
src/Bang/Syntax/PostProcess.hs
View File

@@ -1,217 +0,0 @@
{-# LANGUAGE RankNTypes #-}
module Bang.Syntax.PostProcess(
runPostProcessor
)
where
import Bang.AST(Name, Module, moduleDeclarations, ppName,
nameText, nameLocation, nameEnvironment)
import Bang.AST.Declaration(Declaration(..), declName,
tdName, tdType,
ValueDeclaration, vdName, vdLocation,
vdDeclaredType, vdValue)
import Bang.AST.Expression(Expression(..), isEmptyExpression, refName,
lambdaArgumentNames, lambdaBody,
isEmptyExpression)
import Bang.AST.Type(Type(..), rtName, ftArgumentType, ftResultType,
taLeftType, taRightType)
import Bang.Monad(Compiler, BangError(..), err, err', registerName)
import Bang.Syntax.Location(Location, ppLocation)
import Bang.Utils.FreeVars(CanHaveFreeVars(..))
import Bang.Utils.Pretty(BangDoc, text')
import Control.Lens(Lens', view, set)
import Control.Monad(foldM)
import Data.Char(isLower)
import Data.Graph(SCC(..))
import Data.Graph.SCC(stronglyConnComp)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Set(toList)
import Data.Text.Lazy(uncons)
import Text.PrettyPrint.Annotated(text, ($+$), (<+>), nest, quotes)
data PostProcessError = InternalError Name
| UndefinedVariable Name
| RedefinitionError Name Location Location
| TypeDeclWithoutValue Name Location
deriving (Show)
instance BangError PostProcessError where
ppError = prettyError
prettyError :: PostProcessError -> (Maybe Location, BangDoc)
prettyError e =
case e of
InternalError n ->
(Nothing, text "Serious post-processing error w.r.t. " <+> ppName n)
UndefinedVariable n ->
(Just (view nameLocation n), text "Undefined variable " <+> quotes (text' (view nameText n)))
RedefinitionError n l1 l2 ->
(Just l1, text "Name" <+> ppName n <+> text "redefined." $+$
nest 2 (text "original definiton at " <+> ppLocation l2))
TypeDeclWithoutValue n l ->
(Just l, text "Type declaration provided, but no value provided." $+$
nest 2 (text "variable name: " <+> ppName n))
runPostProcessor :: Module -> Compiler ps Module
runPostProcessor mdl =
do let baseDecls = concat (view moduleDeclarations mdl)
decls <- linkNames baseDecls
declTable <- makeDeclarationTable decls
decls' <- combineTypeValueDeclarations declTable decls
return (set moduleDeclarations (orderDecls decls') mdl)
-- -----------------------------------------------------------------------------
linkNames :: [Declaration] -> Compiler ps [Declaration]
linkNames decls =
do declaredNames <- foldM addNewNames Map.empty (map (view declName) decls)
mapM (linkDecls declaredNames) decls
where
addNewNames t n =
do n' <- registerName n
let key = (view nameText n, view nameEnvironment n)
return (Map.insert key n' t)
--
replaceName nameMap name =
do let key = (view nameText name, view nameEnvironment name)
case Map.lookup key nameMap of
Nothing -> err' (UndefinedVariable name) >> return name
Just name' -> return name'
--
addOrReplaceName nameMap name =
do let key = (view nameText name, view nameEnvironment name)
case Map.lookup key nameMap of
Nothing | couldBeTypeVariable name ->
do name' <- registerName name
return (name', Map.insert key name' nameMap)
Nothing ->
err' (UndefinedVariable name) >> return (name, nameMap)
Just name' ->
return (name', nameMap)
--
couldBeTypeVariable n =
case uncons (view nameText n) of
Nothing ->
error "Empty variable name?"
Just (x,_) ->
isLower x
--
linkDecls nameMap (DeclType td) =
do td' <- overM tdType (linkType' nameMap) td
td'' <- overM tdName (replaceName nameMap) td'
return (DeclType td'')
linkDecls nameMap (DeclVal vd) =
do vd' <- overM vdDeclaredType (traverse (linkType' nameMap)) vd
vd'' <- overM vdValue (linkExpr nameMap) vd'
vd''' <- overM vdName (replaceName nameMap) vd''
return (DeclVal vd''')
--
linkType' nm t = fst `fmap` linkType nm t
--
linkType nameMap x@(TypeUnit _) = return (x, nameMap)
linkType nameMap x@(TypePrim _) = return (x, nameMap)
linkType nameMap (TypeRef t) =
do (name, nameMap') <- addOrReplaceName nameMap (view rtName t)
let t' = set rtName name t
return (TypeRef t', nameMap')
linkType nameMap (TypeFun t) =
do (argType, nameMap') <- linkType nameMap (view ftArgumentType t)
(resType, nameMap'') <- linkType nameMap' (view ftResultType t)
return (TypeFun (set ftArgumentType argType $
set ftResultType resType t),
nameMap'')
linkType nameMap (TypeApp t) =
do (lt, nameMap') <- linkType nameMap (view taLeftType t)
(rt, nameMap'') <- linkType nameMap' (view taRightType t)
return (TypeApp (set taLeftType lt (set taRightType rt t)), nameMap'')
--
linkExpr _ x | isEmptyExpression x = return x
linkExpr _ x@(ConstExp _) = return x
linkExpr nameMap (RefExp e) =
RefExp `fmap` overM refName (replaceName nameMap) e
linkExpr nameMap (LambdaExp e) =
do let names = view lambdaArgumentNames e
nameMap' <- foldM addNewNames nameMap names
e' <- overM lambdaArgumentNames (mapM (replaceName nameMap')) e
e'' <- overM lambdaBody (linkExpr nameMap') e'
return (LambdaExp e'')
overM :: Monad m => Lens' s a -> (a -> m a) -> s -> m s
overM field action input =
do newval <- action (view field input)
return (set field newval input)
-- -----------------------------------------------------------------------------
type DeclarationTable = Map Name (Maybe (Type, Location), Maybe ValueDeclaration)
makeDeclarationTable :: [Declaration] -> Compiler ps DeclarationTable
makeDeclarationTable decls = foldM combine Map.empty decls
where
combine table d =
do let name = view declName d
case d of
DeclType _ ->
return table
DeclVal vd | Just t <- view vdDeclaredType vd,
isEmptyExpression (view vdValue vd) ->
do let myLoc = view vdLocation vd
myVal = Just (t, myLoc)
case Map.lookup name table of
Nothing ->
return (Map.insert name (myVal, Nothing) table)
Just (Nothing, vd') ->
return (Map.insert name (myVal, vd') table)
Just (Just (_, theirLoc), _) ->
err (RedefinitionError name myLoc theirLoc)
DeclVal vd | Just _ <- view vdDeclaredType vd ->
err (InternalError name)
DeclVal vd | isEmptyExpression (view vdValue vd) ->
err (InternalError name)
DeclVal vd ->
case Map.lookup name table of
Nothing ->
return (Map.insert name (Nothing, Just vd) table)
Just (td, Nothing) ->
return (Map.insert name (td, Just vd) table)
Just (_, Just vd') ->
do let newLoc = view vdLocation vd
origLoc = view vdLocation vd'
err (RedefinitionError name newLoc origLoc)
-- -----------------------------------------------------------------------------
combineTypeValueDeclarations :: DeclarationTable ->
[Declaration] ->
Compiler ps [Declaration]
combineTypeValueDeclarations table decls = process decls
where
process [] = return []
process (x:rest) =
case x of
DeclType _ ->
(x:) `fmap` process rest
DeclVal vd | Just _ <- view vdDeclaredType vd,
isEmptyExpression (view vdValue vd) ->
process rest
DeclVal vd ->
case Map.lookup (view vdName vd) table of
Nothing ->
err (InternalError (view vdName vd))
Just (Nothing, _) ->
(x:) `fmap` process rest
Just (Just (t, _), _) ->
do let vd' = set vdDeclaredType (Just t) vd
(DeclVal vd' :) `fmap` process rest
-- -----------------------------------------------------------------------------
orderDecls :: [Declaration] -> [[Declaration]]
orderDecls decls = map unSCC (stronglyConnComp nodes)
where
unSCC (AcyclicSCC x) = [x]
unSCC (CyclicSCC xs) = xs
--
nodes = map tuplify decls
tuplify d = (d, view declName d, toList (freeVariables d))

40
src/Bang/Syntax/Token.hs
View File

@@ -1,40 +0,0 @@
module Bang.Syntax.Token(
Token(..)
, Fixity(..)
, ppToken
)
where
import Bang.Utils.Pretty(BangDoc, text')
import Data.Monoid((<>))
import Data.Text.Lazy(Text)
import Text.PrettyPrint.Annotated(quotes, doubleQuotes, text, parens)
data Token = CharTok Text
| FloatTok Text
| IntTok Word Text
| OpIdent Fixity Text
| Special Text
| StringTok Text
| TypeIdent Text
| ValIdent Text
| ErrorTok Text
| EOFTok
deriving (Show)
data Fixity = LeftAssoc Word
| RightAssoc Word
| NonAssoc Word
deriving (Show)
ppToken :: Token -> BangDoc
ppToken (CharTok t) = quotes (text' t)
ppToken (FloatTok t) = text' t
ppToken (IntTok _ t) = text' t
ppToken (OpIdent _ t) = text' t
ppToken (Special t) = text' t
ppToken (StringTok t) = doubleQuotes (text' t)
ppToken (TypeIdent t) = text' t
ppToken (ValIdent t) = text' t
ppToken (ErrorTok t) = text "ERROR" <> parens (text' t)
ppToken EOFTok = text "<EOF>"

269
src/Bang/TypeInfer.hs
View File

@@ -1,269 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Bang.TypeInfer(runTypeInference)
where
import Bang.AST(Module, moduleDeclarations)
import Bang.AST.Declaration(Declaration(..), ValueDeclaration,
vdName, vdDeclaredType, vdValue,
tdName, tdType)
import Bang.AST.Expression(Expression(..), ConstantValue(..),
lambdaArgumentNames, lambdaBody,
constLocation, constValue, refName)
import Bang.AST.Name(Name, NameEnvironment(..),
nameLocation, nameText, ppName)
import Bang.AST.Type(Type(..), ppType, rtName, ftArgumentType,
ftResultType, taLeftType, taRightType,
mkPrimType, mkFunType, mkTypeRef,
Kind(..))
import Bang.Monad(Compiler, BangError(..), BangWarning(..),
registerNewName, err', err, warn,
getPassState, mapPassState, runPass)
import Bang.Syntax.Location(Location, fakeLocation)
import Bang.Utils.FreeVars(CanHaveFreeVars(..))
import Bang.Utils.Pretty(BangDoc, text')
import Control.Lens(view, over)
import Data.Map.Strict(Map)
import qualified Data.Map.Strict as Map
import Data.Set(Set, (\\))
import qualified Data.Set as Set
import Text.PrettyPrint.Annotated(text, nest, quotes, ($+$), (<+>))
runTypeInference :: Module -> Compiler ps Module
runTypeInference x =
do _ <- runPass emptyEnvironment (mapM_ typeInferDecls (view moduleDeclarations x))
return x
-- -----------------------------------------------------------------------------
type Infer a = Compiler TypeEnvironment a
getNamesTypeScheme :: Name -> Infer (Maybe Scheme)
getNamesTypeScheme n = Map.lookup n `fmap` getPassState
addToTypeEnvironment :: [Name] -> [Scheme] -> Infer ()
addToTypeEnvironment ns schms = mapPassState (add ns schms)
where
add :: [Name] -> [Scheme] -> TypeEnvironment -> TypeEnvironment
add [] [] acc = acc
add (n:restns) (s:rschms) acc =
Map.insertWithKey errorFn n s (add restns rschms acc)
add _ _ _ =
error "Wackiness has insued."
--
errorFn k _ _ = error ("Redefinition of " ++ show k)
-- -----------------------------------------------------------------------------
type Substitution = Map Name Type
nullSubstitution :: Substitution
nullSubstitution = Map.empty
composeSubstitutions :: Substitution -> Substitution -> Substitution
composeSubstitutions s1 s2 = Map.map (apply s1) s2 `Map.union` s1
class ApplySubst t where
apply :: Substitution -> t -> t
instance ApplySubst Type where
apply s (TypeUnit t) = TypeUnit t
apply s (TypePrim t) = TypePrim t
apply s (TypeRef t) = case Map.lookup (view rtName t) s of
Nothing -> TypeRef t
Just t' -> t'
apply s (TypeFun t) = TypeFun (over ftArgumentType (apply s) $
over ftResultType (apply s) t)
apply s (TypeApp t) = TypeApp (over taLeftType (apply s) $
over taRightType (apply s) t)
instance ApplySubst a => ApplySubst [a] where
apply s = map (apply s)
-- -----------------------------------------------------------------------------
data Scheme = Scheme [Name] Type
instance CanHaveFreeVars Scheme where
freeVariables (Scheme ns t) = freeVariables t \\ Set.fromList ns
instance ApplySubst Scheme where
apply s (Scheme vars t) = Scheme vars (apply s t)
newTypeVar :: Name -> Infer Type
newTypeVar n =
do let loc = view nameLocation n
n' <- registerNewName TypeEnv (view nameText n)
return (mkTypeRef loc Unknown n')
instantiate :: Scheme -> Infer Type
instantiate (Scheme vars t) =
do refs <- mapM newTypeVar vars
let newSubsts = Map.fromList (zip vars refs)
return (apply newSubsts t)
-- -----------------------------------------------------------------------------
mostGeneralUnifier :: Type -> Type -> Infer Substitution
mostGeneralUnifier a b =
case (a, b) of
(TypeUnit _, TypeUnit _) -> return nullSubstitution
(TypePrim _, TypePrim _) -> return nullSubstitution
(TypeRef t1, t2) -> varBind (view rtName t1) t2
(t2, TypeRef t1) -> varBind (view rtName t1) t2
(TypeFun t1, TypeFun t2) -> do let at1 = view ftArgumentType t1
at2 = view ftArgumentType t2
s1 <- mostGeneralUnifier at1 at2
let rt1 = apply s1 (view ftResultType t1)
rt2 = apply s1 (view ftResultType t2)
s2 <- mostGeneralUnifier rt1 rt2
return (s1 `composeSubstitutions` s2)
(TypeApp t1, TypeApp t2) -> do let lt1 = view taLeftType t1
lt2 = view taLeftType t2
s1 <- mostGeneralUnifier lt1 lt2
let rt1 = apply s1 (view taRightType t1)
rt2 = apply s1 (view taRightType t2)
s2 <- mostGeneralUnifier rt1 rt2
return (s1 `composeSubstitutions` s2)
_ -> do err' (TypesDontUnify a b)
return nullSubstitution
varBind :: Name -> Type -> Infer Substitution
varBind u t | TypeRef t' <- t,
view rtName t' == u = return nullSubstitution
| u `Set.member` freeVariables t = do err' (OccursFail u t)
return nullSubstitution
| otherwise = return (Map.singleton u t)
-- -----------------------------------------------------------------------------
type TypeEnvironment = Map Name Scheme
emptyEnvironment :: TypeEnvironment
emptyEnvironment = Map.empty
instance ApplySubst TypeEnvironment where
apply s tenv = Map.map (apply s) tenv
instance CanHaveFreeVars TypeEnvironment where
freeVariables tenv = freeVariables (Map.elems tenv)
generalize :: TypeEnvironment -> Type -> Scheme
generalize env t = Scheme vars t
where vars = Set.toList (freeVariables t \\ freeVariables env)
-- -----------------------------------------------------------------------------
data InferenceError = InternalError
| TypesDontUnify Type Type
| OccursFail Name Type
| UnboundVariable Name
instance BangError InferenceError where
ppError = prettyError
prettyError :: InferenceError -> (Maybe Location, BangDoc)
prettyError e =
case e of
InternalError ->
(Nothing, text "<internal error>")
TypesDontUnify t1 t2 ->
(Nothing, text "Types don't unify:" $+$
(nest 3
(text "first type: " <+> ppType t1 $+$
text "second type: " <+> ppType t2)))
OccursFail n t ->
(Just (view nameLocation n),
text "Occurs check failed:" $+$
(nest 3 (text "Type: " <+> ppType t)))
UnboundVariable n ->
(Just (view nameLocation n),
text "Unbound variable (in type checker?):" <+> ppName n)
data InferenceWarning = TopLevelWithoutType Name Type
| DeclarationMismatch Name Type Type
instance BangWarning InferenceWarning where
ppWarning = prettyWarning
prettyWarning :: InferenceWarning -> (Maybe Location, BangDoc)
prettyWarning w =
case w of
TopLevelWithoutType n t ->
(Just (view nameLocation n),
text "Variable" <+> quotes (text' (view nameText n)) <+>
text "is defined without a type." $+$
text "Inferred type:" $+$ nest 3 (ppType t))
DeclarationMismatch n dt it ->
(Just (view nameLocation n),
text "Mismatch between declared and inferred type of" <+>
quotes (text' (view nameText n)) $+$
nest 3 (text "declared type:" <+> ppType dt $+$
text "inferred type:" <+> ppType it))
-- -----------------------------------------------------------------------------
-- Infer the type of a group of declarations with cyclic dependencies.
typeInferDecls :: [Declaration] -> Infer ()
typeInferDecls decls =
do (names, schemes, decls') <- getInitialSchemes decls
addToTypeEnvironment names schemes
mapM_ typeInferDecl decls'
where
getInitialSchemes [] =
return ([], [], [])
getInitialSchemes ((DeclType td) : rest) =
do (rn, rs, rd) <- getInitialSchemes rest
let n = view tdName td
s = Scheme [] (view tdType td)
return (n:rn, s:rs, rd)
getInitialSchemes ((DeclVal td) : rest) =
do (rn, rs, rd) <- getInitialSchemes rest
return (rn, rs, (td : rd))
typeInferDecl :: ValueDeclaration -> Infer ()
typeInferDecl vd =
do (subs, t) <- typeInferExpr (view vdValue vd)
let t' = apply subs t
case view vdDeclaredType vd of
Nothing ->
warn (TopLevelWithoutType (view vdName vd) t')
Just dt ->
warn (DeclarationMismatch (view vdName vd) dt t)
typeInferConst :: Location -> ConstantValue ->
Infer (Substitution, Type)
typeInferConst l (ConstantInt _ _) =
return (nullSubstitution, mkPrimType l "i64")
typeInferConst l (ConstantChar _) =
return (nullSubstitution, mkPrimType l "i8") -- FIXME
typeInferConst l (ConstantString _) =
return (nullSubstitution, mkPrimType l "i8*") -- FIXME
typeInferConst l (ConstantFloat _) =
return (nullSubstitution, mkPrimType l "double")
typeInferExpr :: Expression -> Infer (Substitution, Type)
typeInferExpr expr =
case expr of
ConstExp e ->
typeInferConst (view constLocation e) (view constValue e)
RefExp e ->
do mscheme <- getNamesTypeScheme (view refName e)
case mscheme of
Nothing -> err (UnboundVariable (view refName e))
Just scheme -> do t <- instantiate scheme
return (nullSubstitution, t)
LambdaExp e ->
do let argNames = view lambdaArgumentNames e
tvars <- mapM newTypeVar argNames
let tvars' = map (Scheme []) tvars
addToTypeEnvironment argNames tvars'
(s1, t1) <- typeInferExpr (view lambdaBody e)
return (s1, mkFunType' (apply s1 tvars) t1)
where
mkFunType' [] t = t
mkFunType' (x:rest) t = mkFunType fakeLocation x (mkFunType' rest t)

20
src/Bang/Utils/FreeVars.hs
View File

@@ -1,20 +0,0 @@
module Bang.Utils.FreeVars(
CanHaveFreeVars(..)
)
where
import Bang.AST.Name(Name)
import Data.Set(Set)
import qualified Data.Set as Set
class CanHaveFreeVars a where
freeVariables :: a -> Set Name
instance CanHaveFreeVars a => CanHaveFreeVars (Maybe a) where
freeVariables (Just x) = freeVariables x
freeVariables Nothing = Set.empty
instance CanHaveFreeVars a => CanHaveFreeVars [a] where
freeVariables [] = Set.empty
freeVariables (x:xs) = freeVariables x `Set.union` freeVariables xs

9
src/Bang/Utils/PP.hs
View File

@@ -1,9 +0,0 @@
module Bang.Utils.PP(
PP(..)
)
where
import
class PP a where
ppr :: a -> Doc

20
src/Bang/Utils/Pretty.hs
View File

@@ -1,20 +0,0 @@
module Bang.Utils.Pretty(
BangDoc
, Annotation(..)
, text'
, word
)
where
import Data.Text.Lazy(Text, unpack)
import Text.PrettyPrint.Annotated(Doc, text, integer)
type BangDoc = Doc Annotation
data Annotation = KeywordAnnotation
text' :: Text -> Doc a
text' = text . unpack
word :: Word -> Doc a
word = integer . fromIntegral

22
src/Main.hs
View File

@@ -1,22 +0,0 @@
import Bang.CommandLine(getCommand, BangCommand(..), helpString)
import Bang.AST(ppModule)
import Bang.Monad(runCompiler)
import Bang.Syntax.Parser(runParser, parseModule)
import Bang.Syntax.PostProcess(runPostProcessor)
import Bang.TypeInfer(runTypeInference)
import Data.Version(showVersion)
import Paths_bang(version)
import Text.PrettyPrint.Annotated(render)
main :: IO ()
main = getCommand >>= \ cmd ->
case cmd of
Parse o -> do mdl <- runCompiler cmd o (\ r t -> runParser r t parseModule)
putStrLn (render (ppModule mdl))
TypeCheck o -> do mdl <- runCompiler cmd o (\ r t ->
do mdl <- runParser r t parseModule
mdl' <- runPostProcessor mdl
runTypeInference mdl')
putStrLn (render (ppModule mdl))
Help -> putStrLn helpString
Version -> putStrLn ("Bang tool, version " ++ showVersion version)

1
src/bin/bangc.rs Normal file
View File

@@ -0,0 +1 @@
fn main() {}

1
src/lib.rs Normal file
View File

@@ -0,0 +1 @@
pub mod syntax;

17
src/syntax.rs Normal file
View File

@@ -0,0 +1,17 @@
mod arbitrary;
mod ast;
mod error;
mod location;
mod name;
mod parse;
#[cfg(test)]
mod parser_tests;
mod print;
mod tokens;
mod universe;
pub use crate::syntax::error::ParserError;
pub use ast::*;
pub use location::{Located, Location};
pub use name::Name;
pub use universe::*;

548
src/syntax/arbitrary.rs Normal file
View File

@@ -0,0 +1,548 @@
use std::fmt::Arguments;
use crate::syntax::ast::{ConstantValue, IntegerWithBase, Type};
use crate::syntax::location::Location;
use crate::syntax::name::Name;
use itertools::Itertools;
use proptest::arbitrary::Arbitrary;
use proptest::prelude::{BoxedStrategy, Rng};
use proptest::prop_oneof;
use proptest::strategy::{NewTree, Strategy, ValueTree};
use proptest::test_runner::TestRunner;
const MAXIMUM_TYPE_DEPTH: usize = 5;
const MAXIMUM_TYPE_WIDTH: usize = 5;
const MAXIMUM_STRING_SIZE: usize = 32;
const PRIMITIVE_TYPES: &[&str] = &[
"Char", "String", "I8", "I16", "I32", "I64", "U8", "U16", "U32", "U64",
];
#[derive(Debug, Default)]
pub struct TypeGenerationContext {
available_constructors: Vec<Name>,
available_variables: Vec<Name>,
}
impl TypeGenerationContext {
fn generate_type(&mut self, runner: &mut TestRunner, depth: usize) -> Type {
let mut leaf_options = vec![];
if !self.available_constructors.is_empty() {
for name in self.available_constructors.iter() {
leaf_options.push(Type::Constructor(
Location::manufactured(),
name.clone(),
));
}
}
if !self.available_variables.is_empty() {
for name in self.available_variables.iter() {
leaf_options.push(Type::Variable(
Location::manufactured(),
name.clone(),
));
}
}
for prim in PRIMITIVE_TYPES.iter() {
leaf_options.push(Type::Primitive(
Location::manufactured(),
Name::new(Location::manufactured(), prim.to_string()),
));
}
if depth < MAXIMUM_TYPE_DEPTH && runner.rng().random_bool(0.5) {
}
let index = runner.rng().random_range(0..leaf_options.len());
leaf_options.remove(index)
}
}
#[derive(Clone)]
pub struct TypeGenerationTree {
current_value: Type,
parent: Option<Box<TypeGenerationTree>>,
untried_simplified_items: Option<Vec<TypeGenerationTree>>,
}
impl TypeGenerationTree {
/// Create a new type generation tree based on the given
/// initial value.
pub fn new(initial_value: Type) -> TypeGenerationTree {
TypeGenerationTree {
current_value: initial_value,
parent: None,
untried_simplified_items: None,
}
}
}
fn generate_powerset(_: &[Type]) -> Vec<Vec<Type>> {
vec![]
}
fn simplify_type(incoming: &Type) -> Vec<Type> {
match incoming {
Type::Primitive(_, _) => vec![],
Type::Constructor(_, _) => vec![],
Type::Variable(_, _) => vec![],
Type::Function(arg_types, ret_type) => {
let simplified_return_types = simplify_type(ret_type.as_ref());
// we do the following as a set of steps, choosing to go deep rather than
// broad immediately. So this works as follows:
//
// 1. If there are simplifications for the return type, then just
// return variations with the simplified return type.
// 2. If there are simplifications for the first argument, then
// just return variations with the first argument simplified.
// 3. Repeat for each of the arguments.
// 4. At this point, all the subtypes are as simple as they can
// be, so return a series of function types with fewer arguments.
// 5. If we are a function with no arguments, then just return
// the return type.
if !simplified_return_types.is_empty() {
return simplified_return_types
.into_iter()
.map(|ret| Type::Function(arg_types.clone(), Box::new(ret)))
.collect();
}
// now check the arguments, and see if we can simplify them in a
// better way.
for idx in 0..arg_types.len() {
let simplified_arguments = simplify_type(&arg_types[idx]);
if simplified_arguments.is_empty() {
continue;
}
let mut new_function_types = vec![];
for simplified_arg in simplified_arguments.into_iter() {
let mut new_args = vec![];
for item in &arg_types[0..idx] {
new_args.push(item.clone());
}
new_args.push(simplified_arg);
for item in &arg_types[idx + 1..arg_types.len()] {
new_args.push(item.clone());
}
new_function_types.push(Type::Function(new_args, ret_type.clone()));
}
if !new_function_types.is_empty() {
return new_function_types;
}
}
// ok, all of the arguments and the return type are already as
// simple as they can be, so let's see if we can reduce the number
// of arguments.
let mut new_types = vec![];
for args in arg_types.iter().powerset() {
if args.len() != arg_types.len() {
new_types.push(Type::Function(
args.into_iter().cloned().collect(),
ret_type.clone(),
));
}
}
if new_types.is_empty() {
vec![ret_type.as_ref().clone()]
} else {
new_types
}
}
Type::Application(constructor_type, arg_types) => {
// much like functions, we're going to try to simplify the constructor,
// then we'll try to simplify the arguments, then we'll try to remove
// arguments.
let simplified_constructor = simplify_type(constructor_type.as_ref());
if !simplified_constructor.is_empty() {
return simplified_constructor
.into_iter()
.map(|c| Type::Application(Box::new(c), arg_types.clone()))
.collect();
}
// now check the arguments, and see if we can simplify them in a
// better way.
for idx in 0..arg_types.len() {
let simplified_arguments = simplify_type(&arg_types[idx]);
if simplified_arguments.is_empty() {
continue;
}
let mut new_appl_types = vec![];
for simplified_arg in simplified_arguments.into_iter() {
let mut new_args = vec![];
for item in &arg_types[0..idx] {
new_args.push(item.clone());
}
new_args.push(simplified_arg);
for item in &arg_types[idx + 1..arg_types.len()] {
new_args.push(item.clone());
}
new_appl_types.push(Type::Application(constructor_type.clone(), new_args));
}
if !new_appl_types.is_empty() {
return new_appl_types;
}
}
// and now we'll try to reduce types.
let mut new_types = vec![];
for args in arg_types.iter().powerset() {
if args.len() != arg_types.len() {
new_types.push(Type::Application(
constructor_type.clone(),
args.into_iter().cloned().collect(),
));
}
}
if new_types.is_empty() {
vec![constructor_type.as_ref().clone()]
} else {
new_types
}
}
}
}
impl ValueTree for TypeGenerationTree {
type Value = Type;
fn current(&self) -> Self::Value {
self.current_value.clone()
}
fn simplify(&mut self) -> bool {
match self.untried_simplified_items.as_mut() {
None => {
let mut simplified = simplify_type(&self.current_value)
.into_iter()
.map(|current_value| TypeGenerationTree {
current_value,
parent: Some(Box::new(self.clone())),
untried_simplified_items: None,
})
.collect::<Vec<_>>();
match simplified.pop() {
None => {
self.untried_simplified_items = Some(simplified);
false
}
Some(next_tree) => {
self.untried_simplified_items = Some(simplified);
*self = next_tree;
true
}
}
}
Some(untried_simplifieds) => match untried_simplifieds.pop() {
None => false,
Some(x) => {
*self = x;
true
}
},
}
}
fn complicate(&mut self) -> bool {
match self.parent.take() {
None => false,
Some(x) => {
*self = *x;
true
}
}
}
}
impl Strategy for TypeGenerationContext {
type Tree = TypeGenerationTree;
type Value = Type;
fn new_tree(&self, _runner: &mut TestRunner) -> NewTree<Self> {
unimplemented!()
}
}
impl Arbitrary for Type {
type Parameters = TypeGenerationContext;
type Strategy = TypeGenerationContext;
fn arbitrary_with(_context: Self::Parameters) -> Self::Strategy {
unimplemented!()
}
}
#[derive(Default)]
pub enum LegalConstantType {
#[default]
Any,
String,
Char,
Number,
}
impl Arbitrary for ConstantValue {
type Parameters = LegalConstantType;
type Strategy = BoxedStrategy<ConstantValue>;
fn arbitrary_with(args: Self::Parameters) -> Self::Strategy {
match args {
LegalConstantType::Char => char::arbitrary()
.prop_map(|x| ConstantValue::Character(Location::manufactured(), x))
.boxed(),
LegalConstantType::String => {
proptest::collection::vec(proptest::char::any(), MAXIMUM_STRING_SIZE)
.prop_map(|x| {
ConstantValue::String(Location::manufactured(), String::from_iter(x))
})
.boxed()
}
LegalConstantType::Number => {
let value_strat = u64::arbitrary();
let base_strat = proptest::prop_oneof![
proptest::strategy::Just(None),
proptest::strategy::Just(Some(2)),
proptest::strategy::Just(Some(8)),
proptest::strategy::Just(Some(10)),
proptest::strategy::Just(Some(16)),
];
(value_strat, base_strat)
.prop_map(|(value, base)| {
ConstantValue::Integer(
Location::manufactured(),
IntegerWithBase { base, value },
)
})
.boxed()
}
LegalConstantType::Any => proptest::prop_oneof![
Self::arbitrary_with(LegalConstantType::Char),
Self::arbitrary_with(LegalConstantType::String),
Self::arbitrary_with(LegalConstantType::Number),
]
.boxed(),
}
}
}
#[cfg(test)]
mod simplifiers {
use super::*;
#[test]
fn types() {
let loc = Location::manufactured();
let foo = Name::new(loc.clone(), "Foo");
let primint = Type::Primitive(loc.clone(), Name::new(loc.clone(), "Int"));
let primchar = Type::Primitive(loc.clone(), Name::new(loc.clone(), "Char"));
let primstr = Type::Primitive(loc.clone(), Name::new(loc.clone(), "String"));
assert_eq!(
simplify_type(&Type::Constructor(loc.clone(), foo.clone())),
vec![]
);
assert_eq!(
simplify_type(&Type::Variable(loc.clone(), foo.clone())),
vec![]
);
assert_eq!(
simplify_type(&Type::Primitive(loc.clone(), foo.clone())),
vec![]
);
assert_eq!(
simplify_type(&Type::Function(vec![], Box::new(primint.clone()))),
vec![primint.clone()]
);
assert_eq!(
simplify_type(&Type::Function(
vec![primint.clone(), primchar.clone()],
Box::new(primint.clone())
)),
vec![
Type::Function(vec![], Box::new(primint.clone())),
Type::Function(vec![primint.clone()], Box::new(primint.clone())),
Type::Function(vec![primchar.clone()], Box::new(primint.clone())),
]
);
assert_eq!(
simplify_type(&Type::Function(
vec![primint.clone(), primchar.clone(), primstr.clone()],
Box::new(primint.clone())
)),
vec![
Type::Function(vec![], Box::new(primint.clone())),
Type::Function(vec![primint.clone()], Box::new(primint.clone())),
Type::Function(vec![primchar.clone()], Box::new(primint.clone())),
Type::Function(vec![primstr.clone()], Box::new(primint.clone())),
Type::Function(
vec![primint.clone(), primchar.clone()],
Box::new(primint.clone())
),
Type::Function(
vec![primint.clone(), primstr.clone()],
Box::new(primint.clone())
),
Type::Function(
vec![primchar.clone(), primstr.clone()],
Box::new(primint.clone())
),
]
);
assert_eq!(
simplify_type(&Type::Function(
vec![primint.clone(), primchar.clone(), primstr.clone()],
Box::new(Type::Function(vec![], Box::new(primint.clone()))),
)),
vec![Type::Function(
vec![primint.clone(), primchar.clone(), primstr.clone()],
Box::new(primint.clone())
),]
);
assert_eq!(
simplify_type(&Type::Function(
vec![primint.clone(), primchar.clone(), primstr.clone()],
Box::new(Type::Function(
vec![primint.clone(), primchar.clone()],
Box::new(primint.clone())
)),
)),
vec![
Type::Function(
vec![primint.clone(), primchar.clone(), primstr.clone()],
Box::new(Type::Function(vec![], Box::new(primint.clone())))
),
Type::Function(
vec![primint.clone(), primchar.clone(), primstr.clone()],
Box::new(Type::Function(
vec![primint.clone()],
Box::new(primint.clone())
))
),
Type::Function(
vec![primint.clone(), primchar.clone(), primstr.clone()],
Box::new(Type::Function(
vec![primchar.clone()],
Box::new(primint.clone())
))
),
]
);
assert_eq!(
simplify_type(&Type::Function(
vec![
Type::Function(vec![], Box::new(primint.clone())),
primstr.clone()
],
Box::new(primint.clone())
)),
vec![Type::Function(
vec![primint.clone(), primstr.clone()],
Box::new(primint.clone())
)]
);
assert_eq!(
simplify_type(&Type::Function(
vec![
primint.clone(),
Type::Function(vec![], Box::new(primint.clone()))
],
Box::new(primint.clone())
)),
vec![Type::Function(
vec![primint.clone(), primint.clone()],
Box::new(primint.clone())
)]
);
let applied = Type::Application(Box::new(primint.clone()), vec![]);
assert_eq!(
simplify_type(&Type::Application(Box::new(primint.clone()), vec![])),
vec![primint.clone()]
);
assert_eq!(simplify_type(&applied), vec![primint.clone()]);
assert_eq!(
simplify_type(&Type::Application(
Box::new(applied.clone()),
vec![primint.clone()]
)),
vec![Type::Application(
Box::new(primint.clone()),
vec![primint.clone()]
)]
);
assert_eq!(
simplify_type(&Type::Application(
Box::new(primint.clone()),
vec![applied.clone()]
)),
vec![Type::Application(
Box::new(primint.clone()),
vec![primint.clone()]
)]
);
assert_eq!(
simplify_type(&Type::Application(
Box::new(primint.clone()),
vec![primchar.clone(), applied.clone(), primstr.clone()]
)),
vec![Type::Application(
Box::new(primint.clone()),
vec![primchar.clone(), primint.clone(), primstr.clone()]
)]
);
assert_eq!(
simplify_type(&Type::Application(
Box::new(primint.clone()),
vec![primchar.clone(), primint.clone(), primstr.clone()]
)),
vec![
Type::Application(Box::new(primint.clone()), vec![]),
Type::Application(Box::new(primint.clone()), vec![primchar.clone()]),
Type::Application(Box::new(primint.clone()), vec![primint.clone()]),
Type::Application(Box::new(primint.clone()), vec![primstr.clone()]),
Type::Application(
Box::new(primint.clone()),
vec![primchar.clone(), primint.clone()]
),
Type::Application(
Box::new(primint.clone()),
vec![primchar.clone(), primstr.clone()]
),
Type::Application(
Box::new(primint.clone()),
vec![primint.clone(), primstr.clone()]
)
]
);
}
}

336
src/syntax/ast.rs Normal file
View File

@@ -0,0 +1,336 @@
use crate::syntax::location::{Located, Location};
use crate::syntax::name::Name;
use proptest_derive::Arbitrary;
#[derive(Debug)]
pub struct Module {
pub definitions: Vec<Definition>,
}
#[derive(Debug)]
pub struct Definition {
pub location: Location,
pub export: ExportClass,
pub type_restrictions: TypeRestrictions,
pub definition: Def,
}
impl Located for Definition {
fn location(&self) -> Location {
self.location.clone()
}
}
#[derive(Debug)]
pub enum Def {
Enumeration(EnumerationDef),
Structure(StructureDef),
Function(FunctionDef),
Value(ValueDef),
Operator(OperatorDef),
}
impl Located for Def {
fn location(&self) -> Location {
match self {
Def::Enumeration(def) => def.location.clone(),
Def::Structure(def) => def.location.clone(),
Def::Function(def) => def.location.clone(),
Def::Value(def) => def.location.clone(),
Def::Operator(def) => def.location.clone(),
}
}
}
#[derive(Debug)]
pub struct EnumerationDef {
pub name: Name,
pub location: Location,
pub variants: Vec<EnumerationVariant>,
}
#[derive(Debug)]
pub struct EnumerationVariant {
pub location: Location,
pub name: Name,
pub argument: Option<Type>,
}
#[derive(Debug)]
pub struct StructureDef {
pub name: Name,
pub location: Location,
pub fields: Vec<StructureField>,
}
#[derive(Debug)]
pub struct StructureField {
pub location: Location,
pub export: ExportClass,
pub name: Name,
pub field_type: Option<Type>,
}
#[derive(Debug)]
pub struct FunctionDef {
pub name: Name,
pub location: Location,
pub arguments: Vec<FunctionArg>,
pub return_type: Option<Type>,
pub body: Vec<Statement>,
}
#[derive(Debug)]
pub struct FunctionArg {
pub name: Name,
pub arg_type: Option<Type>,
}
#[derive(Debug)]
pub struct ValueDef {
pub name: Name,
pub location: Location,
pub mtype: Option<Type>,
pub value: Expression,
}
#[derive(Debug)]
pub struct OperatorDef {
pub operator_name: Name,
pub location: Location,
pub function_name: Name,
}
#[derive(Debug)]
pub enum ExportClass {
Public,
Private,
}
#[derive(Debug)]
pub enum Statement {
Binding(BindingStmt),
Expression(Expression),
}
#[derive(Debug)]
pub struct BindingStmt {
pub location: Location,
pub mutable: bool,
pub variable: Name,
pub value: Expression,
}
#[derive(Debug)]
pub enum Expression {
Value(ConstantValue),
Reference(Location, Name),
Enumeration(EnumerationExpr),
Structure(StructureExpr),
Conditional(ConditionalExpr),
Match(MatchExpr),
Call(Box<Expression>, CallKind, Vec<Expression>),
Block(Location, Vec<Statement>),
}
impl Located for Expression {
fn location(&self) -> Location {
match self {
Expression::Value(c) => c.location(),
Expression::Reference(l, _) => l.clone(),
Expression::Enumeration(ev) => ev.location.clone(),
Expression::Structure(sv) => sv.location.clone(),
Expression::Conditional(ce) => ce.location.clone(),
Expression::Match(me) => me.location.clone(),
Expression::Call(_, _, _) => unimplemented!(),
Expression::Block(l, _) => l.clone(),
}
}
}
#[derive(Debug)]
pub struct EnumerationExpr {
pub location: Location,
pub type_name: Name,
pub variant_name: Name,
pub argument: Option<Box<Expression>>,
}
#[derive(Debug)]
pub struct StructureExpr {
pub location: Location,
pub type_name: Name,
pub fields: Vec<FieldValue>,
}
#[derive(Debug)]
pub struct ConditionalExpr {
pub location: Location,
pub test: Box<Expression>,
pub consequent: Box<Expression>,
pub alternative: Option<Box<Expression>>,
}
#[derive(Debug)]
pub struct MatchExpr {
pub location: Location,
pub value: Box<Expression>,
pub cases: Vec<MatchCase>,
}
#[derive(Debug)]
pub struct MatchCase {
pub pattern: Pattern,
pub consequent: Expression,
}
#[derive(Debug)]
pub enum Pattern {
Constant(ConstantValue),
Variable(Name),
EnumerationValue(EnumerationPattern),
Structure(StructurePattern),
}
#[derive(Debug)]
pub struct EnumerationPattern {
pub location: Location,
pub type_name: Name,
pub variant_name: Name,
pub argument: Option<Box<Pattern>>,
}
#[derive(Debug)]
pub struct StructurePattern {
pub location: Location,
pub type_name: Name,
pub fields: Vec<(Name, Option<Pattern>)>,
}
#[derive(Debug)]
pub enum CallKind {
Infix,
Normal,
Postfix,
Prefix,
}
#[derive(Debug)]
pub struct FieldValue {
pub field: Name,
pub value: Expression,
}
#[derive(Debug)]
pub struct TypeRestrictions {
pub restrictions: Vec<TypeRestriction>,
}
impl TypeRestrictions {
pub fn empty() -> Self {
TypeRestrictions {
restrictions: vec![],
}
}
pub fn is_empty(&self) -> bool {
self.restrictions.is_empty()
}
}
#[derive(Debug)]
pub struct TypeRestriction {
pub constructor: Type,
pub arguments: Vec<Type>,
}
#[derive(Clone, Debug)]
pub enum Type {
Constructor(Location, Name),
Variable(Location, Name),
Primitive(Location, Name),
Application(Box<Type>, Vec<Type>),
Function(Vec<Type>, Box<Type>),
}
impl PartialEq for Type {
fn eq(&self, other: &Self) -> bool {
match self {
Type::Constructor(_, x) => matches!(other, Type::Constructor(_, y) if x == y),
Type::Variable(_, x) => matches!(other, Type::Variable(_, y) if x == y),
Type::Primitive(_, x) => matches!(other, Type::Primitive(_, y) if x == y),
Type::Application(con1, args1) => {
matches!(other, Type::Application(con2, args2) if con1 == con2 && args1 == args2)
}
Type::Function(args1, ret1) => {
matches!(other, Type::Function(args2, ret2) if args1 == args2 && ret1 == ret2)
}
}
}
}
impl Located for Type {
fn location(&self) -> Location {
match self {
Type::Constructor(l, _) => l.clone(),
Type::Variable(l, _) => l.clone(),
Type::Primitive(l, _) => l.clone(),
Type::Application(t1, ts) => {
let mut result = t1.location();
if let Some(last) = ts.last() {
result = result.extend_to(&last.location());
}
result
}
Type::Function(args, ret) => {
if let Some(first) = args.first() {
first.location().extend_to(&ret.location())
} else {
ret.location()
}
}
}
}
}
#[derive(Clone, Debug)]
pub enum ConstantValue {
Integer(Location, IntegerWithBase),
Character(Location, char),
String(Location, String),
}
impl Located for ConstantValue {
fn location(&self) -> Location {
match self {
ConstantValue::Integer(l, _) => l.clone(),
ConstantValue::Character(l, _) => l.clone(),
ConstantValue::String(l, _) => l.clone(),
}
}
}
impl PartialEq for ConstantValue {
fn eq(&self, other: &Self) -> bool {
match self {
ConstantValue::Character(_, x) => {
matches!(other, ConstantValue::Character(_, y) if x == y)
}
ConstantValue::String(_, x) => matches!(other, ConstantValue::String(_, y) if x == y),
ConstantValue::Integer(_, x) => matches!(other, ConstantValue::Integer(_, y) if x == y),
}
}
}
#[derive(Clone, Debug, PartialEq, Eq, Arbitrary)]
pub struct IntegerWithBase {
#[proptest(strategy = "proptest::prop_oneof![ \
proptest::strategy::Just(None), \
proptest::strategy::Just(Some(2)), \
proptest::strategy::Just(Some(8)), \
proptest::strategy::Just(Some(10)), \
proptest::strategy::Just(Some(16)), \
]")]
pub base: Option<u8>,
pub value: u64,
}

147
src/syntax/error.rs Normal file
View File

@@ -0,0 +1,147 @@
//use codespan_reporting::diagnostic::{Diagnostic, Label};
use crate::syntax::tokens::Token;
use internment::ArcIntern;
use std::ops::Range;
use std::path::PathBuf;
use thiserror::Error;
#[derive(Debug, Error)]
pub enum ParserError {
#[error("Lexer error at {file}: {error}")]
LexerError {
file: ArcIntern<PathBuf>,
error: LexerError,
},
#[error("Unacceptable end of file at {file} while {place}")]
UnacceptableEof {
file: ArcIntern<PathBuf>,
place: String,
},
#[error("Unexpected token at {file}: expected {expected}, saw {token}")]
UnexpectedToken {
file: ArcIntern<PathBuf>,
span: Range<usize>,
token: Token,
expected: String,
},
#[error("Unexpected problem opening file {file}: {error}")]
OpenError { file: String, error: std::io::Error },
#[error("Unexpected problem reading file {file}: {error}")]
ReadError { file: String, error: std::io::Error },
#[error("UTF-8 problem reading file {file}: {error}")]
Utf8Error {
file: String,
error: std::str::Utf8Error,
},
}
#[derive(Clone, Debug, Error, PartialEq)]
pub enum LexerError {
#[error("Illegal control character in input stream at offset {offset}")]
IllegalControlCharacter { offset: usize },
#[error("Illegal primitive value/type; it cut off before we could determine which at {span:?}")]
IllegalPrimitive { span: Range<usize> },
#[error("Illegal character in primitive ({char:?}) at {span:?}")]
IllegalPrimitiveCharacter { span: Range<usize>, char: char },
#[error("Unfinished character constant found at {span:?}")]
UnfinishedCharacter { span: Range<usize> },
#[error("Unfinished string constant found at {span:?}")]
UnfinishedString { span: Range<usize> },
#[error("Character {char:?} has some extra bits at the end at {span:?}")]
OverlongCharacter { char: char, span: Range<usize> },
#[error("Unknown escaped character {escaped_char:?} at {span:?}")]
UnknownEscapeCharacter {
escaped_char: char,
span: Range<usize>,
},
#[error("Invalid unicode escape sequence at {span:?}")]
InvalidUnicode { span: Range<usize> },
}
impl LexerError {
pub fn to_triple(&self) -> (usize, Result<Token, LexerError>, usize) {
match self {
LexerError::IllegalControlCharacter { offset } => (*offset, Err(self.clone()), *offset),
LexerError::IllegalPrimitive { span } => (span.start, Err(self.clone()), span.end),
LexerError::IllegalPrimitiveCharacter { span, .. } => {
(span.start, Err(self.clone()), span.end)
}
LexerError::UnfinishedCharacter { span, .. } => {
(span.start, Err(self.clone()), span.end)
}
LexerError::UnfinishedString { span, .. } => (span.start, Err(self.clone()), span.end),
LexerError::OverlongCharacter { span, .. } => (span.start, Err(self.clone()), span.end),
LexerError::UnknownEscapeCharacter { span, .. } => {
(span.start, Err(self.clone()), span.end)
}
LexerError::InvalidUnicode { span, .. } => (span.start, Err(self.clone()), span.end),
}
}
}
//impl<F> From<LexerError> for Diagnostic<F> {
// fn from(value: LexerError) -> Self {
// match value {
// LexerError::IllegalControlCharacter { file, offset } => Diagnostic::error()
// .with_code("E1001")
// .with_message("Illegal control character in input stream")
// .with_label(Label::primary(file, offset..offset).with_message("illegal character")),
//
// LexerError::IllegalPrimitive { file, span } => Diagnostic::error()
// .with_code("E1002")
// .with_message("Illegal primitive; it cut off before it could finish")
// .with_label(
// Label::primary(file, span)
// .with_message("should be at least one character after the %"),
// ),
//
// LexerError::IllegalPrimitiveCharacter { file, span, char } => Diagnostic::error()
// .with_code("E1003")
// .with_message(format!("Illegal character {char:?} in primitive"))
// .with_label(Label::primary(file, span).with_message("illegal character")),
//
// LexerError::UnfinishedCharacter { file, span } => Diagnostic::error()
// .with_code("E1004")
// .with_message("Unfinished character in input stream.")
// .with_label(Label::primary(file, span).with_message("unfinished character")),
//
// LexerError::UnfinishedString { file, span } => Diagnostic::error()
// .with_code("E1005")
// .with_message("Unfinished string in input stream.")
// .with_label(Label::primary(file, span).with_message("unfinished string")),
//
// LexerError::OverlongCharacter { file, char, span } => Diagnostic::error()
// .with_code("E1006")
// .with_message(format!(
// "Character {char:?} has some extra bits at the end of it."
// ))
// .with_label(Label::primary(file, span).with_message("overlong character")),
//
// LexerError::UnknownEscapeCharacter {
// file,
// escaped_char,
// span,
// } => Diagnostic::error()
// .with_code("E1007")
// .with_message(format!("Unknown escape character {escaped_char:?}."))
// .with_label(Label::primary(file, span).with_message("unknown character")),
//
// LexerError::InvalidUnicode { file, span } => Diagnostic::error()
// .with_code("E1008")
// .with_message("Unknown or invalid unicode escape sequence.")
// .with_label(Label::primary(file, span).with_message("escape sequence")),
// }
// }
//}

79
src/syntax/location.rs Normal file
View File

@@ -0,0 +1,79 @@
use ariadne::Span;
use internment::ArcIntern;
use std::cmp::{max, min};
use std::ops::Range;
use std::path::PathBuf;
pub trait Located {
fn location(&self) -> Location;
}
#[derive(Clone, Debug, Eq, PartialEq)]
pub struct Location {
file: ArcIntern<PathBuf>,
span: Range<usize>,
}
impl Span for Location {
type SourceId = ArcIntern<PathBuf>;
fn source(&self) -> &Self::SourceId {
&self.file
}
fn start(&self) -> usize {
self.span.start
}
fn end(&self) -> usize {
self.span.end
}
}
impl Location {
pub fn new(file: &ArcIntern<PathBuf>, span: Range<usize>) -> Self {
Location {
file: file.clone(),
span,
}
}
pub fn manufactured() -> Self {
Location {
file: ArcIntern::new("<manufactured>".into()),
span: 0..0,
}
}
pub fn extend_to(&self, other: &Location) -> Location {
assert_eq!(self.file, other.file);
Location {
file: self.file.clone(),
span: min(self.span.start, other.span.start)..max(self.span.end, other.span.end),
}
}
pub fn merge_span(mut self, span: Range<usize>) -> Location {
self.span = min(self.span.start, span.start)..max(self.span.end, span.end);
self
}
}
#[test]
fn extension_and_merge() {
let file = ArcIntern::new("/foo/bar.txt".into());
let loc1 = Location::new(&file, 1..4);
let loc2 = Location::new(&file, 4..8);
assert_eq!(loc1.extend_to(&loc2).source(), &file);
assert_eq!(loc1.extend_to(&loc2).start(), 1);
assert_eq!(loc1.extend_to(&loc2).end(), 8);
let loc3 = Location::new(&file, 12..16);
assert_eq!(loc1.extend_to(&loc3).source(), &file);
assert_eq!(loc1.extend_to(&loc3).start(), 1);
assert_eq!(loc1.extend_to(&loc3).end(), 16);
assert_eq!(loc1.clone().merge_span(0..1).start(), 0);
assert_eq!(loc1.merge_span(0..1).end(), 4);
}

156
src/syntax/name.rs Normal file
View File

@@ -0,0 +1,156 @@
use crate::syntax::Location;
#[cfg(test)]
use internment::ArcIntern;
use std::cmp;
use std::fmt;
use std::hash::{Hash, Hasher};
use std::sync::atomic::{AtomicU64, Ordering};
static IDENTIFIER_COUNTER: AtomicU64 = AtomicU64::new(0);
#[derive(Clone, Debug)]
pub struct Name {
printable: String,
identifier: u64,
location: Option<Location>,
}
impl cmp::PartialEq for Name {
fn eq(&self, other: &Self) -> bool {
self.identifier == other.identifier
}
}
impl cmp::Eq for Name {}
impl Hash for Name {
fn hash<H: Hasher>(&self, state: &mut H) {
self.identifier.hash(state);
}
}
impl fmt::Display for Name {
fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
write!(f, "{}:{}", self.printable, self.identifier)
}
}
impl Name {
pub fn new<S: ToString>(location: Location, s: S) -> Name {
let my_id = IDENTIFIER_COUNTER.fetch_add(1, Ordering::SeqCst);
Name {
printable: s.to_string(),
identifier: my_id,
location: Some(location),
}
}
pub fn gensym(base: &'static str) -> Name {
let formatted = format!("<{base}>");
let my_id = IDENTIFIER_COUNTER.fetch_add(1, Ordering::SeqCst);
Name {
printable: formatted,
identifier: my_id,
location: None,
}
}
pub fn as_printed(&self) -> &str {
self.printable.as_str()
}
pub fn bind_to(&mut self, other: &Name) {
self.identifier = other.identifier;
}
pub fn location(&self) -> Option<&Location> {
self.location.as_ref()
}
}
#[test]
fn equality() {
let file = ArcIntern::new("/foo.bang".into());
let loc1 = Location::new(&file, 0..3);
let loc2 = Location::new(&file, 9..12);
assert_ne!(Name::gensym("x"), Name::gensym("x"));
assert_ne!(Name::new(loc1.clone(), "x"), Name::new(loc1.clone(), "x"));
assert_eq!(
Name {
printable: "x".into(),
identifier: 5,
location: Some(loc1.clone())
},
Name {
printable: "x".into(),
identifier: 5,
location: Some(loc2.clone())
}
);
assert_eq!(
Name {
printable: "x".into(),
identifier: 5,
location: Some(loc1.clone())
},
Name {
printable: "x".into(),
identifier: 5,
location: None
}
);
assert_eq!(
Name {
printable: "x".into(),
identifier: 5,
location: Some(loc1.clone())
},
Name {
printable: "y".into(),
identifier: 5,
location: None
}
);
}
#[test]
fn hashing() {
let file = ArcIntern::new("/foo.bang".into());
let loc1 = Location::new(&file, 0..3);
let loc2 = Location::new(&file, 9..12);
let x1 = Name {
printable: "x".into(),
identifier: 1,
location: Some(loc1),
};
let mut x2 = Name {
printable: "x".into(),
identifier: 2,
location: Some(loc2),
};
let y1 = Name {
printable: "y".into(),
identifier: 1,
location: None,
};
let run_hash = |name: &Name| {
let mut hash = std::hash::DefaultHasher::new();
name.hash(&mut hash);
hash.finish()
};
let hash_x1 = run_hash(&x1);
let hash_x2 = run_hash(&x2);
let hash_y1 = run_hash(&y1);
assert_ne!(hash_x1, hash_x2);
assert_eq!(hash_x1, hash_y1);
x2.bind_to(&x1);
let rehashed_x2 = run_hash(&x2);
assert_eq!(hash_x1, rehashed_x2);
}

1785
src/syntax/parse.rs Normal file
View File

File diff suppressed because it is too large Load Diff

70
src/syntax/parser.lalrpop Normal file
View File

@@ -0,0 +1,70 @@
use crate::syntax::*;
use crate::syntax::error::ParserError;
use crate::syntax::tokens::*;
grammar(file_id: usize);
extern {
type Location = usize;
type Error = ParserError;
enum Token {
"(" => Token::OpenParen,
")" => Token::CloseParen,
"[" => Token::OpenSquare,
"]" => Token::CloseSquare,
"{" => Token::OpenBrace,
"}" => Token::CloseBrace,
";" => Token::Semi,
":" => Token::Colon,
"," => Token::Comma,
"`" => Token::BackTick,
"\\" => Token::Lambda(_),
"->" => Token::Arrow,
"<constructor>" => Token::TypeName(<String>),
"<value>" => Token::ValueName(<String>),
"<op>" => Token::OperatorName(<String>),
"<prim_constructor>" => Token::PrimitiveTypeName(<String>),
"<prim_value>" => Token::PrimitiveValueName(<String>),
"<integer>" => Token::Integer(<IntegerWithBase>),
"<char>" => Token::Character(<char>),
"<string>" => Token::String(<String>),
}
}
pub Type: Type = {
FunctionType,
}
FunctionType: Type = {
TypeApplication,
<argtype:FunctionType> "->" <ret:TypeApplication> =>
Type::Function(Box::new(argtype), Box::new(ret)),
}
TypeApplication: Type = {
BaseType,
<s:@L> <c:"<constructor>"> <e:@L> <arguments: BaseType*> => {
let constructor = Type::Constructor(Location::new(file_id, s..e), c);
Type::Application(Box::new(constructor), arguments)
},
<s:@L> <c:"<prim_constructor>"> <e:@L> <arguments: BaseType*> => {
let constructor = Type::Constructor(Location::new(file_id, s..e), c);
Type::Application(Box::new(constructor), arguments)
},
}
BaseType: Type = {
<s:@L> <v:"<value>"> <e:@L> =>
Type::Variable(Location::new(file_id, s..e), v),
<s:@L> <p: "<prim_value>"> <e:@L> =>
Type::Primitive(Location::new(file_id, s..e), p),
"(" <t:Type> ")" => t,
}
pub ConstantValue: ConstantValue = {
<s:@L> <x:"<integer>"> <e:@L> => ConstantValue::Integer(Location::new(file_id, s..e), x),
<s:@L> <x:"<char>"> <e:@L> => ConstantValue::Character(Location::new(file_id, s..e), x),
<s:@L> <x:"<string>"> <e:@L> => ConstantValue::String(Location::new(file_id, s..e), x),
}

1500
src/syntax/parser_tests.rs Normal file
View File

File diff suppressed because it is too large Load Diff

70
src/syntax/print.rs Normal file
View File

@@ -0,0 +1,70 @@
use crate::syntax::ast::{ConstantValue, Type};
#[cfg(test)]
use crate::syntax::parse::Parser;
#[cfg(test)]
use crate::syntax::tokens::Lexer;
use pretty::{DocAllocator, Pretty};
impl<'a, D: ?Sized + DocAllocator<'a, A>, A: 'a> Pretty<'a, D, A> for Type {
fn pretty(self, allocator: &'a D) -> pretty::DocBuilder<'a, D, A> {
match self {
Type::Constructor(_, n) => allocator.as_string(n),
Type::Variable(_, n) => allocator.as_string(n),
Type::Primitive(_, n) => allocator.text("prim%").append(allocator.as_string(n)),
Type::Application(c, args) => c
.pretty(allocator)
.append(allocator.space())
.append(allocator.intersperse(args, " ")),
Type::Function(args, ret) => allocator
.intersperse(args, " ")
.append(allocator.space())
.append(ret.pretty(allocator)),
}
}
}
impl<'a, D: ?Sized + DocAllocator<'a, A>, A: 'a> Pretty<'a, D, A> for ConstantValue {
fn pretty(self, allocator: &'a D) -> pretty::DocBuilder<'a, D, A> {
match self {
ConstantValue::String(_, x) => allocator.text(format!("{x:?}")),
ConstantValue::Character(_, c) => allocator.text(format!("{c:?}")),
ConstantValue::Integer(_, iwb) => match iwb.base {
None => allocator.as_string(iwb.value),
Some(2) => allocator.text(format!("0b{:b}", iwb.value)),
Some(8) => allocator.text(format!("0o{:o}", iwb.value)),
Some(10) => allocator.text(format!("0d{}", iwb.value)),
Some(16) => allocator.text(format!("0x{:x}", iwb.value)),
Some(x) => panic!("Illegal base {x} for integer constant."),
},
}
}
}
proptest::proptest! {
#[test]
fn constants(x: ConstantValue) {
let allocator: pretty::Arena = pretty::Arena::new();
let docbuilder = x.clone().pretty(&allocator);
let mut string_version = String::new();
docbuilder.render_fmt(80, &mut string_version).expect("can render to string");
let lexer = Lexer::from(string_version.as_str());
let mut parser = Parser::new("test", lexer);
let roundtripped = parser.parse_constant().expect("can parse constant");
proptest::prop_assert_eq!(x, roundtripped);
}
// #[test]
// fn types(x: Type) {
// let allocator: pretty::Arena = pretty::Arena::new();
// let docbuilder = x.clone().pretty(&allocator);
// let mut string_version = String::new();
// docbuilder.render_fmt(80, &mut string_version).expect("can render to string");
// println!("String version: {string_version:?}");
// let lexer = Lexer::from(string_version.as_str());
// let mut parser = Parser::new("test", lexer);
// let roundtripped = parser.parse_type().expect("can parse constant");
// proptest::prop_assert_eq!(x, roundtripped);
// }
}

882
src/syntax/tokens.rs Normal file
View File

@@ -0,0 +1,882 @@
use crate::syntax::IntegerWithBase;
use crate::syntax::error::LexerError;
use proptest_derive::Arbitrary;
use std::fmt;
use std::ops::Range;
use std::str::CharIndices;
#[derive(Clone)]
pub struct LocatedToken {
pub token: Token,
pub span: Range<usize>,
}
/// A single token of the input stream; used to help the parsing function over
/// more concrete things than bytes.
///
/// The [`std::fmt::Display`] implementation is designed to round-trip, so those
/// needing a more regular or descriptive option should consider using the
/// [`std::fmt::Debug`] implementation instead.
#[derive(Clone, Debug, PartialEq, Eq, Arbitrary)]
pub enum Token {
OpenParen,
CloseParen,
OpenSquare,
CloseSquare,
OpenBrace,
CloseBrace,
Semi,
Colon,
DoubleColon,
Comma,
BackTick,
Arrow,
Lambda(bool),
TypeName(#[proptest(regex = r"[A-Z][a-zA-Z0-9_]*")] String),
ValueName(#[proptest(regex = r"[a-z_][a-zA-Z0-9_]*")] String),
OperatorName(
#[proptest(
regex = r"[\~\!\@\#\$\%\^\&\*\+\-\=\.<>\?\|][\~\!\@\#\$\%\^\&\*\+\-\=\.<>\?\|_]*",
filter = "|x| x != \"->\""
)]
String,
),
PrimitiveTypeName(#[proptest(regex = r"[A-Z][a-zA-Z0-9_]*")] String),
PrimitiveValueName(#[proptest(regex = r"[a-z_][a-zA-Z0-9_]*")] String),
Integer(IntegerWithBase),
Character(char),
String(String),
}
impl fmt::Display for Token {
fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
match self {
Token::OpenParen => write!(f, "("),
Token::CloseParen => write!(f, ")"),
Token::OpenSquare => write!(f, "["),
Token::CloseSquare => write!(f, "]"),
Token::OpenBrace => write!(f, "{{"),
Token::CloseBrace => write!(f, "}}"),
Token::Semi => write!(f, ";"),
Token::Colon => write!(f, ":"),
Token::DoubleColon => write!(f, "::"),
Token::Comma => write!(f, ","),
Token::BackTick => write!(f, "`"),
Token::Arrow => write!(f, "->"),
Token::Lambda(false) => write!(f, "\\"),
Token::Lambda(true) => write!(f, "λ"),
Token::TypeName(str) => write!(f, "{str}"),
Token::ValueName(str) => write!(f, "{str}"),
Token::OperatorName(str) => write!(f, "{str}"),
Token::PrimitiveTypeName(str) => write!(f, "prim%{str}"),
Token::PrimitiveValueName(str) => write!(f, "prim%{str}"),
Token::Integer(IntegerWithBase { base, value }) => match base {
None => write!(f, "{value}"),
Some(2) => write!(f, "0b{value:b}"),
Some(8) => write!(f, "0o{value:o}"),
Some(10) => write!(f, "0d{value}"),
Some(16) => write!(f, "0x{value:x}"),
Some(base) => write!(f, "<illegal number token base={base} value={value}>"),
},
Token::Character(c) => write!(f, "{c:?}"),
Token::String(s) => write!(f, "{s:?}"),
}
}
}
#[allow(private_interfaces)]
pub enum Lexer<'a> {
Working(LexerState<'a>),
Errored(LexerError),
Done,
}
struct LexerState<'a> {
stream: CharIndices<'a>,
buffer: Option<(usize, char)>,
}
impl<'a> From<&'a str> for Lexer<'a> {
fn from(value: &'a str) -> Self {
Lexer::new(value)
}
}
impl<'a> Lexer<'a> {
pub fn new(stream: &'a str) -> Self {
Lexer::Working(LexerState {
stream: stream.char_indices(),
buffer: None,
})
}
}
impl<'a> Iterator for Lexer<'a> {
type Item = Result<LocatedToken, LexerError>;
fn next(&mut self) -> Option<Self::Item> {
match self {
Lexer::Done => None,
Lexer::Errored(e) => Some(Err(e.clone())),
Lexer::Working(state) => match state.next_token() {
Err(e) => {
println!("ERROR: {e}");
*self = Lexer::Errored(e.clone());
Some(Err(e))
}
Ok(None) => {
*self = Lexer::Done;
None
}
Ok(Some(ltoken)) => Some(Ok(ltoken)),
},
}
}
}
impl<'a> LexerState<'a> {
fn next_char(&mut self) -> Option<(usize, char)> {
self.buffer.take().or_else(|| self.stream.next())
}
fn stash_char(&mut self, idx: usize, c: char) {
assert!(self.buffer.is_none());
self.buffer = Some((idx, c));
}
fn next_token(&mut self) -> Result<Option<LocatedToken>, LexerError> {
while let Some((token_start_offset, char)) = self.next_char() {
if char.is_whitespace() {
continue;
}
let simple_response = |token| {
Ok(Some(LocatedToken {
token,
span: token_start_offset..self.stream.offset(),
}))
};
match char {
'(' => return simple_response(Token::OpenParen),
')' => return simple_response(Token::CloseParen),
'[' => return simple_response(Token::OpenSquare),
']' => return simple_response(Token::CloseSquare),
'{' => return simple_response(Token::OpenBrace),
'}' => return simple_response(Token::CloseBrace),
';' => return simple_response(Token::Semi),
',' => return simple_response(Token::Comma),
'`' => return simple_response(Token::BackTick),
'\\' => return simple_response(Token::Lambda(false)),
'λ' => return simple_response(Token::Lambda(true)),
'0' => return self.starts_with_zero(token_start_offset),
'\'' => return self.starts_with_single(token_start_offset),
'\"' => return self.starts_with_double(token_start_offset),
'-' => return self.starts_with_dash(token_start_offset),
':' => return self.starts_with_colon(token_start_offset),
_ => {}
}
if let Some(value) = char.to_digit(10) {
return self.parse_integer(token_start_offset, 10, None, value as u64);
}
if char.is_uppercase() {
return self.parse_identifier(
token_start_offset,
char.into(),
|c| c.is_alphanumeric() || c == '_',
Token::TypeName,
);
}
if char.is_alphabetic() || char == '_' {
return self.parse_identifier(
token_start_offset,
char.into(),
|c| c.is_alphanumeric() || c == '_',
Token::ValueName,
);
}
if !char.is_alphanumeric() && !char.is_whitespace() && !char.is_control() {
return self.parse_identifier(
token_start_offset,
char.into(),
|c| !c.is_alphanumeric() && !c.is_whitespace() && !c.is_control(),
Token::OperatorName,
);
}
}
Ok(None)
}
fn starts_with_zero(
&mut self,
token_start_offset: usize,
) -> Result<Option<LocatedToken>, LexerError> {
match self.next_char() {
None => {
let token = Token::Integer(IntegerWithBase {
base: None,
value: 0,
});
Ok(Some(LocatedToken {
token,
span: token_start_offset..self.stream.offset(),
}))
}
Some((_, 'b')) => self.parse_integer(token_start_offset, 2, Some(2), 0),
Some((_, 'o')) => self.parse_integer(token_start_offset, 8, Some(8), 0),
Some((_, 'd')) => self.parse_integer(token_start_offset, 10, Some(10), 0),
Some((_, 'x')) => self.parse_integer(token_start_offset, 16, Some(16), 0),
Some((offset, c)) => {
if let Some(value) = c.to_digit(10) {
self.parse_integer(token_start_offset, 10, None, value as u64)
} else {
self.stash_char(offset, c);
let token = Token::Integer(IntegerWithBase {
base: None,
value: 0,
});
Ok(Some(LocatedToken {
token,
span: token_start_offset..offset,
}))
}
}
}
}
fn parse_integer(
&mut self,
token_start_offset: usize,
base: u32,
provided_base: Option<u8>,
mut value: u64,
) -> Result<Option<LocatedToken>, LexerError> {
let mut end_offset = self.stream.offset();
while let Some((offset, c)) = self.next_char() {
end_offset = offset;
if let Some(digit) = c.to_digit(base) {
value = (value * (base as u64)) + (digit as u64);
} else {
self.stash_char(offset, c);
break;
}
}
let token = Token::Integer(IntegerWithBase {
base: provided_base,
value,
});
Ok(Some(LocatedToken {
token,
span: token_start_offset..end_offset,
}))
}
fn parse_identifier(
&mut self,
token_start_offset: usize,
mut identifier: String,
mut allowed_character: fn(char) -> bool,
mut builder: fn(String) -> Token,
) -> Result<Option<LocatedToken>, LexerError> {
let mut end_offset = self.stream.offset();
while let Some((offset, c)) = self.next_char() {
end_offset = offset;
if allowed_character(c) {
identifier.push(c);
} else if identifier == "prim" && c == '%' {
identifier = String::new();
allowed_character = |c| c.is_alphanumeric() || c == '_';
match self.next_char() {
None => {
return Err(LexerError::IllegalPrimitive {
span: token_start_offset..end_offset,
});
}
Some((_, char)) => {
if char.is_uppercase() {
identifier.push(char);
builder = Token::PrimitiveTypeName;
} else if char.is_lowercase() || char == '_' {
identifier.push(char);
builder = Token::PrimitiveValueName;
} else {
return Err(LexerError::IllegalPrimitiveCharacter {
span: token_start_offset..end_offset,
char,
});
}
}
}
} else {
self.stash_char(offset, c);
break;
}
}
Ok(Some(LocatedToken {
token: builder(identifier),
span: token_start_offset..end_offset,
}))
}
fn starts_with_single(
&mut self,
token_start_offset: usize,
) -> Result<Option<LocatedToken>, LexerError> {
let Some((_, mut char)) = self.next_char() else {
return Err(LexerError::UnfinishedCharacter {
span: token_start_offset..self.stream.offset(),
});
};
if char == '\\' {
char = self.get_escaped_character(token_start_offset)?;
}
let Some((idx, finish_char)) = self.next_char() else {
return Err(LexerError::UnfinishedCharacter {
span: token_start_offset..self.stream.offset(),
});
};
if finish_char != '\'' {
return Err(LexerError::OverlongCharacter {
char,
span: token_start_offset..self.stream.offset(),
});
}
Ok(Some(LocatedToken {
token: Token::Character(char),
span: token_start_offset..idx,
}))
}
fn get_escaped_character(&mut self, token_start_offset: usize) -> Result<char, LexerError> {
let Some((idx, escaped_char)) = self.next_char() else {
return Err(LexerError::UnfinishedCharacter {
span: token_start_offset..self.stream.offset(),
});
};
match escaped_char {
'0' => Ok('\0'),
'a' => Ok('\u{0007}'),
'b' => Ok('\u{0008}'),
'f' => Ok('\u{000C}'),
'n' => Ok('\n'),
'r' => Ok('\r'),
't' => Ok('\t'),
'u' => self.get_unicode_sequence(idx),
'v' => Ok('\u{000B}'),
'\'' => Ok('\''),
'"' => Ok('"'),
'\\' => Ok('\\'),
_ => Err(LexerError::UnknownEscapeCharacter {
escaped_char,
span: idx..self.stream.offset(),
}),
}
}
fn get_unicode_sequence(&mut self, token_start_offset: usize) -> Result<char, LexerError> {
let Some((_, char)) = self.next_char() else {
return Err(LexerError::InvalidUnicode {
span: token_start_offset..self.stream.offset(),
});
};
if char != '{' {
return Err(LexerError::InvalidUnicode {
span: token_start_offset..self.stream.offset(),
});
}
let mut value: u32 = 0;
while let Some((idx, char)) = self.next_char() {
if let Some(digit) = char.to_digit(16) {
if let Some(shifted) = value.checked_shl(4) {
value = shifted + digit;
continue;
} else {
return Err(LexerError::InvalidUnicode {
span: token_start_offset..idx,
});
}
}
if char == '}' {
if let Some(char) = char::from_u32(value) {
return Ok(char);
} else {
return Err(LexerError::InvalidUnicode {
span: token_start_offset..idx,
});
}
}
return Err(LexerError::InvalidUnicode {
span: token_start_offset..self.stream.offset(),
});
}
Err(LexerError::InvalidUnicode {
span: token_start_offset..self.stream.offset(),
})
}
fn starts_with_double(
&mut self,
token_start_offset: usize,
) -> Result<Option<LocatedToken>, LexerError> {
let mut result = String::new();
while let Some((idx, char)) = self.next_char() {
match char {
'"' => {
return Ok(Some(LocatedToken {
token: Token::String(result),
span: token_start_offset..idx,
}));
}
'\\' => result.push(self.get_escaped_character(idx)?),
_ => result.push(char),
}
}
Err(LexerError::UnfinishedString {
span: token_start_offset..self.stream.offset(),
})
}
fn starts_with_dash(
&mut self,
token_start_offset: usize,
) -> Result<Option<LocatedToken>, LexerError> {
match self.next_char() {
None => Ok(Some(LocatedToken {
token: Token::OperatorName("-".into()),
span: token_start_offset..token_start_offset + 1,
})),
Some((end, '>')) => {
let Some((pbloc, peekaboo)) = self.next_char() else {
return Ok(Some(LocatedToken {
token: Token::Arrow,
span: token_start_offset..end,
}));
};
let is_operator = !peekaboo.is_alphanumeric()
&& !peekaboo.is_whitespace()
&& !peekaboo.is_control();
if is_operator {
self.parse_identifier(
token_start_offset,
format!("->{peekaboo}"),
|c| !c.is_alphanumeric() && !c.is_whitespace() && !c.is_control(),
Token::OperatorName,
)
} else {
self.stash_char(pbloc, peekaboo);
Ok(Some(LocatedToken {
token: Token::Arrow,
span: token_start_offset..end,
}))
}
}
Some((_, c)) if !c.is_alphanumeric() && !c.is_whitespace() && !c.is_control() => self
.parse_identifier(
token_start_offset,
format!("-{c}"),
|c| !c.is_alphanumeric() && !c.is_whitespace() && !c.is_control(),
Token::OperatorName,
),
Some((idx, c)) => {
self.stash_char(idx, c);
Ok(Some(LocatedToken {
token: Token::OperatorName("-".into()),
span: token_start_offset..idx,
}))
}
}
}
fn starts_with_colon(
&mut self,
token_start_offset: usize,
) -> Result<Option<LocatedToken>, LexerError> {
match self.next_char() {
None => Ok(Some(LocatedToken {
token: Token::Colon,
span: token_start_offset..token_start_offset + 1,
})),
Some((pos, ':')) => Ok(Some(LocatedToken {
token: Token::DoubleColon,
span: token_start_offset..pos,
})),
Some((pos, char)) => {
self.stash_char(pos, char);
Ok(Some(LocatedToken {
token: Token::Colon,
span: token_start_offset..token_start_offset + 1,
}))
}
}
}
}
proptest::proptest! {
#[test]
fn token_string_token(token: Token) {
println!("Starting from {token:?}");
let string = format!("{token}");
let mut tokens = Lexer::from(string.as_str());
let initial_token = tokens.next()
.expect("Can get a token without an error.")
.expect("Can get a valid token.")
.token;
proptest::prop_assert_eq!(token, initial_token);
proptest::prop_assert!(tokens.next().is_none());
}
}
#[cfg(test)]
fn parsed_single_token(s: &str) -> Token {
let mut tokens = Lexer::from(s);
let result = tokens
.next()
.unwrap_or_else(|| panic!("Can get at least one token from {s:?}"))
.expect("Can get a valid token.")
.token;
assert!(
tokens.next().is_none(),
"Should only get one token from {s:?}"
);
result
}
#[test]
fn numbers_work_as_expected() {
assert_eq!(
Token::Integer(IntegerWithBase {
base: None,
value: 1
}),
parsed_single_token("1")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(2),
value: 1
}),
parsed_single_token("0b1")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(8),
value: 1
}),
parsed_single_token("0o1")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(10),
value: 1
}),
parsed_single_token("0d1")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(16),
value: 1
}),
parsed_single_token("0x1")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: None,
value: 10
}),
parsed_single_token("10")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(2),
value: 2
}),
parsed_single_token("0b10")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(8),
value: 8
}),
parsed_single_token("0o10")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: None,
value: 10
}),
parsed_single_token("0010")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(10),
value: 10
}),
parsed_single_token("0d10")
);
assert_eq!(
Token::Integer(IntegerWithBase {
base: Some(16),
value: 16
}),
parsed_single_token("0x10")
);
}
#[test]
fn lambda_works() {
assert_eq!(Token::Lambda(false), parsed_single_token("\\"));
assert_eq!(Token::Lambda(true), parsed_single_token("λ"));
assert_eq!(Token::TypeName("Λ".into()), parsed_single_token("Λ"));
}
#[test]
fn types_work_as_expected() {
assert_eq!(Token::TypeName("Int".into()), parsed_single_token("Int"));
assert_eq!(Token::TypeName("Int8".into()), parsed_single_token("Int8"));
assert_eq!(Token::TypeName("Γ".into()), parsed_single_token("Γ"));
}
#[test]
fn values_work_as_expected() {
assert_eq!(
Token::ValueName("alpha".into()),
parsed_single_token("alpha")
);
assert_eq!(Token::ValueName("ɑ".into()), parsed_single_token("ɑ"));
}
#[test]
fn primitives() {
assert_eq!(
Token::PrimitiveValueName("add_u8".into()),
parsed_single_token("prim%add_u8"),
);
assert_eq!(
Token::PrimitiveTypeName("U8".into()),
parsed_single_token("prim%U8"),
);
assert!(Lexer::from("prim%").next().unwrap().is_err());
assert!(Lexer::from("prim%%").next().unwrap().is_err());
}
#[test]
fn operators_work_as_expected() {
assert_eq!(Token::OperatorName("-".into()), parsed_single_token("-"));
assert_eq!(Token::OperatorName("+".into()), parsed_single_token("+"));
assert_eq!(Token::OperatorName("*".into()), parsed_single_token("*"));
assert_eq!(Token::OperatorName("/".into()), parsed_single_token("/"));
assert_eq!(Token::OperatorName("↣".into()), parsed_single_token("↣"));
}
#[test]
fn can_separate_pieces() {
let mut lexer = Lexer::from("a-b");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::ValueName("a".into())), next_token());
assert_eq!(Some(Token::OperatorName("-".into())), next_token());
assert_eq!(Some(Token::ValueName("b".into())), next_token());
assert_eq!(None, next_token());
let mut lexer = Lexer::from("a--b");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::ValueName("a".into())), next_token());
assert_eq!(Some(Token::OperatorName("--".into())), next_token());
assert_eq!(Some(Token::ValueName("b".into())), next_token());
assert_eq!(None, next_token());
let mut lexer = Lexer::from("a - -b");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::ValueName("a".into())), next_token());
assert_eq!(Some(Token::OperatorName("-".into())), next_token());
assert_eq!(Some(Token::OperatorName("-".into())), next_token());
assert_eq!(Some(Token::ValueName("b".into())), next_token());
assert_eq!(None, next_token());
}
#[test]
fn arrow_requires_nonop() {
let mut lexer = Lexer::from("->");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::Arrow), next_token());
let mut lexer = Lexer::from("->*");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::OperatorName("->*".into())), next_token());
let mut lexer = Lexer::from("->*x");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::OperatorName("->*".into())), next_token());
let mut lexer = Lexer::from("->x");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::Arrow), next_token());
}
#[test]
fn unicode() {
let mut lexer = Lexer::from("'\\u{00BE}'");
let mut next_token = move || lexer.next().map(|x| x.expect("Can read valid token").token);
assert_eq!(Some(Token::Character('¾')), next_token());
let mut lexer = Lexer::from("'\\u{11111111111111111111111111111}'");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'\\u{00BE'");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'\\u00BE}'");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'\\u");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'\\u{00Z}'");
assert!(lexer.next().unwrap().is_err());
}
#[test]
fn character_string_errors() {
let mut lexer = Lexer::from("'");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'-\\");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("''");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'ab'");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'\\x'");
assert!(lexer.next().unwrap().is_err());
let mut lexer = Lexer::from("'a'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character('a'),
..
}))
));
let mut lexer = Lexer::from("'\\0'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character('\0'),
..
}))
));
let mut lexer = Lexer::from("'\\a'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character(_),
..
}))
));
let mut lexer = Lexer::from("'\\b'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character(_),
..
}))
));
let mut lexer = Lexer::from("'\\f'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character(_),
..
}))
));
let mut lexer = Lexer::from("'\\n'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character(_),
..
}))
));
let mut lexer = Lexer::from("'\\r'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character(_),
..
}))
));
let mut lexer = Lexer::from("'\\t'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character(_),
..
}))
));
let mut lexer = Lexer::from("'\\v'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character(_),
..
}))
));
let mut lexer = Lexer::from("'\\''");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character('\''),
..
}))
));
let mut lexer = Lexer::from("'\\\\'");
assert!(matches!(
lexer.next(),
Some(Ok(LocatedToken {
token: Token::Character('\\'),
..
}))
));
let mut lexer = Lexer::from("\"foo");
assert!(lexer.next().unwrap().is_err());
}

44
src/syntax/universe.rs Normal file
View File

@@ -0,0 +1,44 @@
use crate::syntax::ast::*;
use crate::syntax::error::ParserError;
use crate::syntax::parse::Parser;
use crate::syntax::tokens::Lexer;
use memmap2::Mmap;
use std::collections::HashMap;
use std::path::{Path, PathBuf};
#[derive(Default)]
pub struct Universe {
pub files: HashMap<PathBuf, Mmap>,
pub modules: HashMap<PathBuf, Module>,
}
impl Universe {
/// Add a file to this universe.
///
/// This may result in other files being loaded on behalf of the file, if
/// (for example) the given file has imports.
pub fn add_file<P: AsRef<Path>>(&mut self, file: P) -> Result<(), ParserError> {
let filename = file.as_ref().to_string_lossy().into_owned();
let file_handle = std::fs::File::open(&file).map_err(|e| ParserError::OpenError {
file: filename.clone(),
error: e,
})?;
let contents = unsafe { Mmap::map(&file_handle) }.map_err(|e| ParserError::ReadError {
file: filename.clone(),
error: e,
})?;
let string_contents =
std::str::from_utf8(&contents).map_err(|e| ParserError::Utf8Error {
file: filename.clone(),
error: e,
})?;
let lexer = Lexer::from(string_contents);
let mut parser = Parser::new(&file, lexer);
let module = parser.parse_module()?;
self.modules.insert(file.as_ref().to_path_buf(), module);
Ok(())
}
}

13
test.bang
View File

@@ -1,13 +0,0 @@
module Test
primitive type Word = "u64"
/* This is a number! */
one :: Word
one = 1
id :: a -> a
id x = x
seq :: a -> b -> b
seq x y = y