language-servers/roc
1
0
Fork 0
mirror of https://github.com/roc-lang/roc.git synced 2025-10-02 16:21:11 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 6

Merge branch 'trunk' into csv_decoding

Browse source
This commit is contained in:
Marten/Qqwy 2022-07-12 23:10:19 +02:00
commit 3136452b98
No known key found for this signature in database
GPG key ID: FACEF83266BDAF72
53 changed files with 1181 additions and 495 deletions
Download patch file Download diff file Expand all files Collapse all files

23
.github/workflows/nix_linux_x86_64.yml vendored Normal file
View file

@ -0,0 +1,23 @@
on: [pull_request]
name: Nix linux x86_64 cargo test
concurrency:
group: ${{ github.workflow }}-${{ github.ref }}
cancel-in-progress: true
env:
RUST_BACKTRACE: 1
jobs:
nix-linux-x86:
name: nix-linux-x86
runs-on: [self-hosted, i7-6700K]
timeout-minutes: 90
steps:
- uses: actions/checkout@v2
with:
clean: "true"
- name: execute tests with --release
run: /home/big-ci-user/.nix-profile/bin/nix develop -c cargo test --locked --release

0
.github/workflows/nix.yml → .github/workflows/nix_macos_apple_silicon.yml vendored
View file

30
Cargo.lock generated
View file

@ -523,10 +523,8 @@ name = "cli_utils"
version = "0.1.0"
dependencies = [
"bumpalo",
"const_format",
"criterion",
"rlimit",
"roc_cli",
"roc_collections",
"roc_load",
"roc_module",
@ -3392,7 +3390,6 @@ dependencies = [
"roc_module",
"roc_region",
"roc_target",
"roc_types",
"tempfile",
]
@ -3451,7 +3448,6 @@ dependencies = [
"roc_target",
"roc_test_utils",
"serial_test",
"signal-hook",
"strum",
"strum_macros",
"target-lexicon",
@ -3492,7 +3488,6 @@ name = "roc_constrain"
version = "0.1.0"
dependencies = [
"arrayvec 0.7.2",
"roc_builtins",
"roc_can",
"roc_collections",
"roc_error_macros",
@ -3915,10 +3910,6 @@ name = "roc_repl_expect"
version = "0.1.0"
dependencies = [
"bumpalo",
"const_format",
"inkwell 0.1.0",
"libloading",
"roc_build",
"roc_builtins",
"roc_collections",
"roc_load",
@ -3930,8 +3921,6 @@ dependencies = [
"roc_std",
"roc_target",
"roc_types",
"rustyline",
"rustyline-derive",
"target-lexicon",
]
@ -4389,25 +4378,6 @@ version = "1.1.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "43b2853a4d09f215c24cc5489c992ce46052d359b5109343cbafbf26bc62f8a3"
[[package]]
name = "signal-hook"
version = "0.3.14"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "a253b5e89e2698464fc26b545c9edceb338e18a89effeeecfea192c3025be29d"
dependencies = [
"libc",
"signal-hook-registry",
]
[[package]]
name = "signal-hook-registry"
version = "1.4.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "e51e73328dc4ac0c7ccbda3a494dfa03df1de2f46018127f60c693f2648455b0"
dependencies = [
"libc",
]
[[package]]
name = "similar"
version = "2.1.0"

1
crates/cli/Cargo.toml
View file

@ -64,7 +64,6 @@ bumpalo = { version = "3.8.0", features = ["collections"] }
mimalloc = { version = "0.1.26", default-features = false }
libc = "0.2.106"
errno = "0.2.8"
signal-hook = "0.3.14"
ven_pretty = { path = "../vendor/pretty" }
target-lexicon = "0.12.3"

78
crates/cli/src/lib.rs
View file

@ -13,6 +13,7 @@ use roc_target::TargetInfo;
use std::env;
use std::ffi::{CString, OsStr};
use std::io;
use std::os::raw::c_char;
use std::path::{Path, PathBuf};
use std::process;
use target_lexicon::BinaryFormat;
@ -593,7 +594,7 @@ pub fn build(
let mut bytes = std::fs::read(&binary_path).unwrap();
let x = roc_run(arena, triple, args, &mut bytes);
let x = roc_run(arena, opt_level, triple, args, &mut bytes);
std::mem::forget(bytes);
x
}
@ -617,7 +618,7 @@ pub fn build(
let mut bytes = std::fs::read(&binary_path).unwrap();
let x = roc_run(arena, triple, args, &mut bytes);
let x = roc_run(arena, opt_level, triple, args, &mut bytes);
std::mem::forget(bytes);
x
} else {
@ -667,6 +668,7 @@ pub fn build(
fn roc_run<'a, I: IntoIterator<Item = &'a OsStr>>(
arena: Bump, // This should be passed an owned value, not a reference, so we can usefully mem::forget it!
opt_level: OptLevel,
triple: Triple,
args: I,
binary_bytes: &mut [u8],
@ -704,7 +706,7 @@ fn roc_run<'a, I: IntoIterator<Item = &'a OsStr>>(
Ok(0)
}
_ => roc_run_native(arena, args, binary_bytes),
_ => roc_run_native(arena, opt_level, args, binary_bytes),
}
}
@ -712,6 +714,7 @@ fn roc_run<'a, I: IntoIterator<Item = &'a OsStr>>(
#[cfg(target_family = "unix")]
fn roc_run_native<I: IntoIterator<Item = S>, S: AsRef<OsStr>>(
arena: Bump,
opt_level: OptLevel,
args: I,
binary_bytes: &mut [u8],
) -> std::io::Result<i32> {
@ -737,11 +740,10 @@ fn roc_run_native<I: IntoIterator<Item = S>, S: AsRef<OsStr>>(
.iter()
.map(|x| x.as_bytes_with_nul().as_ptr().cast());
let argv: bumpalo::collections::Vec<*const libc::c_char> =
std::iter::once(path_cstring.as_ptr())
.chain(c_string_pointers)
.chain([std::ptr::null()])
.collect_in(&arena);
let argv: bumpalo::collections::Vec<*const c_char> = std::iter::once(path_cstring.as_ptr())
.chain(c_string_pointers)
.chain([std::ptr::null()])
.collect_in(&arena);
// envp is an array of pointers to strings, conventionally of the
// form key=value, which are passed as the environment of the new
@ -755,32 +757,19 @@ fn roc_run_native<I: IntoIterator<Item = S>, S: AsRef<OsStr>>(
})
.collect_in(&arena);
let envp: bumpalo::collections::Vec<*const libc::c_char> = envp_cstrings
let envp: bumpalo::collections::Vec<*const c_char> = envp_cstrings
.iter()
.map(|s| s.as_ptr())
.chain([std::ptr::null()])
.collect_in(&arena);
match executable {
#[cfg(target_os = "linux")]
ExecutableFile::MemFd(fd, _) => {
if libc::fexecve(fd, argv.as_ptr(), envp.as_ptr()) != 0 {
internal_error!(
"libc::fexecve({:?}, ..., ...) failed: {:?}",
path,
errno::errno()
);
}
match opt_level {
OptLevel::Development => {
// roc_run_native_debug(executable, &argv, &envp, expectations, interns)
todo!()
}
#[cfg(not(target_os = "linux"))]
ExecutableFile::OnDisk(_, _) => {
if libc::execve(path_cstring.as_ptr().cast(), argv.as_ptr(), envp.as_ptr()) != 0 {
internal_error!(
"libc::execve({:?}, ..., ...) failed: {:?}",
path,
errno::errno()
);
}
OptLevel::Normal | OptLevel::Size | OptLevel::Optimize => {
roc_run_native_fast(executable, &argv, &envp);
}
}
}
@ -788,6 +777,39 @@ fn roc_run_native<I: IntoIterator<Item = S>, S: AsRef<OsStr>>(
Ok(1)
}
unsafe fn roc_run_native_fast(
executable: ExecutableFile,
argv: &[*const c_char],
envp: &[*const c_char],
) {
match executable {
#[cfg(target_os = "linux")]
ExecutableFile::MemFd(fd, path) => {
if libc::fexecve(fd, argv.as_ptr(), envp.as_ptr()) != 0 {
internal_error!(
"libc::fexecve({:?}, ..., ...) failed: {:?}",
path,
errno::errno()
);
}
}
#[cfg(all(target_family = "unix", not(target_os = "linux")))]
ExecutableFile::OnDisk(_, path) => {
use std::os::unix::ffi::OsStrExt;
let path_cstring = CString::new(path.as_os_str().as_bytes()).unwrap();
if libc::execve(path_cstring.as_ptr().cast(), argv.as_ptr(), envp.as_ptr()) != 0 {
internal_error!(
"libc::execve({:?}, ..., ...) failed: {:?}",
path,
errno::errno()
);
}
}
}
}
#[derive(Debug)]
enum ExecutableFile {
#[cfg(target_os = "linux")]

2
crates/cli_utils/Cargo.toml
View file

@ -10,7 +10,6 @@ description = "Shared code for cli tests and benchmarks"
# See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html
[dependencies]
roc_cli = { path = "../cli" }
roc_collections = { path = "../compiler/collections" }
roc_reporting = { path = "../reporting" }
roc_load = { path = "../compiler/load" }
@ -21,7 +20,6 @@ serde = { version = "1.0.130", features = ["derive"] }
serde-xml-rs = "0.5.1"
strip-ansi-escapes = "0.1.1"
tempfile = "3.2.0"
const_format = { version = "0.2.23", features = ["const_generics"] }
[target.'cfg(unix)'.dependencies]
rlimit = "0.6.2"

6
crates/cli_utils/src/bench_utils.rs
View file

@ -1,12 +1,10 @@
use crate::helpers::{example_file, run_cmd, run_roc};
use const_format::concatcp;
use criterion::{black_box, measurement::Measurement, BenchmarkGroup};
use roc_cli::CMD_BUILD;
use std::{path::Path, thread};
const CFOLD_STACK_SIZE: usize = 8192 * 100000;
const OPTIMIZE_FLAG: &str = concatcp!("--", roc_cli::FLAG_OPTIMIZE);
const OPTIMIZE_FLAG: &str = "--optimize";
fn exec_bench_w_input<T: Measurement>(
file: &Path,
@ -16,7 +14,7 @@ fn exec_bench_w_input<T: Measurement>(
bench_group_opt: Option<&mut BenchmarkGroup<T>>,
) {
let compile_out = run_roc(
[CMD_BUILD, OPTIMIZE_FLAG, file.to_str().unwrap()],
["build", OPTIMIZE_FLAG, file.to_str().unwrap()],
&[stdin_str],
);

1
crates/compiler/builtins/Cargo.toml
View file

@ -9,7 +9,6 @@ edition = "2021"
roc_collections = { path = "../collections" }
roc_region = { path = "../region" }
roc_module = { path = "../module" }
roc_types = { path = "../types" }
roc_target = { path = "../roc_target" }
lazy_static = "1.4.0"

4
crates/compiler/builtins/roc/List.roc
View file

@ -734,6 +734,7 @@ min = \list ->
when List.first list is
Ok initial ->
Ok (minHelp list initial)
Err ListWasEmpty ->
Err ListWasEmpty
@ -750,6 +751,7 @@ max = \list ->
when List.first list is
Ok initial ->
Ok (maxHelp list initial)
Err ListWasEmpty ->
Err ListWasEmpty
@ -782,6 +784,7 @@ find = \array, pred ->
when List.iterate array {} callback is
Continue {} ->
Err NotFound
Break found ->
Ok found
@ -863,6 +866,7 @@ iterHelp = \list, state, f, index, length ->
when f state (List.getUnsafe list index) is
Continue nextState ->
iterHelp list nextState f (index + 1) length
Break b ->
Break b
else

42
crates/compiler/builtins/roc/Result.roc
View file

@ -12,10 +12,8 @@ Result ok err : [Ok ok, Err err]
isOk : Result ok err -> Bool
isOk = \result ->
when result is
Ok _ ->
True
Err _ ->
False
Ok _ -> True
Err _ -> False
## Return True if the result indicates a failure, else return False
##
@ -23,10 +21,8 @@ isOk = \result ->
isErr : Result ok err -> Bool
isErr = \result ->
when result is
Ok _ ->
False
Err _ ->
True
Ok _ -> False
Err _ -> True
## If the result is `Ok`, return the value it holds. Otherwise, return
## the given default value.
@ -37,10 +33,8 @@ isErr = \result ->
withDefault : Result ok err, ok -> ok
withDefault = \result, default ->
when result is
Ok value ->
value
Err _ ->
default
Ok value -> value
Err _ -> default
## If the result is `Ok`, transform the value it holds by running a conversion
## function on it. Then return a new `Ok` holding the transformed value.
@ -56,10 +50,8 @@ withDefault = \result, default ->
map : Result a err, (a -> b) -> Result b err
map = \result, transform ->
when result is
Ok v ->
Ok (transform v)
Err e ->
Err e
Ok v -> Ok (transform v)
Err e -> Err e
## If the result is `Err`, transform the value it holds by running a conversion
## function on it. Then return a new `Err` holding the transformed value.
@ -72,10 +64,8 @@ map = \result, transform ->
mapErr : Result ok a, (a -> b) -> Result ok b
mapErr = \result, transform ->
when result is
Ok v ->
Ok v
Err e ->
Err (transform e)
Ok v -> Ok v
Err e -> Err (transform e)
## If the result is `Ok`, transform the entire result by running a conversion
## function on the value the `Ok` holds. Then return that new result.
@ -88,10 +78,8 @@ mapErr = \result, transform ->
after : Result a err, (a -> Result b err) -> Result b err
after = \result, transform ->
when result is
Ok v ->
transform v
Err e ->
Err e
Ok v -> transform v
Err e -> Err e
## If the result is `Err`, transform the entire result by running a conversion
## function on the value the `Err` holds. Then return that new result.
@ -104,7 +92,5 @@ after = \result, transform ->
afterErr : Result a err, (err -> Result a otherErr) -> Result a otherErr
afterErr = \result, transform ->
when result is
Ok v ->
Ok v
Err e ->
transform e
Ok v -> Ok v
Err e -> transform e

4
crates/compiler/builtins/roc/Str.roc
View file

@ -290,6 +290,7 @@ splitFirst = \haystack, needle ->
after = Str.substringUnsafe haystack (index + Str.countUtf8Bytes needle) remaining
Ok { before, after }
None ->
Err NotFound
@ -325,6 +326,7 @@ splitLast = \haystack, needle ->
after = Str.substringUnsafe haystack (index + Str.countUtf8Bytes needle) remaining
Ok { before, after }
None ->
Err NotFound
@ -344,6 +346,7 @@ lastMatchHelp = \haystack, needle, index ->
when Num.subChecked index 1 is
Ok nextIndex ->
lastMatchHelp haystack needle nextIndex
Err _ ->
None
@ -428,6 +431,7 @@ walkScalarsUntilHelp = \string, state, step, index, length ->
when step state scalar is
Continue newState ->
walkScalarsUntilHelp string newState step (index + bytesParsed) length
Break newState ->
newState
else

77
crates/compiler/can/src/expr.rs
View file

@ -2393,3 +2393,80 @@ fn get_lookup_symbols(expr: &Expr, var_store: &mut VarStore) -> Vec<(Symbol, Var
symbols
}
/// Here we transform
///
/// ```ignore
/// expect
/// a = 1
/// b = 2
///
/// a == b
/// ```
///
/// into
///
/// ```ignore
/// a = 1
/// b = 2
///
/// expect a == b
///
/// {}
/// ```
///
/// This is supposed to happen just before monomorphization:
/// all type errors and such are generated from the user source,
/// but this transformation means that we don't need special codegen for toplevel expects
pub fn toplevel_expect_to_inline_expect(mut loc_expr: Loc<Expr>) -> Loc<Expr> {
enum StoredDef {
NonRecursive(Region, Box<Def>),
Recursive(Region, Vec<Def>, IllegalCycleMark),
}
let mut stack = vec![];
let mut lookups_in_cond = vec![];
loop {
match loc_expr.value {
Expr::LetNonRec(boxed_def, remainder) => {
lookups_in_cond.extend(boxed_def.pattern_vars.iter().map(|(a, b)| (*a, *b)));
stack.push(StoredDef::NonRecursive(loc_expr.region, boxed_def));
loc_expr = *remainder;
}
Expr::LetRec(defs, remainder, mark) => {
for def in &defs {
lookups_in_cond.extend(def.pattern_vars.iter().map(|(a, b)| (*a, *b)));
}
stack.push(StoredDef::Recursive(loc_expr.region, defs, mark));
loc_expr = *remainder;
}
_ => break,
}
}
let expect_region = loc_expr.region;
let expect = Expr::Expect {
loc_condition: Box::new(loc_expr),
loc_continuation: Box::new(Loc::at_zero(Expr::EmptyRecord)),
lookups_in_cond,
};
let mut loc_expr = Loc::at(expect_region, expect);
for stored in stack {
match stored {
StoredDef::NonRecursive(region, boxed_def) => {
loc_expr = Loc::at(region, Expr::LetNonRec(boxed_def, Box::new(loc_expr)));
}
StoredDef::Recursive(region, defs, illegal_cycle_mark) => {
let let_rec = Expr::LetRec(defs, Box::new(loc_expr), illegal_cycle_mark);
loc_expr = Loc::at(region, let_rec);
}
}
}
loc_expr
}

1
crates/compiler/constrain/Cargo.toml
View file

@ -13,5 +13,4 @@ roc_module = { path = "../module" }
roc_parse = { path = "../parse" }
roc_types = { path = "../types" }
roc_can = { path = "../can" }
roc_builtins = { path = "../builtins" }
arrayvec = "0.7.2"

8
crates/compiler/fmt/src/collection.rs
View file

@ -46,16 +46,16 @@ pub fn fmt_collection<'a, 'buf, T: ExtractSpaces<'a> + Formattable>(
let is_only_newlines = item.before.iter().all(|s| s.is_newline());
if item.before.is_empty() || is_only_newlines {
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
} else {
if is_first_item {
// The first item in a multiline collection always begins with exactly
// one newline (so the delimiter is at the end of its own line),
// and that newline appears before the first comment (if there is one).
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
} else {
if item.before.starts_with(&[CommentOrNewline::Newline]) {
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
}
if item
@ -113,7 +113,7 @@ pub fn fmt_collection<'a, 'buf, T: ExtractSpaces<'a> + Formattable>(
item_indent,
);
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
buf.indent(braces_indent);
} else {
// is_multiline == false

42
crates/compiler/fmt/src/expr.rs
View file

@ -540,7 +540,7 @@ fn fmt_binops<'a, 'buf>(
loc_left_side.format_with_options(buf, apply_needs_parens, Newlines::No, curr_indent);
if is_multiline {
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
curr_indent = indent + INDENT;
buf.indent(curr_indent);
} else {
@ -699,6 +699,8 @@ fn fmt_when<'a, 'buf>(
buf.push_str("is");
buf.newline();
let mut prev_branch_was_multiline = false;
for (branch_index, branch) in branches.iter().enumerate() {
let expr = &branch.value;
let patterns = &branch.patterns;
@ -709,10 +711,21 @@ fn fmt_when<'a, 'buf>(
if pattern_index == 0 {
match &pattern.value {
Pattern::SpaceBefore(sub_pattern, spaces) => {
let added_blank_line;
if branch_index > 0 // Never render newlines before the first branch.
&& matches!(spaces.first(), Some(CommentOrNewline::Newline))
{
buf.ensure_ends_in_newline();
if prev_branch_was_multiline {
// Multiline branches always get a full blank line after them.
buf.ensure_ends_with_blank_line();
added_blank_line = true;
} else {
buf.ensure_ends_with_newline();
added_blank_line = false;
}
} else {
added_blank_line = false;
}
// Write comments (which may have been attached to the previous
@ -720,20 +733,33 @@ fn fmt_when<'a, 'buf>(
fmt_comments_only(buf, spaces.iter(), NewlineAt::Bottom, indent + INDENT);
if branch_index > 0 {
buf.ensure_ends_in_newline();
if prev_branch_was_multiline && !added_blank_line {
// Multiline branches always get a full blank line after them
// (which we may already have added before a comment).
buf.ensure_ends_with_blank_line();
} else {
buf.ensure_ends_with_newline();
}
}
fmt_pattern(buf, sub_pattern, indent + INDENT, Parens::NotNeeded);
}
other => {
buf.ensure_ends_in_newline();
if branch_index > 0 {
if prev_branch_was_multiline {
// Multiline branches always get a full blank line after them.
buf.ensure_ends_with_blank_line();
} else {
buf.ensure_ends_with_newline();
}
}
fmt_pattern(buf, other, indent + INDENT, Parens::NotNeeded);
}
}
} else {
if is_multiline_patterns {
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
// Indent an extra level for the `|`;
// otherwise it'll be at the start of the line,
// and will be incorrectly parsed as a pattern
@ -762,7 +788,7 @@ fn fmt_when<'a, 'buf>(
fmt_spaces_no_blank_lines(buf, spaces.iter(), indent + (INDENT * 2));
if is_multiline_expr {
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
} else {
buf.spaces(1);
}
@ -776,7 +802,7 @@ fn fmt_when<'a, 'buf>(
}
_ => {
if is_multiline_expr {
buf.ensure_ends_in_newline();
buf.ensure_ends_with_newline();
} else {
buf.spaces(1);
}
@ -789,6 +815,8 @@ fn fmt_when<'a, 'buf>(
);
}
}
prev_branch_was_multiline = is_multiline_expr || is_multiline_patterns;
}
}

15
crates/compiler/fmt/src/lib.rs
View file

@ -98,7 +98,7 @@ impl<'a> Buf<'a> {
/// Ensures the current buffer ends in a newline, if it didn't already.
/// Doesn't add a newline if the buffer already ends in one.
pub fn ensure_ends_in_newline(&mut self) {
pub fn ensure_ends_with_newline(&mut self) {
if self.spaces_to_flush > 0 {
self.flush_spaces();
self.newline();
@ -107,6 +107,19 @@ impl<'a> Buf<'a> {
}
}
pub fn ensure_ends_with_blank_line(&mut self) {
if self.spaces_to_flush > 0 {
self.flush_spaces();
self.newline();
self.newline();
} else if !self.text.ends_with('\n') {
self.newline();
self.newline();
} else if !self.text.ends_with("\n\n") {
self.newline();
}
}
fn flush_spaces(&mut self) {
if self.spaces_to_flush > 0 {
for _ in 0..self.spaces_to_flush {

28
crates/compiler/fmt/tests/test_fmt.rs
View file

@ -3341,6 +3341,7 @@ mod test_fmt {
when b is
1 ->
1
_ ->
2
"#
@ -3370,6 +3371,7 @@ mod test_fmt {
when year is
1999 ->
1
_ ->
0
"#
@ -3386,6 +3388,7 @@ mod test_fmt {
1 ->
# when 1
1
# important
# fall through
_ ->
@ -3404,6 +3407,7 @@ mod test_fmt {
when 0 is
1 # comment
| 2 -> "a"
_ -> "b"
"#
));
@ -3431,6 +3435,7 @@ mod test_fmt {
when c is
6 | 7 ->
8
3 | 4 ->
5
"#
@ -3504,15 +3509,19 @@ mod test_fmt {
| 2
| 3 ->
4
5 | 6 | 7 ->
8
9
| 10 -> 11
12 | 13 ->
when c is
14 | 15 -> 16
17
| 18 -> 19
20 -> 21
"#
),
@ -3549,6 +3558,7 @@ mod test_fmt {
is
1 ->
Nothing
_ ->
Just True
"#
@ -3566,6 +3576,7 @@ mod test_fmt {
is
Complex x y ->
simplify x y
Simple z ->
z
"#
@ -3600,6 +3611,7 @@ mod test_fmt {
is
2 ->
x
_ ->
y
"#
@ -3636,6 +3648,7 @@ mod test_fmt {
is
4 ->
x
_ ->
y
"#
@ -3783,6 +3796,7 @@ mod test_fmt {
when maybeScore is
Just score if score > 21 ->
win
_ ->
nextRound
"#
@ -3796,8 +3810,10 @@ mod test_fmt {
when authenticationResponse is
Ok user if hasPermission user ->
loadPage route user
Ok user ->
PageNotFound
Err _ ->
ErrorPage
"#
@ -3903,6 +3919,7 @@ mod test_fmt {
when f x == g y == h z is
True ->
Ok 1
False ->
Err 2
"#
@ -4039,17 +4056,20 @@ mod test_fmt {
3
* 2 # comment 3
< 1 # comment 4
z ->
4
/ 5 # comment 5
< 1 # comment 6
46 # first pattern comment
| 95 # alternative comment 1
| 126 # alternative comment 2
| 150 -> # This comment goes after the ->
# This comment is for the expr
Str.appendScalar output (Num.toU32 byte)
|> Result.withDefault "" # this will never fail
foo bar
|> Result.withDefault "" # one last comment
_ ->
42
"#
@ -4301,6 +4321,7 @@ mod test_fmt {
when result is
Err _ ->
Err {}
Ok val ->
Ok {}
)
@ -4319,6 +4340,7 @@ mod test_fmt {
when result is
Err _ ->
Err {}
Ok val ->
Ok {}
)
@ -4335,6 +4357,7 @@ mod test_fmt {
when result is
Err _ ->
Err {}
Ok val ->
Ok {}
)
@ -4746,6 +4769,7 @@ mod test_fmt {
when list is
Nil ->
Nothing
Cons first _ ->
Just first

18
crates/compiler/gen_llvm/src/llvm/build.rs
View file

@ -4313,24 +4313,10 @@ pub fn build_procedures_return_main<'a, 'ctx, 'env>(
pub fn build_procedures_expose_expects<'a, 'ctx, 'env>(
env: &Env<'a, 'ctx, 'env>,
opt_level: OptLevel,
expects: &[Symbol],
procedures: MutMap<(Symbol, ProcLayout<'a>), roc_mono::ir::Proc<'a>>,
entry_point: EntryPoint<'a>,
) -> Vec<'a, &'a str> {
use bumpalo::collections::CollectIn;
// this is not entirely accurate: it will treat every top-level bool value (turned into a
// zero-argument thunk) as an expect.
let expects: Vec<_> = procedures
.keys()
.filter_map(|(symbol, proc_layout)| {
if proc_layout.arguments.is_empty() && proc_layout.result == Layout::bool() {
Some(*symbol)
} else {
None
}
})
.collect_in(env.arena);
let mod_solutions = build_procedures_help(
env,
opt_level,
@ -4343,7 +4329,7 @@ pub fn build_procedures_expose_expects<'a, 'ctx, 'env>(
let top_level = ProcLayout {
arguments: &[],
result: Layout::bool(),
result: Layout::UNIT,
captures_niche,
};

18
crates/compiler/load_internal/src/file.rs
View file

@ -626,6 +626,7 @@ pub struct MonomorphizedModule<'a> {
pub can_problems: MutMap<ModuleId, Vec<roc_problem::can::Problem>>,
pub type_problems: MutMap<ModuleId, Vec<solve::TypeError>>,
pub procedures: MutMap<(Symbol, ProcLayout<'a>), Proc<'a>>,
pub toplevel_expects: Vec<Symbol>,
pub entry_point: EntryPoint<'a>,
pub exposed_to_host: ExposedToHost,
pub sources: MutMap<ModuleId, (PathBuf, Box<str>)>,
@ -708,6 +709,7 @@ enum Msg<'a> {
solved_subs: Solved<Subs>,
module_timing: ModuleTiming,
abilities_store: AbilitiesStore,
toplevel_expects: std::vec::Vec<Symbol>,
},
MadeSpecializations {
module_id: ModuleId,
@ -795,6 +797,7 @@ struct State<'a> {
pub module_cache: ModuleCache<'a>,
pub dependencies: Dependencies<'a>,
pub procedures: MutMap<(Symbol, ProcLayout<'a>), Proc<'a>>,
pub toplevel_expects: Vec<Symbol>,
pub exposed_to_host: ExposedToHost,
/// This is the "final" list of IdentIds, after canonicalization and constraint gen
@ -861,6 +864,7 @@ impl<'a> State<'a> {
module_cache: ModuleCache::default(),
dependencies: Dependencies::default(),
procedures: MutMap::default(),
toplevel_expects: Vec::new(),
exposed_to_host: ExposedToHost::default(),
exposed_types,
arc_modules,
@ -2324,11 +2328,14 @@ fn update<'a>(
layout_cache,
module_timing,
abilities_store,
toplevel_expects,
} => {
log!("found specializations for {:?}", module_id);
let subs = solved_subs.into_inner();
state.toplevel_expects.extend(toplevel_expects);
state
.module_cache
.top_level_thunks
@ -2630,6 +2637,7 @@ fn finish_specialization(
};
let State {
toplevel_expects,
procedures,
module_cache,
output_path,
@ -2718,6 +2726,7 @@ fn finish_specialization(
entry_point,
sources,
timings: state.timings,
toplevel_expects,
})
}
@ -4560,13 +4569,14 @@ fn build_pending_specializations<'a>(
mut module_timing: ModuleTiming,
mut layout_cache: LayoutCache<'a>,
target_info: TargetInfo,
exposed_to_host: ExposedToHost, // TODO remove
exposed_to_host: ExposedToHost,
abilities_store: AbilitiesStore,
derived_symbols: GlobalDerivedSymbols,
) -> Msg<'a> {
let find_specializations_start = SystemTime::now();
let mut module_thunks = bumpalo::collections::Vec::new_in(arena);
let mut toplevel_expects = std::vec::Vec::new();
let mut procs_base = ProcsBase {
partial_procs: BumpMap::default(),
@ -4809,6 +4819,8 @@ fn build_pending_specializations<'a>(
// mark this symbol as a top-level thunk before any other work on the procs
module_thunks.push(symbol);
let expr_var = Variable::EMPTY_RECORD;
let is_host_exposed = true;
// If this is an exposed symbol, we need to
@ -4848,6 +4860,8 @@ fn build_pending_specializations<'a>(
);
}
let body = roc_can::expr::toplevel_expect_to_inline_expect(body);
let proc = PartialProc {
annotation: expr_var,
// This is a 0-arity thunk, so it has no arguments.
@ -4860,6 +4874,7 @@ fn build_pending_specializations<'a>(
is_self_recursive: false,
};
toplevel_expects.push(symbol);
procs_base.partial_procs.insert(symbol, proc);
}
}
@ -4880,6 +4895,7 @@ fn build_pending_specializations<'a>(
procs_base,
module_timing,
abilities_store,
toplevel_expects,
}
}

20
crates/compiler/mono/src/inc_dec.rs
View file

@ -1187,7 +1187,25 @@ impl<'a> Context<'a> {
(switch, case_live_vars)
}
Expect { remainder, .. } => self.visit_stmt(codegen, remainder),
Expect {
remainder,
condition,
region,
lookups,
layouts,
} => {
let (b, b_live_vars) = self.visit_stmt(codegen, remainder);
let expect = self.arena.alloc(Stmt::Expect {
condition: *condition,
region: *region,
lookups,
layouts,
remainder: b,
});
(expect, b_live_vars)
}
RuntimeError(_) | Refcounting(_, _) => (stmt, MutSet::default()),
}

79
crates/compiler/mono/src/ir.rs
View file

@ -68,29 +68,29 @@ roc_error_macros::assert_sizeof_non_wasm!(Call, 9 * 8);
roc_error_macros::assert_sizeof_non_wasm!(CallType, 7 * 8);
macro_rules! return_on_layout_error {
($env:expr, $layout_result:expr) => {
($env:expr, $layout_result:expr, $context_msg:expr) => {
match $layout_result {
Ok(cached) => cached,
Err(error) => return_on_layout_error_help!($env, error),
Err(error) => return_on_layout_error_help!($env, error, $context_msg),
}
};
}
macro_rules! return_on_layout_error_help {
($env:expr, $error:expr) => {{
($env:expr, $error:expr, $context_msg:expr) => {{
match $error {
LayoutProblem::UnresolvedTypeVar(_) => {
return Stmt::RuntimeError($env.arena.alloc(format!(
"UnresolvedTypeVar {} line {}",
"UnresolvedTypeVar {} at {}",
file!(),
line!()
$context_msg,
)));
}
LayoutProblem::Erroneous => {
return Stmt::RuntimeError($env.arena.alloc(format!(
"Erroneous {} line {}",
"Erroneous {} at {}",
file!(),
line!()
$context_msg,
)));
}
}
@ -1980,9 +1980,16 @@ impl<'a> Stmt<'a> {
.append(alloc.hardline())
.append(cont.to_doc(alloc)),
Expect { condition, .. } => alloc
Expect {
condition,
remainder,
..
} => alloc
.text("expect ")
.append(symbol_to_doc(alloc, *condition)),
.append(symbol_to_doc(alloc, *condition))
.append(";")
.append(alloc.hardline())
.append(remainder.to_doc(alloc)),
Ret(symbol) => alloc
.text("ret ")
@ -4357,7 +4364,8 @@ pub fn with_hole<'a>(
Ok(_) => {
let raw_layout = return_on_layout_error!(
env,
layout_cache.raw_from_var(env.arena, function_type, env.subs,)
layout_cache.raw_from_var(env.arena, function_type, env.subs),
"Expr::Accessor"
);
match raw_layout {
@ -4559,7 +4567,7 @@ pub fn with_hole<'a>(
let raw = layout_cache.raw_from_var(env.arena, function_type, env.subs);
match return_on_layout_error!(env, raw) {
match return_on_layout_error!(env, raw, "Expr::Closure") {
RawFunctionLayout::ZeroArgumentThunk(_) => {
unreachable!("a closure syntactically always must have at least one argument")
}
@ -4691,7 +4699,8 @@ pub fn with_hole<'a>(
let full_layout = return_on_layout_error!(
env,
layout_cache.raw_from_var(env.arena, fn_var, env.subs,)
layout_cache.raw_from_var(env.arena, fn_var, env.subs),
"Expr::Call"
);
// if the function expression (loc_expr) is already a symbol,
@ -4877,8 +4886,11 @@ pub fn with_hole<'a>(
let arg_symbols = arg_symbols.into_bump_slice();
// layout of the return type
let layout =
return_on_layout_error!(env, layout_cache.from_var(env.arena, ret_var, env.subs,));
let layout = return_on_layout_error!(
env,
layout_cache.from_var(env.arena, ret_var, env.subs),
"ForeignCall"
);
let call = self::Call {
call_type: CallType::Foreign {
@ -4913,8 +4925,11 @@ pub fn with_hole<'a>(
let arg_symbols = arg_symbols.into_bump_slice();
// layout of the return type
let layout =
return_on_layout_error!(env, layout_cache.from_var(env.arena, ret_var, env.subs,));
let layout = return_on_layout_error!(
env,
layout_cache.from_var(env.arena, ret_var, env.subs),
"RunLowLevel"
);
macro_rules! match_on_closure_argument {
( $ho:ident, [$($x:ident),* $(,)?]) => {{
@ -4924,7 +4939,8 @@ pub fn with_hole<'a>(
let closure_data_layout = return_on_layout_error!(
env,
layout_cache.raw_from_var(env.arena, closure_data_var, env.subs)
layout_cache.raw_from_var(env.arena, closure_data_var, env.subs),
"match_on_closure_argument"
);
// NB: I don't think the top_level here can have a captures niche?
@ -5388,7 +5404,8 @@ fn convert_tag_union<'a>(
// version is not the same as the minimal version.
let union_layout = match return_on_layout_error!(
env,
layout_cache.from_var(env.arena, variant_var, env.subs,)
layout_cache.from_var(env.arena, variant_var, env.subs),
"Wrapped"
) {
Layout::Union(ul) => ul,
_ => unreachable!(),
@ -5581,7 +5598,8 @@ fn tag_union_to_function<'a>(
// only need to construct closure data
let raw_layout = return_on_layout_error!(
env,
layout_cache.raw_from_var(env.arena, whole_var, env.subs,)
layout_cache.raw_from_var(env.arena, whole_var, env.subs),
"tag_union_to_function"
);
match raw_layout {
@ -5878,7 +5896,7 @@ pub fn from_can<'a>(
for (_, var) in lookups_in_cond {
let res_layout = layout_cache.from_var(env.arena, var, env.subs);
let layout = return_on_layout_error!(env, res_layout);
let layout = return_on_layout_error!(env, res_layout, "Expect");
layouts.push(layout);
}
@ -6044,11 +6062,17 @@ fn from_can_when<'a>(
}
let opt_branches = to_opt_branches(env, procs, branches, exhaustive_mark, layout_cache);
let cond_layout =
return_on_layout_error!(env, layout_cache.from_var(env.arena, cond_var, env.subs,));
let cond_layout = return_on_layout_error!(
env,
layout_cache.from_var(env.arena, cond_var, env.subs),
"from_can_when cond_layout"
);
let ret_layout =
return_on_layout_error!(env, layout_cache.from_var(env.arena, expr_var, env.subs,));
let ret_layout = return_on_layout_error!(
env,
layout_cache.from_var(env.arena, expr_var, env.subs),
"from_can_when ret_layout"
);
let arena = env.arena;
let it = opt_branches
@ -7040,7 +7064,7 @@ where
add_needed_external(procs, env, variable, LambdaName::no_niche(right));
let res_layout = layout_cache.from_var(env.arena, variable, env.subs);
let layout = return_on_layout_error!(env, res_layout);
let layout = return_on_layout_error!(env, res_layout, "handle_variable_aliasing");
result = force_thunk(env, right, layout, left, env.arena.alloc(result));
}
@ -7131,7 +7155,7 @@ fn specialize_symbol<'a>(
Some(arg_var) if env.is_imported_symbol(original) => {
let raw = match layout_cache.raw_from_var(env.arena, arg_var, env.subs) {
Ok(v) => v,
Err(e) => return_on_layout_error_help!(env, e),
Err(e) => return_on_layout_error_help!(env, e, "specialize_symbol"),
};
if procs.is_imported_module_thunk(original) {
@ -7192,7 +7216,8 @@ fn specialize_symbol<'a>(
// to it in the IR.
let res_layout = return_on_layout_error!(
env,
layout_cache.raw_from_var(env.arena, arg_var, env.subs,)
layout_cache.raw_from_var(env.arena, arg_var, env.subs),
"specialize_symbol res_layout"
);
// we have three kinds of functions really. Plain functions, closures by capture,

4
crates/compiler/test_mono/generated/call_function_in_empty_list_unbound.txt
View file

@ -1,6 +1,6 @@
procedure List.5 (#Attr.2, #Attr.3):
Error UnresolvedTypeVar crates/compiler/mono/src/ir.rs line 5035
Error UnresolvedTypeVar crates/compiler/mono/src/ir.rs at match_on_closure_argument
procedure Test.0 ():
let Test.1 : List [] = Array [];
Error UnresolvedTypeVar crates/compiler/mono/src/ir.rs line 4562
Error UnresolvedTypeVar crates/compiler/mono/src/ir.rs at Expr::Closure

16
crates/highlight/tests/peg_grammar.rs
View file

@ -446,14 +446,14 @@ mod test_peg_grammar {
[T::KeywordWhen] expr() [T::KeywordIs] when_branches()
rule when_branches() =
[T::OpenIndent] when_branch()+ close_or_end()
[T::OpenIndent] when_branch() ([T::SameIndent]? when_branch())* close_or_end()
/ when_branch()+
pub rule when_branch() =
when_match_pattern() ([T::Pipe] full_expr())* ([T::KeywordIf] full_expr())? [T::Arrow] when_branch_body()
rule when_branch_body() =
[T::OpenIndent] full_expr() ([T::CloseIndent] / end_of_file())
[T::OpenIndent] full_expr() close_or_end()
/ full_expr()
rule var() =
@ -807,6 +807,16 @@ test1 =
assert_eq!(tokenparser::when(&tokens), Ok(()));
}
#[test]
fn test_when_3() {
let tokens = tokenize(
r#"when list is
Nil -> Cons a
Nil -> Nil"#,
);
assert_eq!(tokenparser::when(&tokens), Ok(()));
}
#[test]
fn test_when_in_defs() {
let tokens = tokenize(
@ -815,7 +825,7 @@ test1 =
Ok v -> v
"#,
);
dbg!(&tokens);
assert_eq!(tokenparser::module_defs(&tokens), Ok(()));
}

2
crates/repl_cli/src/lib.rs
View file

@ -201,6 +201,7 @@ pub fn expect_mono_module_to_dylib<'a>(
let target_info = TargetInfo::from(&target);
let MonomorphizedModule {
toplevel_expects,
procedures,
entry_point,
interns,
@ -241,6 +242,7 @@ pub fn expect_mono_module_to_dylib<'a>(
let expects = roc_gen_llvm::llvm::build::build_procedures_expose_expects(
&env,
opt_level,
&toplevel_expects,
procedures,
entry_point,
);

14
crates/repl_expect/Cargo.toml
View file

@ -5,24 +5,10 @@ edition = "2021"
# See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html
[features]
# pipe target to roc_build
target-aarch64 = ["roc_build/target-aarch64"]
target-arm = ["roc_build/target-arm"]
target-wasm32 = ["roc_build/target-wasm32"]
target-x86 = ["roc_build/target-x86"]
target-x86_64 = ["roc_build/target-x86_64"]
[dependencies]
bumpalo = {version = "3.8.0", features = ["collections"]}
const_format = { version = "0.2.23", features = ["const_generics"] }
inkwell = {path = "../vendor/inkwell"}
libloading = "0.7.1"
rustyline = {git = "https://github.com/rtfeldman/rustyline", rev = "e74333c"}
rustyline-derive = {git = "https://github.com/rtfeldman/rustyline", rev = "e74333c"}
target-lexicon = "0.12.2"
roc_build = {path = "../compiler/build"}
roc_builtins = {path = "../compiler/builtins"}
roc_collections = {path = "../compiler/collections"}
roc_load = {path = "../compiler/load"}

3
examples/algorithms/quicksort.roc
View file

@ -26,6 +26,7 @@ partition = \low, high, initialList ->
when partitionHelp low low initialList high pivot is
Pair newI newList ->
Pair newI (swap newI high newList)
Err _ ->
Pair low initialList
@ -38,6 +39,7 @@ partitionHelp = \i, j, list, high, pivot ->
partitionHelp (i + 1) (j + 1) (swap i j list) high pivot
else
partitionHelp i (j + 1) list high pivot
Err _ ->
Pair i list
else
@ -50,6 +52,7 @@ swap = \i, j, list ->
list
|> List.set i atJ
|> List.set j atI
_ ->
# to prevent a decrement on list
# turns out this is very important for optimizations

16
examples/benchmarks/AStar.roc
View file

@ -25,10 +25,8 @@ cheapestOpen = \costFn, model ->
|> List.keepOks
(\position ->
when Dict.get model.costs position is
Err _ ->
Err {}
Ok cost ->
Ok { cost: cost + costFn position, position }
Err _ -> Err {}
Ok cost -> Ok { cost: cost + costFn position, position }
)
|> Quicksort.sortBy .cost
|> List.first
@ -38,10 +36,8 @@ cheapestOpen = \costFn, model ->
reconstructPath : Dict position position, position -> List position
reconstructPath = \cameFrom, goal ->
when Dict.get cameFrom goal is
Err _ ->
[]
Ok next ->
List.append (reconstructPath cameFrom next) goal
Err _ -> []
Ok next -> List.append (reconstructPath cameFrom next) goal
updateCost : position, position, Model position -> Model position
updateCost = \current, neighbor, model ->
@ -65,6 +61,7 @@ updateCost = \current, neighbor, model ->
when Dict.get model.costs neighbor is
Err _ ->
newModel
Ok previousDistance ->
if distanceTo < previousDistance then
newModel
@ -74,8 +71,7 @@ updateCost = \current, neighbor, model ->
astar : (position, position -> F64), (position -> Set position), position, Model position -> Result (List position) {}
astar = \costFn, moveFn, goal, model ->
when cheapestOpen (\source -> costFn source goal) model is
Err {} ->
Err {}
Err {} -> Err {}
Ok current ->
if current == goal then
Ok (reconstructPath model.cameFrom goal)

3
examples/benchmarks/Base64.roc
View file

@ -6,6 +6,7 @@ fromBytes = \bytes ->
when Base64.Decode.fromBytes bytes is
Ok v ->
Ok v
Err _ ->
Err InvalidInput
@ -26,7 +27,9 @@ toStr = \str ->
when Str.fromUtf8 bytes is
Ok v ->
Ok v
Err _ ->
Err InvalidInput
Err _ ->
Err InvalidInput

17
examples/benchmarks/Base64/Decode.roc
View file

@ -48,10 +48,8 @@ loopHelp = \{ remaining, string } ->
bitsToChars : U32, Int * -> Str
bitsToChars = \bits, missing ->
when Str.fromUtf8 (bitsToCharsHelp bits missing) is
Ok str ->
str
Err _ ->
""
Ok str -> str
Err _ -> ""
# Mask that can be used to get the lowest 6 bits of a binary number
lowest6BitsMask : Int *
@ -87,12 +85,9 @@ bitsToCharsHelp = \bits, missing ->
equals = 61
when missing is
0 ->
[p, q, r, s]
1 ->
[p, q, r, equals]
2 ->
[p, q, equals, equals]
0 -> [p, q, r, s]
1 -> [p, q, r, equals]
2 -> [p, q, equals, equals]
_ ->
# unreachable
[]
@ -115,9 +110,11 @@ unsafeToChar = \n ->
62 ->
# '+'
43
63 ->
# '/'
47
_ ->
# anything else is invalid '\u{0000}'
0

39
examples/benchmarks/Base64/Encode.roc
View file

@ -24,14 +24,10 @@ coerce = \_, x -> x
# folder : { output : List Encoder, accum : State }, U8 -> { output : List Encoder, accum : State }
folder = \{ output, accum }, char ->
when accum is
Unreachable n ->
coerce n { output, accum: Unreachable n }
None ->
{ output, accum: One char }
One a ->
{ output, accum: Two a char }
Two a b ->
{ output, accum: Three a b char }
Unreachable n -> coerce n { output, accum: Unreachable n }
None -> { output, accum: One char }
One a -> { output, accum: Two a char }
Two a b -> { output, accum: Three a b char }
Three a b c ->
when encodeCharacters a b c char is
Ok encoder ->
@ -39,6 +35,7 @@ folder = \{ output, accum }, char ->
output: List.append output encoder,
accum: None,
}
Err _ ->
{ output, accum: None }
@ -46,24 +43,18 @@ folder = \{ output, accum }, char ->
# encodeResidual : { output : List Encoder, accum : State } -> List Encoder
encodeResidual = \{ output, accum } ->
when accum is
Unreachable _ ->
output
None ->
output
One _ ->
output
Unreachable _ -> output
None -> output
One _ -> output
Two a b ->
when encodeCharacters a b equals equals is
Ok encoder ->
List.append output encoder
Err _ ->
output
Ok encoder -> List.append output encoder
Err _ -> output
Three a b c ->
when encodeCharacters a b c equals is
Ok encoder ->
List.append output encoder
Err _ ->
output
Ok encoder -> List.append output encoder
Err _ -> output
equals : U8
equals = 61
@ -146,9 +137,11 @@ isValidChar = \c ->
43 ->
# '+'
True
47 ->
# '/'
True
_ ->
False
@ -174,8 +167,10 @@ unsafeConvertChar = \key ->
43 ->
# '+'
62
47 ->
# '/'
63
_ ->
0

11
examples/benchmarks/Bytes/Decode.roc
View file

@ -11,6 +11,7 @@ decode = \bytes, @Decoder decoder ->
when decoder { bytes, cursor: 0 } is
Good _ value ->
Ok value
Bad e ->
Err e
@ -24,6 +25,7 @@ map = \@Decoder decoder, transform ->
when decoder state is
Good state1 value ->
Good state1 (transform value)
Bad e ->
Bad e
@ -36,8 +38,10 @@ map2 = \@Decoder decoder1, @Decoder decoder2, transform ->
when decoder2 state2 is
Good state3 b ->
Good state3 (transform a b)
Bad e ->
Bad e
Bad e ->
Bad e
@ -52,10 +56,13 @@ map3 = \@Decoder decoder1, @Decoder decoder2, @Decoder decoder3, transform ->
when decoder3 state3 is
Good state4 c ->
Good state4 (transform a b c)
Bad e ->
Bad e
Bad e ->
Bad e
Bad e ->
Bad e
@ -68,6 +75,7 @@ after = \@Decoder decoder, transform ->
(@Decoder decoder1) = transform value
decoder1 state1
Bad e ->
Bad e
@ -77,6 +85,7 @@ u8 = @Decoder
when List.get state.bytes state.cursor is
Ok b ->
Good { state & cursor: state.cursor + 1 } b
Err _ ->
Bad OutOfBytes
@ -94,7 +103,9 @@ loopHelp = \stepper, accum, state ->
when stepper1 state is
Good newState (Done value) ->
Good newState value
Good newState (Loop newAccum) ->
loopHelp stepper newAccum newState
Bad e ->
Bad e

25
examples/benchmarks/Bytes/Encode.roc
View file

@ -27,24 +27,18 @@ sequence = \encoders ->
getWidth : Encoder -> Nat
getWidth = \encoder ->
when encoder is
Signed8 _ ->
1
Unsigned8 _ ->
1
Signed16 _ _ ->
2
Unsigned16 _ _ ->
2
Signed8 _ -> 1
Unsigned8 _ -> 1
Signed16 _ _ -> 2
Unsigned16 _ _ -> 2
# Signed32 _ -> 4
# Unsigned32 _ -> 4
# Signed64 _ -> 8
# Unsigned64 _ -> 8
# Signed128 _ -> 16
# Unsigned128 _ -> 16
Sequence w _ ->
w
Bytes bs ->
List.len bs
Sequence w _ -> w
Bytes bs -> List.len bs
getWidths : List Encoder, Nat -> Nat
getWidths = \encoders, initial ->
@ -65,6 +59,7 @@ encodeHelp = \encoder, offset, output ->
output: List.set output offset value,
offset: offset + 1,
}
Signed8 value ->
cast : U8
cast = Num.intCast value
@ -73,6 +68,7 @@ encodeHelp = \encoder, offset, output ->
output: List.set output offset cast,
offset: offset + 1,
}
Unsigned16 endianness value ->
a : U8
a = Num.intCast (Num.shiftRightBy 8 value)
@ -86,6 +82,7 @@ encodeHelp = \encoder, offset, output ->
output
|> List.set (offset + 0) a
|> List.set (offset + 1) b
LE ->
output
|> List.set (offset + 0) b
@ -95,6 +92,7 @@ encodeHelp = \encoder, offset, output ->
output: newOutput,
offset: offset + 2,
}
Signed16 endianness value ->
a : U8
a = Num.intCast (Num.shiftRightBy 8 value)
@ -108,6 +106,7 @@ encodeHelp = \encoder, offset, output ->
output
|> List.set (offset + 0) a
|> List.set (offset + 1) b
LE ->
output
|> List.set (offset + 0) b
@ -117,6 +116,7 @@ encodeHelp = \encoder, offset, output ->
output: newOutput,
offset: offset + 1,
}
Bytes bs ->
List.walk
bs
@ -125,6 +125,7 @@ encodeHelp = \encoder, offset, output ->
offset: accum.offset + 1,
output: List.set accum.output offset byte,
}
Sequence _ encoders ->
List.walk
encoders

16
examples/benchmarks/CFold.roc
View file

@ -31,6 +31,7 @@ mkExpr = \n, v ->
when n is
0 ->
if v == 0 then Var 1 else Val v
_ ->
Add (mkExpr (n - 1) (v + 1)) (mkExpr (n - 1) (max (v - 1) 0))
@ -42,6 +43,7 @@ appendAdd = \e1, e2 ->
when e1 is
Add a1 a2 ->
Add a1 (appendAdd a2 e2)
_ ->
Add e1 e2
@ -50,6 +52,7 @@ appendMul = \e1, e2 ->
when e1 is
Mul a1 a2 ->
Mul a1 (appendMul a2 e2)
_ ->
Mul e1 e2
@ -58,10 +61,13 @@ eval = \e ->
when e is
Var _ ->
0
Val v ->
v
Add l r ->
eval l + eval r
Mul l r ->
eval l * eval r
@ -73,11 +79,13 @@ reassoc = \e ->
x2 = reassoc e2
appendAdd x1 x2
Mul e1 e2 ->
x1 = reassoc e1
x2 = reassoc e2
appendMul x1 x2
_ ->
e
@ -91,12 +99,16 @@ constFolding = \e ->
when Pair x1 x2 is
Pair (Val a) (Val b) ->
Val (a + b)
Pair (Val a) (Add (Val b) x) ->
Add (Val (a + b)) x
Pair (Val a) (Add x (Val b)) ->
Add (Val (a + b)) x
Pair y1 y2 ->
Add y1 y2
Mul e1 e2 ->
x1 = constFolding e1
x2 = constFolding e2
@ -104,11 +116,15 @@ constFolding = \e ->
when Pair x1 x2 is
Pair (Val a) (Val b) ->
Val (a * b)
Pair (Val a) (Mul (Val b) x) ->
Mul (Val (a * b)) x
Pair (Val a) (Mul x (Val b)) ->
Mul (Val (a * b)) x
Pair y1 y2 ->
Add y1 y2
_ ->
e

84
examples/benchmarks/Deriv.roc
View file

@ -28,8 +28,7 @@ State : { s : I64, f : I64, Expr -> IO Expr, m : I64, x : Expr }
nestHelp : State -> IO [Step State, Done Expr]
nestHelp = \{ s, f, m, x } ->
when m is
0 ->
Task.succeed (Done x)
0 -> Task.succeed (Done x)
_ ->
w <- Task.after (f (s - m) x)
@ -40,24 +39,21 @@ Expr : [Val I64, Var Str, Add Expr Expr, Mul Expr Expr, Pow Expr Expr, Ln Expr]
divmod : I64, I64 -> Result { div : I64, mod : I64 } [DivByZero]*
divmod = \l, r ->
when Pair (Num.divTruncChecked l r) (Num.remChecked l r) is
Pair (Ok div) (Ok mod) ->
Ok { div, mod }
_ ->
Err DivByZero
Pair (Ok div) (Ok mod) -> Ok { div, mod }
_ -> Err DivByZero
pown : I64, I64 -> I64
pown = \a, n ->
when n is
0 ->
1
1 ->
a
0 -> 1
1 -> a
_ ->
when divmod n 2 is
Ok { div, mod } ->
b = pown a div
b * b * (if mod == 0 then 1 else a)
Err DivByZero ->
-1
@ -66,18 +62,25 @@ add = \a, b ->
when Pair a b is
Pair (Val n) (Val m) ->
Val (n + m)
Pair (Val 0) f ->
f
Pair f (Val 0) ->
f
Pair f (Val n) ->
add (Val n) f
Pair (Val n) (Add (Val m) f) ->
add (Val (n + m)) f
Pair f (Add (Val n) g) ->
add (Val n) (add f g)
Pair (Add f g) h ->
add f (add g h)
Pair f g ->
Add f g
@ -86,78 +89,71 @@ mul = \a, b ->
when Pair a b is
Pair (Val n) (Val m) ->
Val (n * m)
Pair (Val 0) _ ->
Val 0
Pair _ (Val 0) ->
Val 0
Pair (Val 1) f ->
f
Pair f (Val 1) ->
f
Pair f (Val n) ->
mul (Val n) f
Pair (Val n) (Mul (Val m) f) ->
mul (Val (n * m)) f
Pair f (Mul (Val n) g) ->
mul (Val n) (mul f g)
Pair (Mul f g) h ->
mul f (mul g h)
Pair f g ->
Mul f g
pow : Expr, Expr -> Expr
pow = \a, b ->
when Pair a b is
Pair (Val m) (Val n) ->
Val (pown m n)
Pair _ (Val 0) ->
Val 1
Pair f (Val 1) ->
f
Pair (Val 0) _ ->
Val 0
Pair f g ->
Pow f g
Pair (Val m) (Val n) -> Val (pown m n)
Pair _ (Val 0) -> Val 1
Pair f (Val 1) -> f
Pair (Val 0) _ -> Val 0
Pair f g -> Pow f g
ln : Expr -> Expr
ln = \f ->
when f is
Val 1 ->
Val 0
_ ->
Ln f
Val 1 -> Val 0
_ -> Ln f
d : Str, Expr -> Expr
d = \x, expr ->
when expr is
Val _ ->
Val 0
Var y ->
if x == y then Val 1 else Val 0
Add f g ->
add (d x f) (d x g)
Mul f g ->
add (mul f (d x g)) (mul g (d x f))
Val _ -> Val 0
Var y -> if x == y then Val 1 else Val 0
Add f g -> add (d x f) (d x g)
Mul f g -> add (mul f (d x g)) (mul g (d x f))
Pow f g ->
mul (pow f g) (add (mul (mul g (d x f)) (pow f (Val (-1)))) (mul (ln f) (d x g)))
Ln f ->
mul (d x f) (pow f (Val (-1)))
count : Expr -> I64
count = \expr ->
when expr is
Val _ ->
1
Var _ ->
1
Add f g ->
count f + count g
Mul f g ->
count f + count g
Pow f g ->
count f + count g
Ln f ->
count f
Val _ -> 1
Var _ -> 1
Add f g -> count f + count g
Mul f g -> count f + count g
Pow f g -> count f + count g
Ln f -> count f
deriv : I64, Expr -> IO Expr
deriv = \i, f ->

15
examples/benchmarks/NQueens.roc
View file

@ -22,16 +22,13 @@ length = \xs -> lengthHelp xs 0
lengthHelp : ConsList a, I64 -> I64
lengthHelp = \foobar, acc ->
when foobar is
Cons _ lrest ->
lengthHelp lrest (1 + acc)
Nil ->
acc
Cons _ lrest -> lengthHelp lrest (1 + acc)
Nil -> acc
safe : I64, I64, ConsList I64 -> Bool
safe = \queen, diagonal, xs ->
when xs is
Nil ->
True
Nil -> True
Cons q t ->
queen != q && queen != q + diagonal && queen != q - diagonal && safe queen (diagonal + 1) t
@ -46,10 +43,8 @@ appendSafe = \k, soln, solns ->
extend = \n, acc, solutions ->
when solutions is
Nil ->
acc
Cons soln rest ->
extend n (appendSafe n soln acc) rest
Nil -> acc
Cons soln rest -> extend n (appendSafe n soln acc) rest
findSolutions = \n, k ->
if k == 0 then

4
examples/benchmarks/Quicksort.roc
View file

@ -42,6 +42,7 @@ partition = \low, high, initialList, order ->
when partitionHelp low low initialList order high pivot is
Pair newI newList ->
Pair newI (swap newI high newList)
Err _ ->
Pair low initialList
@ -53,8 +54,10 @@ partitionHelp = \i, j, list, order, high, pivot ->
when order value pivot is
LT | EQ ->
partitionHelp (i + 1) (j + 1) (swap i j list) order high pivot
GT ->
partitionHelp i (j + 1) list order high pivot
Err _ ->
Pair i list
else
@ -67,5 +70,6 @@ swap = \i, j, list ->
list
|> List.set i atJ
|> List.set j atI
_ ->
[]

41
examples/benchmarks/RBTreeCk.roc
View file

@ -18,8 +18,7 @@ makeMap = \freq, n ->
makeMapHelp : I64, I64, Map, ConsList Map -> ConsList Map
makeMapHelp = \freq, n, m, acc ->
when n is
0 ->
Cons m acc
0 -> Cons m acc
_ ->
powerOf10 =
n % 10 == 0
@ -36,10 +35,8 @@ makeMapHelp = \freq, n, m, acc ->
fold : (a, b, omega -> omega), Tree a b, omega -> omega
fold = \f, tree, b ->
when tree is
Leaf ->
b
Node _ l k v r ->
fold f r (f k v (fold f l b))
Leaf -> b
Node _ l k v r -> fold f r (f k v (fold f l b))
main : Task.Task {} []
main =
@ -57,6 +54,7 @@ main =
val
|> Num.toStr
|> Task.putLine
Nil ->
Task.putLine "fail"
@ -66,26 +64,21 @@ insert = \t, k, v -> if isRed t then setBlack (ins t k v) else ins t k v
setBlack : Tree a b -> Tree a b
setBlack = \tree ->
when tree is
Node _ l k v r ->
Node Black l k v r
_ ->
tree
Node _ l k v r -> Node Black l k v r
_ -> tree
isRed : Tree a b -> Bool
isRed = \tree ->
when tree is
Node Red _ _ _ _ ->
True
_ ->
False
Node Red _ _ _ _ -> True
_ -> False
lt = \x, y -> x < y
ins : Tree (Num k) v, Num k, v -> Tree (Num k) v
ins = \tree, kx, vx ->
when tree is
Leaf ->
Node Red Leaf kx vx Leaf
Leaf -> Node Red Leaf kx vx Leaf
Node Red a ky vy b ->
if lt kx ky then
Node Red (ins a kx vx) ky vy b
@ -93,6 +86,7 @@ ins = \tree, kx, vx ->
Node Red a ky vy (ins b kx vx)
else
Node Red a ky vy (ins b kx vx)
Node Black a ky vy b ->
if lt kx ky then
(if isRed a then balance1 (Node Black Leaf ky vy b) (ins a kx vx) else Node Black (ins a kx vx) ky vy b)
@ -104,31 +98,34 @@ ins = \tree, kx, vx ->
balance1 : Tree a b, Tree a b -> Tree a b
balance1 = \tree1, tree2 ->
when tree1 is
Leaf ->
Leaf
Leaf -> Leaf
Node _ _ kv vv t ->
when tree2 is
Node _ (Node Red l kx vx r1) ky vy r2 ->
Node Red (Node Black l kx vx r1) ky vy (Node Black r2 kv vv t)
Node _ l1 ky vy (Node Red l2 kx vx r) ->
Node Red (Node Black l1 ky vy l2) kx vx (Node Black r kv vv t)
Node _ l ky vy r ->
Node Black (Node Red l ky vy r) kv vv t
Leaf ->
Leaf
Leaf -> Leaf
balance2 : Tree a b, Tree a b -> Tree a b
balance2 = \tree1, tree2 ->
when tree1 is
Leaf ->
Leaf
Leaf -> Leaf
Node _ t kv vv _ ->
when tree2 is
Node _ (Node Red l kx1 vx1 r1) ky vy r2 ->
Node Red (Node Black t kv vv l) kx1 vx1 (Node Black r1 ky vy r2)
Node _ l1 ky vy (Node Red l2 kx2 vx2 r2) ->
Node Red (Node Black t kv vv l1) ky vy (Node Black l2 kx2 vx2 r2)
Node _ l ky vy r ->
Node Black t kv vv (Node Red l ky vy r)
Leaf ->
Leaf

88
examples/benchmarks/RBTreeDel.roc
View file

@ -33,8 +33,7 @@ makeMap = \n ->
makeMapHelp : I64, I64, Map -> Map
makeMapHelp = \total, n, m ->
when n is
0 ->
m
0 -> m
_ ->
n1 = n - 1
@ -54,26 +53,14 @@ makeMapHelp = \total, n, m ->
fold : (a, b, omega -> omega), Tree a b, omega -> omega
fold = \f, tree, b ->
when tree is
Leaf ->
b
Node _ l k v r ->
fold f r (f k v (fold f l b))
Leaf -> b
Node _ l k v r -> fold f r (f k v (fold f l b))
depth : Tree * * -> I64
depth = \tree ->
when tree is
Leaf ->
1
Node _ l _ _ r ->
1 + depth l + depth r
resultWithDefault : Result a e, a -> a
resultWithDefault = \res, default ->
when res is
Ok v ->
v
Err _ ->
default
Leaf -> 1
Node _ l _ _ r -> 1 + depth l + depth r
insert : Map, I64, Bool -> Map
insert = \t, k, v -> if isRed t then setBlack (ins t k v) else ins t k v
@ -81,46 +68,39 @@ insert = \t, k, v -> if isRed t then setBlack (ins t k v) else ins t k v
setBlack : Tree a b -> Tree a b
setBlack = \tree ->
when tree is
Node _ l k v r ->
Node Black l k v r
_ ->
tree
Node _ l k v r -> Node Black l k v r
_ -> tree
isRed : Tree a b -> Bool
isRed = \tree ->
when tree is
Node Red _ _ _ _ ->
True
_ ->
False
Node Red _ _ _ _ -> True
_ -> False
ins : Tree I64 Bool, I64, Bool -> Tree I64 Bool
ins = \tree, kx, vx ->
when tree is
Leaf ->
Node Red Leaf kx vx Leaf
Node Red a ky vy b ->
when Num.compare kx ky is
LT ->
Node Red (ins a kx vx) ky vy b
GT ->
Node Red a ky vy (ins b kx vx)
EQ ->
Node Red a ky vy (ins b kx vx)
LT -> Node Red (ins a kx vx) ky vy b
GT -> Node Red a ky vy (ins b kx vx)
EQ -> Node Red a ky vy (ins b kx vx)
Node Black a ky vy b ->
when Num.compare kx ky is
LT ->
when isRed a is
True ->
balanceLeft (ins a kx vx) ky vy b
False ->
Node Black (ins a kx vx) ky vy b
True -> balanceLeft (ins a kx vx) ky vy b
False -> Node Black (ins a kx vx) ky vy b
GT ->
when isRed b is
True ->
balanceRight a ky vy (ins b kx vx)
False ->
Node Black a ky vy (ins b kx vx)
True -> balanceRight a ky vy (ins b kx vx)
False -> Node Black a ky vy (ins b kx vx)
EQ ->
Node Black a kx vx b
@ -129,10 +109,13 @@ balanceLeft = \l, k, v, r ->
when l is
Leaf ->
Leaf
Node _ (Node Red lx kx vx rx) ky vy ry ->
Node Red (Node Black lx kx vx rx) ky vy (Node Black ry k v r)
Node _ ly ky vy (Node Red lx kx vx rx) ->
Node Red (Node Black ly ky vy lx) kx vx (Node Black rx k v r)
Node _ lx kx vx rx ->
Node Black (Node Red lx kx vx rx) k v r
@ -141,20 +124,21 @@ balanceRight = \l, k, v, r ->
when r is
Leaf ->
Leaf
Node _ (Node Red lx kx vx rx) ky vy ry ->
Node Red (Node Black l k v lx) kx vx (Node Black rx ky vy ry)
Node _ lx kx vx (Node Red ly ky vy ry) ->
Node Red (Node Black l k v lx) kx vx (Node Black ly ky vy ry)
Node _ lx kx vx rx ->
Node Black l k v (Node Red lx kx vx rx)
isBlack : Color -> Bool
isBlack = \c ->
when c is
Black ->
True
Red ->
False
Black -> True
Red -> False
Del a b : [Del (Tree a b) Bool]
@ -163,6 +147,7 @@ setRed = \t ->
when t is
Node _ l k v r ->
Node Red l k v r
_ ->
t
@ -171,6 +156,7 @@ makeBlack = \t ->
when t is
Node Red l k v r ->
Del (Node Black l k v r) False
_ ->
Del t True
@ -178,8 +164,10 @@ rebalanceLeft = \c, l, k, v, r ->
when l is
Node Black _ _ _ _ ->
Del (balanceLeft (setRed l) k v r) (isBlack c)
Node Red lx kx vx rx ->
Del (Node Black lx kx vx (balanceLeft (setRed rx) k v r)) False
_ ->
boom "unreachable"
@ -187,8 +175,10 @@ rebalanceRight = \c, l, k, v, r ->
when r is
Node Black _ _ _ _ ->
Del (balanceRight l k v (setRed r)) (isBlack c)
Node Red lx kx vx rx ->
Del (Node Black (balanceRight l k v (setRed lx)) kx vx rx) False
_ ->
boom "unreachable"
@ -198,16 +188,21 @@ delMin = \t ->
when r is
Leaf ->
Delmin (Del Leaf True) k v
_ ->
Delmin (Del (setBlack r) False) k v
Node Red Leaf k v r ->
Delmin (Del r False) k v
Node c l k v r ->
when delMin l is
Delmin (Del lx True) kx vx ->
Delmin (rebalanceRight c lx k v r) kx vx
Delmin (Del lx False) kx vx ->
Delmin (Del (Node c lx k v r) False) kx vx
Leaf ->
Delmin (Del t False) 0 False
@ -222,26 +217,31 @@ del = \t, k ->
when t is
Leaf ->
Del Leaf False
Node cx lx kx vx rx ->
if (k < kx) then
when del lx k is
Del ly True ->
rebalanceRight cx ly kx vx rx
Del ly False ->
Del (Node cx ly kx vx rx) False
else if (k > kx) then
when del rx k is
Del ry True ->
rebalanceLeft cx lx kx vx ry
Del ry False ->
Del (Node cx lx kx vx ry) False
else
when rx is
Leaf ->
if isBlack cx then makeBlack lx else Del lx False
Node _ _ _ _ _ ->
when delMin rx is
Delmin (Del ry True) ky vy ->
rebalanceLeft cx lx ky vy ry
Delmin (Del ry False) ky vy ->
Del (Node cx lx ky vy ry) False

29
examples/benchmarks/RBTreeInsert.roc
View file

@ -18,8 +18,7 @@ show = \tree -> showRBTree tree Num.toStr (\{} -> "{}")
showRBTree : RedBlackTree k v, (k -> Str), (v -> Str) -> Str
showRBTree = \tree, showKey, showValue ->
when tree is
Empty ->
"Empty"
Empty -> "Empty"
Node color key value left right ->
sColor = showColor color
sKey = showKey key
@ -34,6 +33,7 @@ nodeInParens = \tree, showKey, showValue ->
when tree is
Empty ->
showRBTree tree showKey showValue
Node _ _ _ _ _ ->
inner = showRBTree tree showKey showValue
@ -42,10 +42,8 @@ nodeInParens = \tree, showKey, showValue ->
showColor : NodeColor -> Str
showColor = \color ->
when color is
Red ->
"Red"
Black ->
"Black"
Red -> "Red"
Black -> "Black"
NodeColor : [Red, Black]
@ -56,10 +54,8 @@ Key k : Num k
insert : Key k, v, RedBlackTree (Key k) v -> RedBlackTree (Key k) v
insert = \key, value, dict ->
when insertHelp key value dict is
Node Red k v l r ->
Node Black k v l r
x ->
x
Node Red k v l r -> Node Black k v l r
x -> x
insertHelp : Key k, v, RedBlackTree (Key k) v -> RedBlackTree (Key k) v
insertHelp = \key, value, dict ->
@ -68,14 +64,12 @@ insertHelp = \key, value, dict ->
# New nodes are always red. If it violates the rules, it will be fixed
# when balancing.
Node Red key value Empty Empty
Node nColor nKey nValue nLeft nRight ->
when Num.compare key nKey is
LT ->
balance nColor nKey nValue (insertHelp key value nLeft) nRight
EQ ->
Node nColor nKey value nLeft nRight
GT ->
balance nColor nKey nValue nLeft (insertHelp key value nRight)
LT -> balance nColor nKey nValue (insertHelp key value nLeft) nRight
EQ -> Node nColor nKey value nLeft nRight
GT -> balance nColor nKey nValue nLeft (insertHelp key value nRight)
balance : NodeColor, k, v, RedBlackTree k v, RedBlackTree k v -> RedBlackTree k v
balance = \color, key, value, left, right ->
@ -89,8 +83,10 @@ balance = \color, key, value, left, right ->
value
(Node Black lK lV lLeft lRight)
(Node Black rK rV rLeft rRight)
_ ->
Node color rK rV (Node Red key value left rLeft) rRight
_ ->
when left is
Node Red lK lV (Node Red llK llV llLeft llRight) lRight ->
@ -100,5 +96,6 @@ balance = \color, key, value, left, right ->
lV
(Node Black llK llV llLeft llRight)
(Node Black key value lRight right)
_ ->
Node color key value left right

24
examples/benchmarks/TestAStar.roc
View file

@ -18,10 +18,8 @@ main =
showBool : Bool -> Str
showBool = \b ->
when b is
True ->
"True"
False ->
"False"
True -> "True"
False -> "False"
test1 : Bool
test1 =
@ -32,20 +30,14 @@ example1 =
step : I64 -> Set I64
step = \n ->
when n is
1 ->
Set.fromList [2, 3]
2 ->
Set.fromList [4]
3 ->
Set.fromList [4]
_ ->
Set.fromList []
1 -> Set.fromList [2, 3]
2 -> Set.fromList [4]
3 -> Set.fromList [4]
_ -> Set.fromList []
cost : I64, I64 -> F64
cost = \_, _ -> 1
when AStar.findPath cost step 1 4 is
Ok path ->
path
Err _ ->
[]
Ok path -> path
Err _ -> []

9
examples/benchmarks/TestBase64.roc
View file

@ -8,14 +8,11 @@ IO a : Task.Task a []
main : IO {}
main =
when Base64.fromBytes (Str.toUtf8 "Hello World") is
Err _ ->
Task.putLine "sadness"
Err _ -> Task.putLine "sadness"
Ok encoded ->
Task.after
(Task.putLine (Str.concat "encoded: " encoded))
\_ ->
when Base64.toStr encoded is
Ok decoded ->
Task.putLine (Str.concat "decoded: " decoded)
Err _ ->
Task.putLine "sadness"
Ok decoded -> Task.putLine (Str.concat "decoded: " decoded)
Err _ -> Task.putLine "sadness"

28
examples/benchmarks/platform/Task.roc
View file

@ -11,10 +11,8 @@ forever = \task ->
|> Effect.map
\res ->
when res is
Ok _ ->
Step {}
Err e ->
Done (Err e)
Ok _ -> Step {}
Err e -> Done (Err e)
Effect.loop {} looper
@ -25,12 +23,9 @@ loop = \state, step ->
|> Effect.map
\res ->
when res is
Ok (Step newState) ->
Step newState
Ok (Done result) ->
Done (Ok result)
Err e ->
Done (Err e)
Ok (Step newState) -> Step newState
Ok (Done result) -> Done (Ok result)
Err e -> Done (Err e)
Effect.loop state looper
@ -48,10 +43,8 @@ after = \effect, transform ->
effect
\result ->
when result is
Ok a ->
transform a
Err err ->
Task.fail err
Ok a -> transform a
Err err -> Task.fail err
map : Task a err, (a -> b) -> Task b err
map = \effect, transform ->
@ -59,10 +52,8 @@ map = \effect, transform ->
effect
\result ->
when result is
Ok a ->
Ok (transform a)
Err err ->
Err err
Ok a -> Ok (transform a)
Err err -> Err err
putLine : Str -> Task {} *
putLine = \line -> Effect.map (Effect.putLine line) (\_ -> Ok {})
@ -82,5 +73,6 @@ getInt =
# # B -> Task.fail IOError
# _ ->
Task.succeed -1
False ->
Task.succeed value

4
examples/breakout/breakout.roc
View file

@ -48,12 +48,16 @@ update = \model, event ->
when event is
Resize size ->
{ model & width: size.width, height: size.height }
KeyDown Left ->
{ model & paddleX: model.paddleX - paddleSpeed }
KeyDown Right ->
{ model & paddleX: model.paddleX + paddleSpeed }
Tick _ ->
tick model
_ ->
model

6
examples/breakout/platform/Action.roc
View file

@ -13,7 +13,5 @@ update = Update
map : Action a, (a -> b) -> Action b
map = \action, transform ->
when action is
None ->
None
Update state ->
Update (transform state)
None -> None
Update state -> Update (transform state)

13
examples/breakout/platform/Elem.roc
View file

@ -53,6 +53,7 @@ lazy = \state, render ->
# same as the cached one, then we can return exactly
# what we had cached.
cached
_ ->
# Either the state changed or else we didn't have a
# cached value to use. Either way, we need to render
@ -79,10 +80,13 @@ translate = \child, toChild, toParent ->
when child is
Text str ->
Text str
Col elems ->
Col (List.map elems \elem -> translate elem toChild toParent)
Row elems ->
Row (List.map elems \elem -> translate elem toChild toParent)
Button config label ->
onPress = \parentState, event ->
toChild parentState
@ -90,6 +94,7 @@ translate = \child, toChild, toParent ->
|> Action.map \c -> toParent parentState c
Button { onPress } (translate label toChild toParent)
Lazy renderChild ->
Lazy
\parentState ->
@ -99,6 +104,7 @@ translate = \child, toChild, toParent ->
elem: translate toChild toParent newChild,
state: toParent parentState state,
}
None ->
None
@ -147,10 +153,13 @@ translateOrDrop = \child, toChild, toParent ->
when child is
Text str ->
Text str
Col elems ->
Col (List.map elems \elem -> translateOrDrop elem toChild toParent)
Row elems ->
Row (List.map elems \elem -> translateOrDrop elem toChild toParent)
Button config label ->
onPress = \parentState, event ->
when toChild parentState is
@ -158,12 +167,14 @@ translateOrDrop = \child, toChild, toParent ->
newChild
|> config.onPress event
|> Action.map \c -> toParent parentState c
Err _ ->
# The child was removed from the list before this onPress handler resolved.
# (For example, by a previous event handler that fired simultaneously.)
Action.none
Button { onPress } (translateOrDrop label toChild toParent)
Lazy childState renderChild ->
Lazy
(toParent childState)
@ -172,8 +183,10 @@ translateOrDrop = \child, toChild, toParent ->
Ok newChild ->
renderChild newChild
|> translateOrDrop toChild toParent
Err _ ->
None
# I don't think this should ever happen in practice.
None ->
None

36
examples/false-interpreter/Context.roc
View file

@ -26,36 +26,27 @@ popStack = \ctx ->
poppedCtx = { ctx & stack: List.dropAt ctx.stack (List.len ctx.stack - 1) }
Ok (T poppedCtx val)
Err ListWasEmpty ->
Err EmptyStack
toStrData : Data -> Str
toStrData = \data ->
when data is
Lambda _ ->
"[]"
Number n ->
Num.toStr (Num.intCast n)
Var v ->
Variable.toStr v
Lambda _ -> "[]"
Number n -> Num.toStr (Num.intCast n)
Var v -> Variable.toStr v
toStrState : State -> Str
toStrState = \state ->
when state is
Executing ->
"Executing"
InComment ->
"InComment"
InString _ ->
"InString"
InNumber _ ->
"InNumber"
InLambda _ _ ->
"InLambda"
InSpecialChar ->
"InSpecialChar"
LoadChar ->
"LoadChar"
Executing -> "Executing"
InComment -> "InComment"
InString _ -> "InString"
InNumber _ -> "InNumber"
InLambda _ _ -> "InLambda"
InSpecialChar -> "InSpecialChar"
LoadChar -> "LoadChar"
toStr : Context -> Str
toStr = \{ scopes, stack, state, vars } ->
@ -81,6 +72,7 @@ getChar = \ctx ->
Ok scope ->
(T val newScope) <- Task.await (getCharScope scope)
Task.succeed (T val { ctx & scopes: List.set ctx.scopes (List.len ctx.scopes - 1) newScope })
Err ListWasEmpty ->
Task.fail NoScope
@ -89,6 +81,7 @@ getCharScope = \scope ->
when List.get scope.buf scope.index is
Ok val ->
Task.succeed (T val { scope & index: scope.index + 1 })
Err OutOfBounds ->
when scope.data is
Some h ->
@ -97,8 +90,10 @@ getCharScope = \scope ->
Ok val ->
# This starts at 1 because the first character is already being returned.
Task.succeed (T val { scope & buf: bytes, index: 1 })
Err ListWasEmpty ->
Task.fail EndOfData
None ->
Task.fail EndOfData
@ -107,5 +102,6 @@ inWhileScope = \ctx ->
when List.last ctx.scopes is
Ok scope ->
scope.whileInfo != None
Err ListWasEmpty ->
False

126
examples/false-interpreter/False.roc
View file

@ -30,28 +30,40 @@ interpretFile = \filename ->
when result is
Ok _ ->
Task.succeed {}
Err BadUtf8 ->
Task.fail (StringErr "Failed to convert string from Utf8 bytes")
Err DivByZero ->
Task.fail (StringErr "Division by zero")
Err EmptyStack ->
Task.fail (StringErr "Tried to pop a value off of the stack when it was empty")
Err InvalidBooleanValue ->
Task.fail (StringErr "Ran into an invalid boolean that was neither false (0) or true (-1)")
Err (InvalidChar char) ->
Task.fail (StringErr "Ran into an invalid character with ascii code: \(char)")
Err MaxInputNumber ->
Task.fail (StringErr "Like the original false compiler, the max input number is 320,000")
Err NoLambdaOnStack ->
Task.fail (StringErr "Tried to run a lambda when no lambda was on the stack")
Err NoNumberOnStack ->
Task.fail (StringErr "Tried to run a number when no number was on the stack")
Err NoVariableOnStack ->
Task.fail (StringErr "Tried to load a variable when no variable was on the stack")
Err NoScope ->
Task.fail (StringErr "Tried to run code when not in any scope")
Err OutOfBounds ->
Task.fail (StringErr "Tried to load from an offset that was outside of the stack")
Err UnexpectedEndOfData ->
Task.fail (StringErr "Hit end of data while still parsing something")
@ -97,17 +109,22 @@ interpretCtxLoop = \ctx ->
newScope = { scope & whileInfo: Some { state: InBody, body, cond } }
Task.succeed (Step { popCtx & scopes: List.append (List.set ctx.scopes last newScope) { data: None, buf: body, index: 0, whileInfo: None } })
Err e ->
Task.fail e
Some { state: InBody, body, cond } ->
# Just rand the body. Run the condition again.
newScope = { scope & whileInfo: Some { state: InCond, body, cond } }
Task.succeed (Step { ctx & scopes: List.append (List.set ctx.scopes last newScope) { data: None, buf: cond, index: 0, whileInfo: None } })
None ->
Task.fail NoScope
Err OutOfBounds ->
Task.fail NoScope
Executing ->
# {} <- Task.await (Stdout.line (Context.toStr ctx))
result <- Task.attempt (Context.getChar ctx)
@ -115,8 +132,10 @@ interpretCtxLoop = \ctx ->
Ok (T val newCtx) ->
execCtx <- Task.await (stepExecCtx newCtx val)
Task.succeed (Step execCtx)
Err NoScope ->
Task.fail NoScope
Err EndOfData ->
# Computation complete for this scope.
# Drop a scope.
@ -127,6 +146,7 @@ interpretCtxLoop = \ctx ->
Task.succeed (Done dropCtx)
else
Task.succeed (Step dropCtx)
InComment ->
result <- Task.attempt (Context.getChar ctx)
when result is
@ -136,10 +156,13 @@ interpretCtxLoop = \ctx ->
Task.succeed (Step { newCtx & state: Executing })
else
Task.succeed (Step { newCtx & state: InComment })
Err NoScope ->
Task.fail NoScope
Err EndOfData ->
Task.fail UnexpectedEndOfData
InNumber accum ->
result <- Task.attempt (Context.getChar ctx)
when result is
@ -158,10 +181,13 @@ interpretCtxLoop = \ctx ->
execCtx <- Task.await (stepExecCtx { pushCtx & state: Executing } val)
Task.succeed (Step execCtx)
Err NoScope ->
Task.fail NoScope
Err EndOfData ->
Task.fail UnexpectedEndOfData
InString bytes ->
result <- Task.attempt (Context.getChar ctx)
when result is
@ -172,14 +198,18 @@ interpretCtxLoop = \ctx ->
Ok str ->
{} <- Task.await (Stdout.raw str)
Task.succeed (Step { newCtx & state: Executing })
Err _ ->
Task.fail BadUtf8
else
Task.succeed (Step { newCtx & state: InString (List.append bytes val) })
Err NoScope ->
Task.fail NoScope
Err EndOfData ->
Task.fail UnexpectedEndOfData
InLambda depth bytes ->
result <- Task.attempt (Context.getChar ctx)
when result is
@ -197,10 +227,13 @@ interpretCtxLoop = \ctx ->
Task.succeed (Step { newCtx & state: InLambda (depth - 1) (List.append bytes val) })
else
Task.succeed (Step { newCtx & state: InLambda depth (List.append bytes val) })
Err NoScope ->
Task.fail NoScope
Err EndOfData ->
Task.fail UnexpectedEndOfData
InSpecialChar ->
result <- Task.attempt (Context.getChar { ctx & state: Executing })
when result is
@ -218,28 +251,33 @@ interpretCtxLoop = \ctx ->
Err OutOfBounds
when result2 is
Ok a ->
Task.succeed (Step a)
Err e ->
Task.fail e
Ok a -> Task.succeed (Step a)
Err e -> Task.fail e
Ok (T 0x9F newCtx) ->
# This is supposed to flush io buffers. We don't buffer, so it does nothing
Task.succeed (Step newCtx)
Ok (T x _) ->
data = Num.toStr (Num.intCast x)
Task.fail (InvalidChar data)
Err NoScope ->
Task.fail NoScope
Err EndOfData ->
Task.fail UnexpectedEndOfData
LoadChar ->
result <- Task.attempt (Context.getChar { ctx & state: Executing })
when result is
Ok (T x newCtx) ->
Task.succeed (Step (Context.pushStack newCtx (Number (Num.intCast x))))
Err NoScope ->
Task.fail NoScope
Err EndOfData ->
Task.fail UnexpectedEndOfData
@ -254,6 +292,7 @@ stepExecCtx = \ctx, char ->
(T popCtx bytes) <- Result.after (popLambda ctx)
Ok { popCtx & scopes: List.append popCtx.scopes { data: None, buf: bytes, index: 0, whileInfo: None } }
)
0x3F ->
# `?` if
Task.fromResult
@ -265,6 +304,7 @@ stepExecCtx = \ctx, char ->
else
Ok { popCtx2 & scopes: List.append popCtx2.scopes { data: None, buf: bytes, index: 0, whileInfo: None } }
)
0x23 ->
# `#` while
Task.fromResult
@ -280,26 +320,26 @@ stepExecCtx = \ctx, char ->
# push a scope to execute the condition.
Ok { popCtx2 & scopes: List.append scopes { data: None, buf: cond, index: 0, whileInfo: None } }
Err OutOfBounds ->
Err NoScope
)
0x24 ->
# `$` dup
# Switching this to List.last and changing the error to ListWasEmpty leads to a compiler bug.
# Complains about the types eq not matching.
when List.get ctx.stack (List.len ctx.stack - 1) is
Ok dupItem ->
Task.succeed (Context.pushStack ctx dupItem)
Err OutOfBounds ->
Task.fail EmptyStack
Ok dupItem -> Task.succeed (Context.pushStack ctx dupItem)
Err OutOfBounds -> Task.fail EmptyStack
0x25 ->
# `%` drop
when Context.popStack ctx is
# Dropping with an empty stack, all results here are fine
Ok (T popCtx _) ->
Task.succeed popCtx
Err _ ->
Task.succeed ctx
Ok (T popCtx _) -> Task.succeed popCtx
Err _ -> Task.succeed ctx
0x5C ->
# `\` swap
result2 =
@ -310,9 +350,11 @@ stepExecCtx = \ctx, char ->
when result2 is
Ok a ->
Task.succeed a
# Being explicit with error type is required to stop the need to propogate the error parameters to Context.popStack
Err EmptyStack ->
Task.fail EmptyStack
0x40 ->
# `@` rot
result2 =
@ -324,14 +366,17 @@ stepExecCtx = \ctx, char ->
when result2 is
Ok a ->
Task.succeed a
# Being explicit with error type is required to stop the need to propogate the error parameters to Context.popStack
Err EmptyStack ->
Task.fail EmptyStack
0xC3 ->
# `ø` pick or `ß` flush
# these are actually 2 bytes, 0xC3 0xB8 or 0xC3 0x9F
# requires special parsing
Task.succeed { ctx & state: InSpecialChar }
0x4F ->
# `O` also treat this as pick for easier script writing
Task.fromResult
@ -347,22 +392,28 @@ stepExecCtx = \ctx, char ->
else
Err OutOfBounds
)
0x42 ->
# `B` also treat this as flush for easier script writing
# This is supposed to flush io buffers. We don't buffer, so it does nothing
Task.succeed ctx
0x27 ->
# `'` load next char
Task.succeed { ctx & state: LoadChar }
0x2B ->
# `+` add
Task.fromResult (binaryOp ctx Num.addWrap)
0x2D ->
# `-` sub
Task.fromResult (binaryOp ctx Num.subWrap)
0x2A ->
# `*` mul
Task.fromResult (binaryOp ctx Num.mulWrap)
0x2F ->
# `/` div
# Due to possible division by zero error, this must be handled specially.
@ -373,12 +424,15 @@ stepExecCtx = \ctx, char ->
res <- Result.after (Num.divTruncChecked numL numR)
Ok (Context.pushStack popCtx2 (Number res))
)
0x26 ->
# `&` bitwise and
Task.fromResult (binaryOp ctx Num.bitwiseAnd)
0x7C ->
# `|` bitwise or
Task.fromResult (binaryOp ctx Num.bitwiseOr)
0x3D ->
# `=` equals
Task.fromResult
@ -389,6 +443,7 @@ stepExecCtx = \ctx, char ->
else
0
)
0x3E ->
# `>` greater than
Task.fromResult
@ -399,13 +454,15 @@ stepExecCtx = \ctx, char ->
else
0
)
0x5F ->
# `_` negate
Task.fromResult (unaryOp ctx Num.neg)
0x7E ->
# `~` bitwise not
Task.fromResult (unaryOp ctx (\x -> Num.bitwiseXor x -1))
# xor with -1 should be bitwise not
Task.fromResult (unaryOp ctx (\x -> Num.bitwiseXor x -1)) # xor with -1 should be bitwise not
0x2C ->
# `,` write char
when popNumber ctx is
@ -414,18 +471,23 @@ stepExecCtx = \ctx, char ->
Ok str ->
{} <- Task.await (Stdout.raw str)
Task.succeed popCtx
Err _ ->
Task.fail BadUtf8
Err e ->
Task.fail e
0x2E ->
# `.` write int
when popNumber ctx is
Ok (T popCtx num) ->
{} <- Task.await (Stdout.raw (Num.toStr (Num.intCast num)))
Task.succeed popCtx
Err e ->
Task.fail e
0x5E ->
# `^` read char as int
in <- Task.await Stdin.char
@ -434,6 +496,7 @@ stepExecCtx = \ctx, char ->
Task.succeed (Context.pushStack ctx (Number -1))
else
Task.succeed (Context.pushStack ctx (Number (Num.intCast in)))
0x3A ->
# `:` store to variable
Task.fromResult
@ -443,6 +506,7 @@ stepExecCtx = \ctx, char ->
(T popCtx2 n1) <- Result.after (Result.mapErr (Context.popStack popCtx1) (\EmptyStack -> EmptyStack))
Ok { popCtx2 & vars: List.set popCtx2.vars (Variable.toIndex var) n1 }
)
0x3B ->
# `;` load from variable
Task.fromResult
@ -451,25 +515,32 @@ stepExecCtx = \ctx, char ->
elem <- Result.after (List.get popCtx.vars (Variable.toIndex var))
Ok (Context.pushStack popCtx elem)
)
0x22 ->
# `"` string start
Task.succeed { ctx & state: InString [] }
0x5B ->
# `"` string start
Task.succeed { ctx & state: InLambda 0 [] }
0x7B ->
# `{` comment start
Task.succeed { ctx & state: InComment }
x if isDigit x ->
# number start
Task.succeed { ctx & state: InNumber (Num.intCast (x - 0x30)) }
x if isWhitespace x ->
Task.succeed ctx
x ->
when Variable.fromUtf8 x is
# letters are variable names
Ok var ->
Task.succeed (Context.pushStack ctx (Var var))
Err _ ->
data = Num.toStr (Num.intCast x)
@ -489,29 +560,20 @@ binaryOp = \ctx, op ->
popNumber : Context -> Result [T Context I32] InterpreterErrors
popNumber = \ctx ->
when Context.popStack ctx is
Ok (T popCtx (Number num)) ->
Ok (T popCtx num)
Ok _ ->
Err (NoNumberOnStack)
Err EmptyStack ->
Err EmptyStack
Ok (T popCtx (Number num)) -> Ok (T popCtx num)
Ok _ -> Err (NoNumberOnStack)
Err EmptyStack -> Err EmptyStack
popLambda : Context -> Result [T Context (List U8)] InterpreterErrors
popLambda = \ctx ->
when Context.popStack ctx is
Ok (T popCtx (Lambda bytes)) ->
Ok (T popCtx bytes)
Ok _ ->
Err NoLambdaOnStack
Err EmptyStack ->
Err EmptyStack
Ok (T popCtx (Lambda bytes)) -> Ok (T popCtx bytes)
Ok _ -> Err NoLambdaOnStack
Err EmptyStack -> Err EmptyStack
popVariable : Context -> Result [T Context Variable] InterpreterErrors
popVariable = \ctx ->
when Context.popStack ctx is
Ok (T popCtx (Var var)) ->
Ok (T popCtx var)
Ok _ ->
Err NoVariableOnStack
Err EmptyStack ->
Err EmptyStack
Ok (T popCtx (Var var)) -> Ok (T popCtx var)
Ok _ -> Err NoVariableOnStack
Err EmptyStack -> Err EmptyStack

6
examples/false-interpreter/Variable.roc
View file

@ -15,10 +15,8 @@ totalCount =
toStr : Variable -> Str
toStr = \@Variable char ->
when Str.fromUtf8 [char] is
Ok str ->
str
_ ->
"_"
Ok str -> str
_ -> "_"
fromUtf8 : U8 -> Result Variable [InvalidVariableUtf8]
fromUtf8 = \char ->

39
examples/false-interpreter/platform/Task.roc
View file

@ -11,12 +11,9 @@ loop = \state, step ->
|> Effect.map
\res ->
when res is
Ok (Step newState) ->
Step newState
Ok (Done result) ->
Done (Ok result)
Err e ->
Done (Err e)
Ok (Step newState) -> Step newState
Ok (Done result) -> Done (Ok result)
Err e -> Done (Err e)
Effect.loop state looper
@ -31,10 +28,8 @@ fail = \val ->
fromResult : Result a e -> Task a e
fromResult = \result ->
when result is
Ok a ->
succeed a
Err e ->
fail e
Ok a -> succeed a
Err e -> fail e
attempt : Task a b, (Result a b -> Task c d) -> Task c d
attempt = \effect, transform ->
@ -42,10 +37,8 @@ attempt = \effect, transform ->
effect
\result ->
when result is
Ok ok ->
transform (Ok ok)
Err err ->
transform (Err err)
Ok ok -> transform (Ok ok)
Err err -> transform (Err err)
await : Task a err, (a -> Task b err) -> Task b err
await = \effect, transform ->
@ -53,10 +46,8 @@ await = \effect, transform ->
effect
\result ->
when result is
Ok a ->
transform a
Err err ->
Task.fail err
Ok a -> transform a
Err err -> Task.fail err
onFail : Task ok a, (a -> Task ok b) -> Task ok b
onFail = \effect, transform ->
@ -64,10 +55,8 @@ onFail = \effect, transform ->
effect
\result ->
when result is
Ok a ->
Task.succeed a
Err err ->
transform err
Ok a -> Task.succeed a
Err err -> transform err
map : Task a err, (a -> b) -> Task b err
map = \effect, transform ->
@ -75,7 +64,5 @@ map = \effect, transform ->
effect
\result ->
when result is
Ok a ->
Task.succeed (transform a)
Err err ->
Task.fail err
Ok a -> Task.succeed (transform a)
Err err -> Task.fail err

6
examples/gui/platform/Action.roc
View file

@ -13,7 +13,5 @@ update = Update
map : Action a, (a -> b) -> Action b
map = \action, transform ->
when action is
None ->
None
Update state ->
Update (transform state)
None -> None
Update state -> Update (transform state)

13
examples/gui/platform/Elem.roc
View file

@ -53,6 +53,7 @@ lazy = \state, render ->
# same as the cached one, then we can return exactly
# what we had cached.
cached
_ ->
# Either the state changed or else we didn't have a
# cached value to use. Either way, we need to render
@ -79,10 +80,13 @@ translate = \child, toChild, toParent ->
when child is
Text str ->
Text str
Col elems ->
Col (List.map elems \elem -> translate elem toChild toParent)
Row elems ->
Row (List.map elems \elem -> translate elem toChild toParent)
Button config label ->
onPress = \parentState, event ->
toChild parentState
@ -90,6 +94,7 @@ translate = \child, toChild, toParent ->
|> Action.map \c -> toParent parentState c
Button { onPress } (translate label toChild toParent)
Lazy renderChild ->
Lazy
\parentState ->
@ -99,6 +104,7 @@ translate = \child, toChild, toParent ->
elem: translate toChild toParent newChild,
state: toParent parentState state,
}
None ->
None
@ -147,10 +153,13 @@ translateOrDrop = \child, toChild, toParent ->
when child is
Text str ->
Text str
Col elems ->
Col (List.map elems \elem -> translateOrDrop elem toChild toParent)
Row elems ->
Row (List.map elems \elem -> translateOrDrop elem toChild toParent)
Button config label ->
onPress = \parentState, event ->
when toChild parentState is
@ -158,12 +167,14 @@ translateOrDrop = \child, toChild, toParent ->
newChild
|> config.onPress event
|> Action.map \c -> toParent parentState c
Err _ ->
# The child was removed from the list before this onPress handler resolved.
# (For example, by a previous event handler that fired simultaneously.)
Action.none
Button { onPress } (translateOrDrop label toChild toParent)
Lazy childState renderChild ->
Lazy
(toParent childState)
@ -172,8 +183,10 @@ translateOrDrop = \child, toChild, toParent ->
Ok newChild ->
renderChild newChild
|> translateOrDrop toChild toParent
Err _ ->
None
# I don't think this should ever happen in practice.
None ->
None

11
examples/interactive/cli-platform/Cargo.lock generated
View file

@ -2,6 +2,12 @@
# It is not intended for manual editing.
version = 3
[[package]]
name = "arrayvec"
version = "0.7.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "8da52d66c7071e2e3fa2a1e5c6d088fec47b593032b254f5e980de8ea54454d6"
[[package]]
name = "host"
version = "0.1.0"
@ -20,11 +26,12 @@ checksum = "a60553f9a9e039a333b4e9b20573b9e9b9c0bb3a11e201ccc48ef4283456d673"
name = "roc_std"
version = "0.1.0"
dependencies = [
"arrayvec",
"static_assertions",
]
[[package]]
name = "static_assertions"
version = "0.1.1"
version = "1.1.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "f406d6ee68db6796e11ffd7b4d171864c58b7451e79ef9460ea33c287a1f89a7"
checksum = "a2eb9349b6444b326872e140eb1cf5e7c522154d69e7a0ffb0fb81c06b37543f"

431
examples/interactive/cli-platform/Url.roc Normal file
View file

@ -0,0 +1,431 @@
interface Url
exposes [
Url,
append,
fromStr,
toStr,
appendParam,
hasQuery,
hasFragment,
query,
fragment,
reserve,
withQuery,
withFragment,
]
imports []
## A [Uniform Resource Locator](https://en.wikipedia.org/wiki/URL).
##
## It could be an absolute address, such as `https://roc-lang.org/authors` or
## a relative address, such as `/authors`. You can create one using [Url.fromStr].
Url := Str
## Reserve the given number of bytes as extra capacity. This can avoid reallocation
## when calling multiple functions that increase the length of the URL.
##
## Url.fromStr "https://example.com"
## |> Url.reserve 50 # We're about to add 50 UTF-8 bytes to it
## |> Url.append "stuff"
## |> Url.appendParam "café" "du Monde"
## |> Url.appendParam "email" "hi@example.com"
## # https://example.com/stuff?caf%C3%A9=du%20Monde&email=hi%40example.com
##
## The [Str.countUtf8Bytes] function can be helpful in finding out how many bytes to reserve.
##
## There is no `Url.withCapacity` because it's better to reserve extra capacity
## on a [Str] first, and then pass that string to [Url.fromStr]. This function will make use
## of the extra capacity.
reserve : Url, Nat -> Url
reserve = \@Url str, cap ->
@Url (Str.reserve str cap)
## Create a [Url] without validating or [percent-encoding](https://en.wikipedia.org/wiki/Percent-encoding)
## anything.
##
## Url.fromStr "https://example.com#stuff"
## # https://example.com#stuff
##
## URLs can be absolute, like `https://example.com`, or they can be relative, like `/blah`.
##
## Url.fromStr "/this/is#relative"
## # /this/is#relative
##
## Since nothing is validated, this can return invalid URLs.
##
## Url.fromStr "https://this is not a valid URL, not at all!"
## # https://this is not a valid URL, not at all!
##
## Naturally, passing invalid URLs to functions that need valid ones will tend to result in errors.
fromStr : Str -> Url
fromStr = \str -> @Url str
## Return a [Str] representation of this URL.
##
## Url.fromStr "https://example.com"
## |> Url.append "two words"
## |> Url.toStr
## # "https://example.com/two%20words"
toStr : Url -> Str
toStr = \@Url str -> str
## [Percent-encodes](https://en.wikipedia.org/wiki/Percent-encoding) a
## [path component](https://en.wikipedia.org/wiki/Uniform_Resource_Identifier#Syntax)
## and appends to the end of the URL's path.
##
## Url.fromStr "https://example.com"
## |> Url.append "some stuff"
## # https://example.com/some%20stuff
##
## This will be appended before any queries and fragments.
##
## Url.fromStr "https://example.com?search=blah#fragment"
## |> Url.append "stuff"
## # https://example.com/stuff?search=blah#fragment
##
## If the given path string begins with `"/"` and the URL already ends with `"/"`, one
## will be ignored. This avoids turning a single slash into a double slash.
##
## Url.fromStr "https://example.com/things/"
## |> Url.append "/stuff/"
## |> Url.append "/more/etc/"
## # https://example.com/things/stuff/more/etc/"
##
## If either the given URL or the given string is empty, no `"/"` will be added.
##
## Url.fromStr "https://example.com/things"
## |> Url.append ""
## # https://example.com/things
append : Url, Str -> Url
append = \@Url urlStr, suffixUnencoded ->
suffix = percentEncode suffixUnencoded
when Str.splitFirst urlStr "?" is
Ok { before, after } ->
bytes =
Str.countUtf8Bytes before
+ 1 # for "/"
+ Str.countUtf8Bytes suffix
+ 1 # for "?"
+ Str.countUtf8Bytes after
before
|> Str.reserve bytes
|> appendHelp suffix
|> Str.concat "?"
|> Str.concat after
|> @Url
Err NotFound ->
# There wasn't a query, but there might still be a fragment
when Str.splitFirst urlStr "#" is
Ok { before, after } ->
bytes =
Str.countUtf8Bytes before
+ 1 # for "/"
+ Str.countUtf8Bytes suffix
+ 1 # for "#"
+ Str.countUtf8Bytes after
before
|> Str.reserve bytes
|> appendHelp suffix
|> Str.concat "#"
|> Str.concat after
|> @Url
Err NotFound ->
# No query and no fragment, so just append it
@Url (appendHelp urlStr suffix)
## Internal helper
appendHelp : Str, Str -> Str
appendHelp = \prefix, suffix ->
if Str.endsWith prefix "/" then
if Str.startsWith suffix "/" then
# Avoid a double-slash by appending only the part of the suffix after the "/"
when Str.splitFirst suffix "/" is
Ok { after } ->
# TODO `expect before == ""`
Str.concat prefix after
Err NotFound ->
# This should never happen, because we already verified
# that the suffix startsWith "/"
# TODO `expect False` here with a comment
Str.concat prefix suffix
else
# prefix ends with "/" but suffix doesn't start with one, so just append.
Str.concat prefix suffix
else if Str.startsWith suffix "/" then
# Suffix starts with "/" but prefix doesn't end with one, so just append them.
Str.concat prefix suffix
else if Str.isEmpty prefix then
# Prefix is empty; return suffix.
suffix
else if Str.isEmpty suffix then
# Suffix is empty; return prefix.
prefix
else
# Neither is empty, but neither has a "/", so add one in between.
prefix
|> Str.concat "/"
|> Str.concat suffix
## Internal helper. This is intentionally unexposed so that you don't accidentally
## double-encode things. If you really want to percent-encode an arbitrary string,
## you can always do:
##
## Url.fromStr ""
## |> Url.append myStrToEncode
## |> Url.toStr
##
## Note that it's not necessary to situationally encode spaces as `+` instead of `%20` -
## it's apparently always safe to use `%20` (but not always safe to use `+`):
## https://stackoverflow.com/questions/2678551/when-should-space-be-encoded-to-plus-or-20/47188851#47188851
percentEncode : Str -> Str
percentEncode = \input ->
# Optimistically assume we won't need any percent encoding, and can have
# the same capacity as the input string. If we're wrong, it will get doubled.
initialOutput = strWithCapacity (Str.countUtf8Bytes input)
# TODO use Str.walkUtf8 once it exists
Str.walkUtf8WithIndex input initialOutput \output, byte, _index ->
# Spec for percent-encoding: https://www.ietf.org/rfc/rfc3986.txt
if
(byte >= 97 && byte <= 122) # lowercase ASCII
|| (byte >= 65 && byte <= 90) # uppercase ASCII
|| (byte >= 48 && byte <= 57) # digit
then
# This is the most common case: an unreserved character,
# which needs no encoding in a path
Str.appendScalar output (Num.toU32 byte)
|> Result.withDefault "" # this will never fail
else
when byte is
46 # '.'
| 95 # '_'
| 126 # '~'
| 150 -> # '-'
# These special characters can all be unescaped in paths
Str.appendScalar output (Num.toU32 byte)
|> Result.withDefault "" # this will never fail
_ ->
# This needs encoding in a path
suffix =
Str.toUtf8 percentEncoded
|> List.sublist { len: 3, start: 3 * Num.toNat byte }
|> Str.fromUtf8
|> Result.withDefault "" # This will never fail
Str.concat output suffix
## Adds a [Str] query parameter to the end of the [Url]. The key
## and value both get [percent-encoded](https://en.wikipedia.org/wiki/Percent-encoding).
##
## Url.fromStr "https://example.com"
## |> Url.appendParam "email" "someone@example.com"
## # https://example.com?email=someone%40example.com
##
## This can be called multiple times on the same URL.
##
## Url.fromStr "https://example.com"
## |> Url.appendParam "café" "du Monde"
## |> Url.appendParam "email" "hi@example.com"
## # https://example.com?caf%C3%A9=du%20Monde&email=hi%40example.com
appendParam : Url, Str, Str -> Url
appendParam = \@Url urlStr, key, value ->
{ withoutFragment, afterQuery } =
when Str.splitLast urlStr "#" is
Ok { before, after } ->
# The fragment is almost certainly going to be a small string,
# so this interpolation should happen on the stack.
{ withoutFragment: before, afterQuery: "#\(after)" }
Err NotFound ->
{ withoutFragment: urlStr, afterQuery: "" }
encodedKey = percentEncode key
encodedValue = percentEncode value
bytes =
Str.countUtf8Bytes withoutFragment
+ 1 # for "?" or "&"
+ Str.countUtf8Bytes encodedKey
+ 1 # for "="
+ Str.countUtf8Bytes encodedValue
+ Str.countUtf8Bytes afterQuery
withoutFragment
|> Str.reserve bytes
|> Str.concat (if hasQuery (@Url withoutFragment) then "&" else "?")
|> Str.concat encodedKey
|> Str.concat "="
|> Str.concat encodedValue
|> Str.concat afterQuery
|> @Url
## Replaces the URL's [query](https://en.wikipedia.org/wiki/URL#Syntax)—the part after
## the `?`, if it has one, but before any `#` it might have.
##
## Url.fromStr "https://example.com?key1=val1&key2=val2#stuff"
## |> Url.withQuery "newQuery=thisRightHere"
## # https://example.com?newQuery=thisRightHere#stuff
##
## Passing `""` removes the `?` (if there was one).
##
## Url.fromStr "https://example.com?key1=val1&key2=val2#stuff"
## |> Url.withQuery ""
## # https://example.com#stuff
withQuery : Url, Str -> Url
withQuery = \@Url urlStr, queryStr ->
{ withoutFragment, afterQuery } =
when Str.splitLast urlStr "#" is
Ok { before, after } ->
# The fragment is almost certainly going to be a small string,
# so this interpolation should happen on the stack.
{ withoutFragment: before, afterQuery: "#\(after)" }
Err NotFound ->
{ withoutFragment: urlStr, afterQuery: "" }
beforeQuery =
when Str.splitLast withoutFragment "?" is
Ok { before } -> before
Err NotFound -> withoutFragment
if Str.isEmpty queryStr then
@Url (Str.concat beforeQuery afterQuery)
else
bytes =
Str.countUtf8Bytes beforeQuery
+ 1 # for "?"
+ Str.countUtf8Bytes queryStr
+ Str.countUtf8Bytes afterQuery
beforeQuery
|> Str.reserve bytes
|> Str.concat "?"
|> Str.concat queryStr
|> Str.concat afterQuery
|> @Url
## Returns the URL's [query](https://en.wikipedia.org/wiki/URL#Syntax)—the part after
## the `?`, if it has one, but before any `#` it might have.
##
## Url.fromStr "https://example.com?key1=val1&key2=val2&key3=val3#stuff"
## |> Url.query
## # "key1=val1&key2=val2&key3=val3"
##
## Returns `""` if the URL has no query.
##
## Url.fromStr "https://example.com#stuff"
## |> Url.query
## # ""
query : Url -> Str
query = \@Url urlStr ->
withoutFragment =
when Str.splitLast urlStr "#" is
Ok { before } -> before
Err NotFound -> urlStr
when Str.splitLast withoutFragment "?" is
Ok { after } -> after
Err NotFound -> ""
## Returns `True` if the URL has a `?` in it.
##
## Url.fromStr "https://example.com?key=value#stuff"
## |> Url.hasQuery
## # True
##
## Url.fromStr "https://example.com#stuff"
## |> Url.hasQuery
## # False
hasQuery : Url -> Bool
hasQuery = \@Url urlStr ->
# TODO use Str.contains once it exists. It should have a "fast path"
# with SIMD iteration if the string is small enough to fit in a SIMD register.
Str.toUtf8 urlStr
|> List.contains (Num.toU8 '?')
## Returns the URL's [fragment](https://en.wikipedia.org/wiki/URL#Syntax)—the part after
## the `#`, if it has one.
##
## Url.fromStr "https://example.com#stuff"
## |> Url.fragment
## # "stuff"
##
## Returns `""` if the URL has no fragment.
##
## Url.fromStr "https://example.com"
## |> Url.fragment
## # ""
fragment : Url -> Str
fragment = \@Url urlStr ->
when Str.splitLast urlStr "#" is
Ok { after } -> after
Err NotFound -> ""
## Replaces the URL's [fragment](https://en.wikipedia.org/wiki/URL#Syntax).
##
## Url.fromStr "https://example.com#stuff"
## |> Url.withFragment "things"
## # https://example.com#things
##
## If the URL didn't have a fragment, adds one.
##
## Url.fromStr "https://example.com"
## |> Url.withFragment "things"
## # https://example.com#things
##
## Passing `""` removes the fragment.
##
## Url.fromStr "https://example.com#stuff"
## |> Url.withFragment ""
## # https://example.com
withFragment : Url, Str -> Url
withFragment = \@Url urlStr, fragmentStr ->
when Str.splitLast urlStr "#" is
Ok { before } ->
if Str.isEmpty fragmentStr then
# If the given fragment is empty, remove the URL's fragment
@Url before
else
# Replace the URL's old fragment with this one, discarding `after`
@Url "\(before)#\(fragmentStr)"
Err NotFound ->
if Str.isEmpty fragmentStr then
# If the given fragment is empty, leave the URL as having no fragment
@Url urlStr
else
# The URL didn't have a fragment, so give it this one
@Url "\(urlStr)#\(fragmentStr)"
## Returns `True` if the URL has a `#` in it.
##
## Url.fromStr "https://example.com?key=value#stuff"
## |> Url.hasFragment
## # True
##
## Url.fromStr "https://example.com?key=value"
## |> Url.hasFragment
## # False
hasFragment : Url -> Bool
hasFragment = \@Url urlStr ->
# TODO use Str.contains once it exists. It should have a "fast path"
# with SIMD iteration if the string is small enough to fit in a SIMD register.
Str.toUtf8 urlStr
|> List.contains (Num.toU8 '#')
strWithCapacity : Nat -> Str
strWithCapacity = \cap ->
Str.reserve "" cap
# Adapted from the percent-encoding crate, © The rust-url developers, Apache2-licensed
#
# https://github.com/servo/rust-url/blob/e12d76a61add5bc09980599c738099feaacd1d0d/percent_encoding/src/lib.rs#L183
percentEncoded : Str
percentEncoded = "%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20%21%22%23%24%25%26%27%28%29%2A%2B%2C%2D%2E%2F%30%31%32%33%34%35%36%37%38%39%3A%3B%3C%3D%3E%3F%40%41%42%43%44%45%46%47%48%49%4A%4B%4C%4D%4E%4F%50%51%52%53%54%55%56%57%58%59%5A%5B%5C%5D%5E%5F%60%61%62%63%64%65%66%67%68%69%6A%6B%6C%6D%6E%6F%70%71%72%73%74%75%76%77%78%79%7A%7B%7C%7D%7E%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF"