mirror of
https://github.com/roc-lang/roc.git
synced 2025-07-23 06:25:10 +00:00
Merge remote-tracking branch 'origin/main' into roc-dev-inline-expects
This commit is contained in:
Folkert
commit
e62ab00c65
275 changed files with 4038 additions and 2432 deletions
6
crates/cli_testing_examples/.gitignore
vendored
Normal file
6
crates/cli_testing_examples/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
*.dSYM
|
||||
libhost.a
|
||||
libapp.so
|
||||
dynhost
|
||||
preprocessedhost
|
||||
metadata
|
||||
2
crates/cli_testing_examples/algorithms/.gitignore
vendored
Normal file
2
crates/cli_testing_examples/algorithms/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
fibonacci
|
||||
quicksort
|
||||
15
crates/cli_testing_examples/algorithms/README.md
Normal file
15
crates/cli_testing_examples/algorithms/README.md
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
# Algorithm examples
|
||||
|
||||
To run:
|
||||
|
||||
```bash
|
||||
cargo run fibonacci.roc
|
||||
cargo run quicksort.roc
|
||||
```
|
||||
|
||||
To run in release mode instead, do:
|
||||
|
||||
```bash
|
||||
cargo run --release fibonacci.roc
|
||||
cargo run --release quicksort.roc
|
||||
```
|
||||
|
|
@ -0,0 +1,109 @@
|
|||
const std = @import("std");
|
||||
const testing = std.testing;
|
||||
const expectEqual = testing.expectEqual;
|
||||
const expect = testing.expect;
|
||||
const maxInt = std.math.maxInt;
|
||||
|
||||
comptime {
|
||||
// This is a workaround for https://github.com/ziglang/zig/issues/8218
|
||||
// which is only necessary on macOS.
|
||||
//
|
||||
// Once that issue is fixed, we can undo the changes in
|
||||
// 177cf12e0555147faa4d436e52fc15175c2c4ff0 and go back to passing
|
||||
// -fcompiler-rt in link.rs instead of doing this. Note that this
|
||||
// workaround is present in many host.zig files, so make sure to undo
|
||||
// it everywhere!
|
||||
const builtin = @import("builtin");
|
||||
if (builtin.os.tag == .macos) {
|
||||
_ = @import("compiler_rt");
|
||||
}
|
||||
}
|
||||
|
||||
const mem = std.mem;
|
||||
const Allocator = mem.Allocator;
|
||||
|
||||
// NOTE the LLVM backend expects this signature
|
||||
// extern fn roc__mainForHost_1_exposed(i64, *i64) void;
|
||||
extern fn roc__mainForHost_1_exposed(i64) i64;
|
||||
|
||||
const Align = 2 * @alignOf(usize);
|
||||
extern fn malloc(size: usize) callconv(.C) ?*align(Align) anyopaque;
|
||||
extern fn realloc(c_ptr: [*]align(Align) u8, size: usize) callconv(.C) ?*anyopaque;
|
||||
extern fn free(c_ptr: [*]align(Align) u8) callconv(.C) void;
|
||||
extern fn memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void;
|
||||
extern fn memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void;
|
||||
|
||||
const DEBUG: bool = false;
|
||||
|
||||
export fn roc_alloc(size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
var ptr = malloc(size);
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("alloc: {d} (alignment {d}, size {d})\n", .{ ptr, alignment, size }) catch unreachable;
|
||||
return ptr;
|
||||
} else {
|
||||
return malloc(size);
|
||||
}
|
||||
}
|
||||
|
||||
export fn roc_realloc(c_ptr: *anyopaque, new_size: usize, old_size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("realloc: {d} (alignment {d}, old_size {d})\n", .{ c_ptr, alignment, old_size }) catch unreachable;
|
||||
}
|
||||
|
||||
return realloc(@alignCast(Align, @ptrCast([*]u8, c_ptr)), new_size);
|
||||
}
|
||||
|
||||
export fn roc_dealloc(c_ptr: *anyopaque, alignment: u32) callconv(.C) void {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("dealloc: {d} (alignment {d})\n", .{ c_ptr, alignment }) catch unreachable;
|
||||
}
|
||||
|
||||
free(@alignCast(Align, @ptrCast([*]u8, c_ptr)));
|
||||
}
|
||||
|
||||
export fn roc_panic(c_ptr: *anyopaque, tag_id: u32) callconv(.C) void {
|
||||
_ = tag_id;
|
||||
|
||||
const stderr = std.io.getStdErr().writer();
|
||||
const msg = @ptrCast([*:0]const u8, c_ptr);
|
||||
stderr.print("Application crashed with message\n\n {s}\n\nShutting down\n", .{msg}) catch unreachable;
|
||||
std.process.exit(0);
|
||||
}
|
||||
|
||||
export fn roc_memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void {
|
||||
return memcpy(dst, src, size);
|
||||
}
|
||||
|
||||
export fn roc_memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void {
|
||||
return memset(dst, value, size);
|
||||
}
|
||||
|
||||
pub export fn main() u8 {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
const stderr = std.io.getStdErr().writer();
|
||||
|
||||
// start time
|
||||
var ts1: std.os.timespec = undefined;
|
||||
std.os.clock_gettime(std.os.CLOCK.REALTIME, &ts1) catch unreachable;
|
||||
|
||||
const result = roc__mainForHost_1_exposed(10);
|
||||
|
||||
// end time
|
||||
var ts2: std.os.timespec = undefined;
|
||||
std.os.clock_gettime(std.os.CLOCK.REALTIME, &ts2) catch unreachable;
|
||||
|
||||
stdout.print("{d}\n", .{result}) catch unreachable;
|
||||
|
||||
const delta = to_seconds(ts2) - to_seconds(ts1);
|
||||
|
||||
stderr.print("runtime: {d:.3}ms\n", .{delta * 1000}) catch unreachable;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
fn to_seconds(tms: std.os.timespec) f64 {
|
||||
return @intToFloat(f64, tms.tv_sec) + (@intToFloat(f64, tms.tv_nsec) / 1_000_000_000.0);
|
||||
}
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
platform "fibonacci"
|
||||
requires {} { main : I64 -> I64 }
|
||||
exposes []
|
||||
packages {}
|
||||
imports []
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : I64 -> I64
|
||||
mainForHost = \a -> main a
|
||||
13
crates/cli_testing_examples/algorithms/fibonacci.roc
Normal file
13
crates/cli_testing_examples/algorithms/fibonacci.roc
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
app "fibonacci"
|
||||
packages { pf: "fibonacci-platform/main.roc" }
|
||||
imports []
|
||||
provides [main] to pf
|
||||
|
||||
main = \n -> fib n 0 1
|
||||
|
||||
# the clever implementation requires join points
|
||||
fib = \n, a, b ->
|
||||
if n == 0 then
|
||||
a
|
||||
else
|
||||
fib (n - 1) b (a + b)
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
const std = @import("std");
|
||||
const builtin = @import("builtin");
|
||||
const str = @import("str");
|
||||
const RocStr = str.RocStr;
|
||||
const testing = std.testing;
|
||||
const expectEqual = testing.expectEqual;
|
||||
const expect = testing.expect;
|
||||
|
||||
comptime {
|
||||
// This is a workaround for https://github.com/ziglang/zig/issues/8218
|
||||
// which is only necessary on macOS.
|
||||
//
|
||||
// Once that issue is fixed, we can undo the changes in
|
||||
// 177cf12e0555147faa4d436e52fc15175c2c4ff0 and go back to passing
|
||||
// -fcompiler-rt in link.rs instead of doing this. Note that this
|
||||
// workaround is present in many host.zig files, so make sure to undo
|
||||
// it everywhere!
|
||||
if (builtin.os.tag == .macos) {
|
||||
_ = @import("compiler_rt");
|
||||
}
|
||||
}
|
||||
|
||||
const mem = std.mem;
|
||||
const Allocator = mem.Allocator;
|
||||
|
||||
extern fn roc__mainForHost_1_exposed(input: RocList) callconv(.C) RocList;
|
||||
|
||||
const Align = 2 * @alignOf(usize);
|
||||
extern fn malloc(size: usize) callconv(.C) ?*align(Align) anyopaque;
|
||||
extern fn realloc(c_ptr: [*]align(Align) u8, size: usize) callconv(.C) ?*anyopaque;
|
||||
extern fn free(c_ptr: [*]align(Align) u8) callconv(.C) void;
|
||||
extern fn memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void;
|
||||
extern fn memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void;
|
||||
|
||||
const DEBUG: bool = false;
|
||||
|
||||
export fn roc_alloc(size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
var ptr = malloc(size);
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("alloc: {d} (alignment {d}, size {d})\n", .{ ptr, alignment, size }) catch unreachable;
|
||||
return ptr;
|
||||
} else {
|
||||
return malloc(size);
|
||||
}
|
||||
}
|
||||
|
||||
export fn roc_realloc(c_ptr: *anyopaque, new_size: usize, old_size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("realloc: {d} (alignment {d}, old_size {d})\n", .{ c_ptr, alignment, old_size }) catch unreachable;
|
||||
}
|
||||
|
||||
return realloc(@alignCast(Align, @ptrCast([*]u8, c_ptr)), new_size);
|
||||
}
|
||||
|
||||
export fn roc_dealloc(c_ptr: *anyopaque, alignment: u32) callconv(.C) void {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("dealloc: {d} (alignment {d})\n", .{ c_ptr, alignment }) catch unreachable;
|
||||
}
|
||||
|
||||
free(@alignCast(Align, @ptrCast([*]u8, c_ptr)));
|
||||
}
|
||||
|
||||
export fn roc_panic(c_ptr: *anyopaque, tag_id: u32) callconv(.C) void {
|
||||
_ = tag_id;
|
||||
|
||||
const stderr = std.io.getStdErr().writer();
|
||||
const msg = @ptrCast([*:0]const u8, c_ptr);
|
||||
stderr.print("Application crashed with message\n\n {s}\n\nShutting down\n", .{msg}) catch unreachable;
|
||||
std.process.exit(0);
|
||||
}
|
||||
|
||||
export fn roc_memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void {
|
||||
return memcpy(dst, src, size);
|
||||
}
|
||||
|
||||
export fn roc_memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void {
|
||||
return memset(dst, value, size);
|
||||
}
|
||||
|
||||
// warning! the array is currently stack-allocated so don't make this too big
|
||||
const NUM_NUMS = 100;
|
||||
|
||||
const RocList = extern struct { elements: [*]i64, length: usize, capacity: usize };
|
||||
|
||||
const Unit = extern struct {};
|
||||
|
||||
pub export fn main() u8 {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
|
||||
var raw_numbers: [NUM_NUMS + 1]i64 = undefined;
|
||||
|
||||
// set refcount to one
|
||||
raw_numbers[0] = -9223372036854775808;
|
||||
|
||||
var numbers = raw_numbers[1..];
|
||||
|
||||
for (numbers) |_, i| {
|
||||
numbers[i] = @mod(@intCast(i64, i), 12);
|
||||
}
|
||||
|
||||
var roc_list = RocList{ .elements = numbers, .length = NUM_NUMS, .capacity = NUM_NUMS };
|
||||
|
||||
// start time
|
||||
var ts1: std.os.timespec = undefined;
|
||||
std.os.clock_gettime(std.os.CLOCK.REALTIME, &ts1) catch unreachable;
|
||||
|
||||
// actually call roc to populate the callresult
|
||||
const callresult: RocList = roc__mainForHost_1_exposed(roc_list);
|
||||
|
||||
// stdout the result
|
||||
const length = std.math.min(20, callresult.length);
|
||||
var result = callresult.elements[0..length];
|
||||
|
||||
// end time
|
||||
var ts2: std.os.timespec = undefined;
|
||||
std.os.clock_gettime(std.os.CLOCK.REALTIME, &ts2) catch unreachable;
|
||||
|
||||
for (result) |x, i| {
|
||||
if (i == 0) {
|
||||
stdout.print("[{}, ", .{x}) catch unreachable;
|
||||
} else if (i == length - 1) {
|
||||
stdout.print("{}]\n", .{x}) catch unreachable;
|
||||
} else {
|
||||
stdout.print("{}, ", .{x}) catch unreachable;
|
||||
}
|
||||
}
|
||||
|
||||
// TODO apparently the typestamps are still (partially) undefined?
|
||||
// const delta = to_seconds(ts2) - to_seconds(ts1);
|
||||
// stderr.print("runtime: {d:.3}ms\n", .{delta * 1000}) catch unreachable;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
fn to_seconds(tms: std.os.timespec) f64 {
|
||||
return @intToFloat(f64, tms.tv_sec) + (@intToFloat(f64, tms.tv_nsec) / 1_000_000_000.0);
|
||||
}
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
platform "quicksort"
|
||||
requires {} { quicksort : List I64 -> List I64 }
|
||||
exposes []
|
||||
packages {}
|
||||
imports []
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : List I64 -> List I64
|
||||
mainForHost = \list -> quicksort list
|
||||
59
crates/cli_testing_examples/algorithms/quicksort.roc
Normal file
59
crates/cli_testing_examples/algorithms/quicksort.roc
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
app "quicksort"
|
||||
packages { pf: "quicksort-platform/main.roc" }
|
||||
imports []
|
||||
provides [quicksort] to pf
|
||||
|
||||
quicksort = \originalList ->
|
||||
n = List.len originalList
|
||||
|
||||
quicksortHelp originalList 0 (n - 1)
|
||||
|
||||
quicksortHelp : List (Num a), Nat, Nat -> List (Num a)
|
||||
quicksortHelp = \list, low, high ->
|
||||
if low < high then
|
||||
when partition low high list is
|
||||
Pair partitionIndex partitioned ->
|
||||
partitioned
|
||||
|> quicksortHelp low (partitionIndex - 1)
|
||||
|> quicksortHelp (partitionIndex + 1) high
|
||||
else
|
||||
list
|
||||
|
||||
partition : Nat, Nat, List (Num a) -> [Pair Nat (List (Num a))]
|
||||
partition = \low, high, initialList ->
|
||||
when List.get initialList high is
|
||||
Ok pivot ->
|
||||
when partitionHelp low low initialList high pivot is
|
||||
Pair newI newList ->
|
||||
Pair newI (swap newI high newList)
|
||||
|
||||
Err _ ->
|
||||
Pair low initialList
|
||||
|
||||
partitionHelp : Nat, Nat, List (Num c), Nat, Num c -> [Pair Nat (List (Num c))]
|
||||
partitionHelp = \i, j, list, high, pivot ->
|
||||
if j < high then
|
||||
when List.get list j is
|
||||
Ok value ->
|
||||
if value <= pivot then
|
||||
partitionHelp (i + 1) (j + 1) (swap i j list) high pivot
|
||||
else
|
||||
partitionHelp i (j + 1) list high pivot
|
||||
|
||||
Err _ ->
|
||||
Pair i list
|
||||
else
|
||||
Pair i list
|
||||
|
||||
swap : Nat, Nat, List a -> List a
|
||||
swap = \i, j, list ->
|
||||
when Pair (List.get list i) (List.get list j) is
|
||||
Pair (Ok atI) (Ok atJ) ->
|
||||
list
|
||||
|> List.set i atJ
|
||||
|> List.set j atI
|
||||
|
||||
_ ->
|
||||
# to prevent a decrement on list
|
||||
# turns out this is very important for optimizations
|
||||
list
|
||||
12
crates/cli_testing_examples/benchmarks/.gitignore
vendored
Normal file
12
crates/cli_testing_examples/benchmarks/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
cfold
|
||||
closure
|
||||
deriv
|
||||
issue2279
|
||||
nqueens
|
||||
quicksortapp
|
||||
rbtree-ck
|
||||
rbtree-del
|
||||
rbtree-insert
|
||||
test-astar
|
||||
test-base64
|
||||
*.wasm
|
||||
124
crates/cli_testing_examples/benchmarks/AStar.roc
Normal file
124
crates/cli_testing_examples/benchmarks/AStar.roc
Normal file
|
|
@ -0,0 +1,124 @@
|
|||
interface AStar
|
||||
exposes [findPath, Model, initialModel, cheapestOpen, reconstructPath]
|
||||
imports [Quicksort]
|
||||
|
||||
findPath = \costFn, moveFn, start, end ->
|
||||
astar costFn moveFn end (initialModel start)
|
||||
|
||||
Model position : {
|
||||
evaluated : Set position,
|
||||
openSet : Set position,
|
||||
costs : Dict position F64,
|
||||
cameFrom : Dict position position,
|
||||
}
|
||||
|
||||
initialModel : position -> Model position
|
||||
initialModel = \start -> {
|
||||
evaluated: Set.empty,
|
||||
openSet: Set.single start,
|
||||
costs: Dict.single start 0,
|
||||
cameFrom: Dict.empty,
|
||||
}
|
||||
|
||||
cheapestOpen : (position -> F64), Model position -> Result position {}
|
||||
cheapestOpen = \costFn, model ->
|
||||
model.openSet
|
||||
|> Set.toList
|
||||
|> List.keepOks
|
||||
(\position ->
|
||||
when Dict.get model.costs position is
|
||||
Err _ -> Err {}
|
||||
Ok cost -> Ok { cost: cost + costFn position, position }
|
||||
)
|
||||
|> Quicksort.sortBy .cost
|
||||
|> List.first
|
||||
|> Result.map .position
|
||||
|> Result.mapErr (\_ -> {})
|
||||
|
||||
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
|
||||
|
||||
updateCost : position, position, Model position -> Model position
|
||||
updateCost = \current, neighbor, model ->
|
||||
newCameFrom =
|
||||
Dict.insert model.cameFrom neighbor current
|
||||
|
||||
newCosts =
|
||||
Dict.insert model.costs neighbor distanceTo
|
||||
|
||||
distanceTo =
|
||||
reconstructPath newCameFrom neighbor
|
||||
|> List.len
|
||||
|> Num.toFrac
|
||||
|
||||
newModel =
|
||||
{ model &
|
||||
costs: newCosts,
|
||||
cameFrom: newCameFrom,
|
||||
}
|
||||
|
||||
when Dict.get model.costs neighbor is
|
||||
Err _ ->
|
||||
newModel
|
||||
|
||||
Ok previousDistance ->
|
||||
if distanceTo < previousDistance then
|
||||
newModel
|
||||
else
|
||||
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 {}
|
||||
Ok current ->
|
||||
if current == goal then
|
||||
Ok (reconstructPath model.cameFrom goal)
|
||||
else
|
||||
modelPopped =
|
||||
{ model &
|
||||
openSet: Set.remove model.openSet current,
|
||||
evaluated: Set.insert model.evaluated current,
|
||||
}
|
||||
|
||||
neighbors =
|
||||
moveFn current
|
||||
|
||||
newNeighbors =
|
||||
Set.difference neighbors modelPopped.evaluated
|
||||
|
||||
modelWithNeighbors : Model position
|
||||
modelWithNeighbors =
|
||||
{ modelPopped &
|
||||
openSet: Set.union modelPopped.openSet newNeighbors,
|
||||
}
|
||||
|
||||
walker : Model position, position -> Model position
|
||||
walker = \amodel, n -> updateCost current n amodel
|
||||
|
||||
modelWithCosts =
|
||||
Set.walk newNeighbors modelWithNeighbors walker
|
||||
|
||||
astar costFn moveFn goal modelWithCosts
|
||||
|
||||
# takeStep = \moveFn, _goal, model, current ->
|
||||
# modelPopped =
|
||||
# { model &
|
||||
# openSet: Set.remove model.openSet current,
|
||||
# evaluated: Set.insert model.evaluated current,
|
||||
# }
|
||||
#
|
||||
# neighbors = moveFn current
|
||||
#
|
||||
# newNeighbors = Set.difference neighbors modelPopped.evaluated
|
||||
#
|
||||
# modelWithNeighbors = { modelPopped & openSet: Set.union modelPopped.openSet newNeighbors }
|
||||
#
|
||||
# # a lot goes wrong here
|
||||
# modelWithCosts =
|
||||
# Set.walk newNeighbors modelWithNeighbors (\n, m -> updateCost current n m)
|
||||
#
|
||||
# modelWithCosts
|
||||
35
crates/cli_testing_examples/benchmarks/Base64.roc
Normal file
35
crates/cli_testing_examples/benchmarks/Base64.roc
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
interface Base64 exposes [fromBytes, fromStr, toBytes, toStr] imports [Base64.Decode, Base64.Encode]
|
||||
|
||||
# base 64 encoding from a sequence of bytes
|
||||
fromBytes : List U8 -> Result Str [InvalidInput]*
|
||||
fromBytes = \bytes ->
|
||||
when Base64.Decode.fromBytes bytes is
|
||||
Ok v ->
|
||||
Ok v
|
||||
|
||||
Err _ ->
|
||||
Err InvalidInput
|
||||
|
||||
# base 64 encoding from a string
|
||||
fromStr : Str -> Result Str [InvalidInput]*
|
||||
fromStr = \str ->
|
||||
fromBytes (Str.toUtf8 str)
|
||||
|
||||
# base64-encode bytes to the original
|
||||
toBytes : Str -> Result (List U8) [InvalidInput]*
|
||||
toBytes = \str ->
|
||||
Ok (Base64.Encode.toBytes str)
|
||||
|
||||
toStr : Str -> Result Str [InvalidInput]*
|
||||
toStr = \str ->
|
||||
when toBytes str is
|
||||
Ok bytes ->
|
||||
when Str.fromUtf8 bytes is
|
||||
Ok v ->
|
||||
Ok v
|
||||
|
||||
Err _ ->
|
||||
Err InvalidInput
|
||||
|
||||
Err _ ->
|
||||
Err InvalidInput
|
||||
120
crates/cli_testing_examples/benchmarks/Base64/Decode.roc
Normal file
120
crates/cli_testing_examples/benchmarks/Base64/Decode.roc
Normal file
|
|
@ -0,0 +1,120 @@
|
|||
interface Base64.Decode exposes [fromBytes] imports [Bytes.Decode.{ ByteDecoder, DecodeProblem }]
|
||||
|
||||
fromBytes : List U8 -> Result Str DecodeProblem
|
||||
fromBytes = \bytes ->
|
||||
Bytes.Decode.decode bytes (decodeBase64 (List.len bytes))
|
||||
|
||||
decodeBase64 : Nat -> ByteDecoder Str
|
||||
decodeBase64 = \width -> Bytes.Decode.loop loopHelp { remaining: width, string: "" }
|
||||
|
||||
loopHelp : { remaining : Nat, string : Str } -> ByteDecoder (Bytes.Decode.Step { remaining : Nat, string : Str } Str)
|
||||
loopHelp = \{ remaining, string } ->
|
||||
if remaining >= 3 then
|
||||
x, y, z <- Bytes.Decode.map3 Bytes.Decode.u8 Bytes.Decode.u8 Bytes.Decode.u8
|
||||
|
||||
a : U32
|
||||
a = Num.intCast x
|
||||
b : U32
|
||||
b = Num.intCast y
|
||||
c : U32
|
||||
c = Num.intCast z
|
||||
combined = Num.bitwiseOr (Num.bitwiseOr (Num.shiftLeftBy a 16) (Num.shiftLeftBy b 8)) c
|
||||
|
||||
Loop {
|
||||
remaining: remaining - 3,
|
||||
string: Str.concat string (bitsToChars combined 0),
|
||||
}
|
||||
else if remaining == 0 then
|
||||
Bytes.Decode.succeed (Done string)
|
||||
else if remaining == 2 then
|
||||
x, y <- Bytes.Decode.map2 Bytes.Decode.u8 Bytes.Decode.u8
|
||||
|
||||
a : U32
|
||||
a = Num.intCast x
|
||||
b : U32
|
||||
b = Num.intCast y
|
||||
combined = Num.bitwiseOr (Num.shiftLeftBy a 16) (Num.shiftLeftBy b 8)
|
||||
|
||||
Done (Str.concat string (bitsToChars combined 1))
|
||||
else
|
||||
# remaining = 1
|
||||
x <- Bytes.Decode.map Bytes.Decode.u8
|
||||
|
||||
a : U32
|
||||
a = Num.intCast x
|
||||
|
||||
Done (Str.concat string (bitsToChars (Num.shiftLeftBy a 16) 2))
|
||||
|
||||
bitsToChars : U32, Int * -> Str
|
||||
bitsToChars = \bits, missing ->
|
||||
when Str.fromUtf8 (bitsToCharsHelp bits missing) is
|
||||
Ok str -> str
|
||||
Err _ -> ""
|
||||
|
||||
# Mask that can be used to get the lowest 6 bits of a binary number
|
||||
lowest6BitsMask : Int *
|
||||
lowest6BitsMask = 63
|
||||
|
||||
bitsToCharsHelp : U32, Int * -> List U8
|
||||
bitsToCharsHelp = \bits, missing ->
|
||||
# The input is 24 bits, which we have to partition into 4 6-bit segments. We achieve this by
|
||||
# shifting to the right by (a multiple of) 6 to remove unwanted bits on the right, then `Num.bitwiseAnd`
|
||||
# with `0b111111` (which is 2^6 - 1 or 63) (so, 6 1s) to remove unwanted bits on the left.
|
||||
# any 6-bit number is a valid base64 digit, so this is actually safe
|
||||
p =
|
||||
Num.shiftRightZfBy bits 18
|
||||
|> Num.intCast
|
||||
|> unsafeToChar
|
||||
|
||||
q =
|
||||
Num.bitwiseAnd (Num.shiftRightZfBy bits 12) lowest6BitsMask
|
||||
|> Num.intCast
|
||||
|> unsafeToChar
|
||||
|
||||
r =
|
||||
Num.bitwiseAnd (Num.shiftRightZfBy bits 6) lowest6BitsMask
|
||||
|> Num.intCast
|
||||
|> unsafeToChar
|
||||
|
||||
s =
|
||||
Num.bitwiseAnd bits lowest6BitsMask
|
||||
|> Num.intCast
|
||||
|> unsafeToChar
|
||||
|
||||
equals : U8
|
||||
equals = 61
|
||||
|
||||
when missing is
|
||||
0 -> [p, q, r, s]
|
||||
1 -> [p, q, r, equals]
|
||||
2 -> [p, q, equals, equals]
|
||||
_ ->
|
||||
# unreachable
|
||||
[]
|
||||
|
||||
# Base64 index to character/digit
|
||||
unsafeToChar : U8 -> U8
|
||||
unsafeToChar = \n ->
|
||||
if n <= 25 then
|
||||
# uppercase characters
|
||||
65 + n
|
||||
else if n <= 51 then
|
||||
# lowercase characters
|
||||
97 + (n - 26)
|
||||
else if n <= 61 then
|
||||
# digit characters
|
||||
48 + (n - 52)
|
||||
else
|
||||
# special cases
|
||||
when n is
|
||||
62 ->
|
||||
# '+'
|
||||
43
|
||||
|
||||
63 ->
|
||||
# '/'
|
||||
47
|
||||
|
||||
_ ->
|
||||
# anything else is invalid '\u{0000}'
|
||||
0
|
||||
176
crates/cli_testing_examples/benchmarks/Base64/Encode.roc
Normal file
176
crates/cli_testing_examples/benchmarks/Base64/Encode.roc
Normal file
|
|
@ -0,0 +1,176 @@
|
|||
interface Base64.Encode
|
||||
exposes [toBytes]
|
||||
imports [Bytes.Encode.{ ByteEncoder }]
|
||||
|
||||
InvalidChar : U8
|
||||
|
||||
# State : [None, One U8, Two U8, Three U8]
|
||||
toBytes : Str -> List U8
|
||||
toBytes = \str ->
|
||||
str
|
||||
|> Str.toUtf8
|
||||
|> encodeChunks
|
||||
|> Bytes.Encode.sequence
|
||||
|> Bytes.Encode.encode
|
||||
|
||||
encodeChunks : List U8 -> List ByteEncoder
|
||||
encodeChunks = \bytes ->
|
||||
List.walk bytes { output: [], accum: None } folder
|
||||
|> encodeResidual
|
||||
|
||||
coerce : Nat, a -> a
|
||||
coerce = \_, x -> x
|
||||
|
||||
# folder : { output : List ByteEncoder, accum : State }, U8 -> { output : List ByteEncoder, 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 }
|
||||
Three a b c ->
|
||||
when encodeCharacters a b c char is
|
||||
Ok encoder ->
|
||||
{
|
||||
output: List.append output encoder,
|
||||
accum: None,
|
||||
}
|
||||
|
||||
Err _ ->
|
||||
{ output, accum: None }
|
||||
|
||||
# SGVs bG8g V29y bGQ=
|
||||
# encodeResidual : { output : List ByteEncoder, accum : State } -> List ByteEncoder
|
||||
encodeResidual = \{ output, accum } ->
|
||||
when accum is
|
||||
Unreachable _ -> output
|
||||
None -> output
|
||||
One _ -> output
|
||||
Two a b ->
|
||||
when encodeCharacters a b equals equals is
|
||||
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
|
||||
|
||||
equals : U8
|
||||
equals = 61
|
||||
|
||||
# Convert 4 characters to 24 bits (as an ByteEncoder)
|
||||
encodeCharacters : U8, U8, U8, U8 -> Result ByteEncoder InvalidChar
|
||||
encodeCharacters = \a, b, c, d ->
|
||||
if !(isValidChar a) then
|
||||
Err a
|
||||
else if !(isValidChar b) then
|
||||
Err b
|
||||
else
|
||||
# `=` is the padding character, and must be special-cased
|
||||
# only the `c` and `d` char are allowed to be padding
|
||||
n1 = unsafeConvertChar a
|
||||
n2 = unsafeConvertChar b
|
||||
|
||||
x : U32
|
||||
x = Num.intCast n1
|
||||
|
||||
y : U32
|
||||
y = Num.intCast n2
|
||||
|
||||
if d == equals then
|
||||
if c == equals then
|
||||
n = Num.bitwiseOr (Num.shiftLeftBy x 18) (Num.shiftLeftBy y 12)
|
||||
|
||||
# masking higher bits is not needed, Encode.unsignedInt8 ignores higher bits
|
||||
b1 : U8
|
||||
b1 = Num.intCast (Num.shiftRightBy n 16)
|
||||
|
||||
Ok (Bytes.Encode.u8 b1)
|
||||
else if !(isValidChar c) then
|
||||
Err c
|
||||
else
|
||||
n3 = unsafeConvertChar c
|
||||
|
||||
z : U32
|
||||
z = Num.intCast n3
|
||||
|
||||
n = Num.bitwiseOr (Num.bitwiseOr (Num.shiftLeftBy x 18) (Num.shiftLeftBy y 12)) (Num.shiftLeftBy z 6)
|
||||
|
||||
combined : U16
|
||||
combined = Num.intCast (Num.shiftRightBy n 8)
|
||||
|
||||
Ok (Bytes.Encode.u16 BE combined)
|
||||
else if !(isValidChar d) then
|
||||
Err d
|
||||
else
|
||||
n3 = unsafeConvertChar c
|
||||
n4 = unsafeConvertChar d
|
||||
|
||||
z : U32
|
||||
z = Num.intCast n3
|
||||
|
||||
w : U32
|
||||
w = Num.intCast n4
|
||||
|
||||
n =
|
||||
Num.bitwiseOr
|
||||
(Num.bitwiseOr (Num.shiftLeftBy x 18) (Num.shiftLeftBy y 12))
|
||||
(Num.bitwiseOr (Num.shiftLeftBy z 6) w)
|
||||
|
||||
b3 : U8
|
||||
b3 = Num.intCast n
|
||||
|
||||
combined : U16
|
||||
combined = Num.intCast (Num.shiftRightBy n 8)
|
||||
|
||||
Ok (Bytes.Encode.sequence [Bytes.Encode.u16 BE combined, Bytes.Encode.u8 b3])
|
||||
|
||||
# is the character a base64 digit?
|
||||
# The base16 digits are: A-Z, a-z, 0-1, '+' and '/'
|
||||
isValidChar : U8 -> Bool
|
||||
isValidChar = \c ->
|
||||
if isAlphaNum c then
|
||||
Bool.true
|
||||
else
|
||||
when c is
|
||||
43 ->
|
||||
# '+'
|
||||
Bool.true
|
||||
|
||||
47 ->
|
||||
# '/'
|
||||
Bool.true
|
||||
|
||||
_ ->
|
||||
Bool.false
|
||||
|
||||
isAlphaNum : U8 -> Bool
|
||||
isAlphaNum = \key ->
|
||||
(key >= 48 && key <= 57) || (key >= 64 && key <= 90) || (key >= 97 && key <= 122)
|
||||
|
||||
# Convert a base64 character/digit to its index
|
||||
# See also [Wikipedia](https://en.wikipedia.org/wiki/Base64#Base64_table)
|
||||
unsafeConvertChar : U8 -> U8
|
||||
unsafeConvertChar = \key ->
|
||||
if key >= 65 && key <= 90 then
|
||||
# A-Z
|
||||
key - 65
|
||||
else if key >= 97 && key <= 122 then
|
||||
# a-z
|
||||
(key - 97) + 26
|
||||
else if key >= 48 && key <= 57 then
|
||||
# 0-9
|
||||
(key - 48) + 26 + 26
|
||||
else
|
||||
when key is
|
||||
43 ->
|
||||
# '+'
|
||||
62
|
||||
|
||||
47 ->
|
||||
# '/'
|
||||
63
|
||||
|
||||
_ ->
|
||||
0
|
||||
111
crates/cli_testing_examples/benchmarks/Bytes/Decode.roc
Normal file
111
crates/cli_testing_examples/benchmarks/Bytes/Decode.roc
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
interface Bytes.Decode exposes [ByteDecoder, decode, map, map2, u8, loop, Step, succeed, DecodeProblem, after, map3] imports []
|
||||
|
||||
State : { bytes : List U8, cursor : Nat }
|
||||
|
||||
DecodeProblem : [OutOfBytes]
|
||||
|
||||
ByteDecoder a := State -> [Good State a, Bad DecodeProblem]
|
||||
|
||||
decode : List U8, ByteDecoder a -> Result a DecodeProblem
|
||||
decode = \bytes, @ByteDecoder decoder ->
|
||||
when decoder { bytes, cursor: 0 } is
|
||||
Good _ value ->
|
||||
Ok value
|
||||
|
||||
Bad e ->
|
||||
Err e
|
||||
|
||||
succeed : a -> ByteDecoder a
|
||||
succeed = \value -> @ByteDecoder \state -> Good state value
|
||||
|
||||
map : ByteDecoder a, (a -> b) -> ByteDecoder b
|
||||
map = \@ByteDecoder decoder, transform ->
|
||||
@ByteDecoder
|
||||
\state ->
|
||||
when decoder state is
|
||||
Good state1 value ->
|
||||
Good state1 (transform value)
|
||||
|
||||
Bad e ->
|
||||
Bad e
|
||||
|
||||
map2 : ByteDecoder a, ByteDecoder b, (a, b -> c) -> ByteDecoder c
|
||||
map2 = \@ByteDecoder decoder1, @ByteDecoder decoder2, transform ->
|
||||
@ByteDecoder
|
||||
\state1 ->
|
||||
when decoder1 state1 is
|
||||
Good state2 a ->
|
||||
when decoder2 state2 is
|
||||
Good state3 b ->
|
||||
Good state3 (transform a b)
|
||||
|
||||
Bad e ->
|
||||
Bad e
|
||||
|
||||
Bad e ->
|
||||
Bad e
|
||||
|
||||
map3 : ByteDecoder a, ByteDecoder b, ByteDecoder c, (a, b, c -> d) -> ByteDecoder d
|
||||
map3 = \@ByteDecoder decoder1, @ByteDecoder decoder2, @ByteDecoder decoder3, transform ->
|
||||
@ByteDecoder
|
||||
\state1 ->
|
||||
when decoder1 state1 is
|
||||
Good state2 a ->
|
||||
when decoder2 state2 is
|
||||
Good state3 b ->
|
||||
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
|
||||
|
||||
after : ByteDecoder a, (a -> ByteDecoder b) -> ByteDecoder b
|
||||
after = \@ByteDecoder decoder, transform ->
|
||||
@ByteDecoder
|
||||
\state ->
|
||||
when decoder state is
|
||||
Good state1 value ->
|
||||
(@ByteDecoder decoder1) = transform value
|
||||
|
||||
decoder1 state1
|
||||
|
||||
Bad e ->
|
||||
Bad e
|
||||
|
||||
u8 : ByteDecoder U8
|
||||
u8 = @ByteDecoder
|
||||
\state ->
|
||||
when List.get state.bytes state.cursor is
|
||||
Ok b ->
|
||||
Good { state & cursor: state.cursor + 1 } b
|
||||
|
||||
Err _ ->
|
||||
Bad OutOfBytes
|
||||
|
||||
Step state b : [Loop state, Done b]
|
||||
|
||||
loop : (state -> ByteDecoder (Step state a)), state -> ByteDecoder a
|
||||
loop = \stepper, initial ->
|
||||
@ByteDecoder
|
||||
\state ->
|
||||
loopHelp stepper initial state
|
||||
|
||||
loopHelp = \stepper, accum, state ->
|
||||
(@ByteDecoder stepper1) = stepper accum
|
||||
|
||||
when stepper1 state is
|
||||
Good newState (Done value) ->
|
||||
Good newState value
|
||||
|
||||
Good newState (Loop newAccum) ->
|
||||
loopHelp stepper newAccum newState
|
||||
|
||||
Bad e ->
|
||||
Bad e
|
||||
134
crates/cli_testing_examples/benchmarks/Bytes/Encode.roc
Normal file
134
crates/cli_testing_examples/benchmarks/Bytes/Encode.roc
Normal file
|
|
@ -0,0 +1,134 @@
|
|||
interface Bytes.Encode exposes [ByteEncoder, sequence, u8, u16, bytes, empty, encode] imports []
|
||||
|
||||
Endianness : [BE, LE]
|
||||
|
||||
ByteEncoder : [Signed8 I8, Unsigned8 U8, Signed16 Endianness I16, Unsigned16 Endianness U16, Sequence Nat (List ByteEncoder), Bytes (List U8)]
|
||||
|
||||
u8 : U8 -> ByteEncoder
|
||||
u8 = \value -> Unsigned8 value
|
||||
|
||||
empty : ByteEncoder
|
||||
empty =
|
||||
foo : List ByteEncoder
|
||||
foo = []
|
||||
|
||||
Sequence 0 foo
|
||||
|
||||
u16 : Endianness, U16 -> ByteEncoder
|
||||
u16 = \endianness, value -> Unsigned16 endianness value
|
||||
|
||||
bytes : List U8 -> ByteEncoder
|
||||
bytes = \bs -> Bytes bs
|
||||
|
||||
sequence : List ByteEncoder -> ByteEncoder
|
||||
sequence = \encoders ->
|
||||
Sequence (getWidths encoders 0) encoders
|
||||
|
||||
getWidth : ByteEncoder -> Nat
|
||||
getWidth = \encoder ->
|
||||
when encoder is
|
||||
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
|
||||
|
||||
getWidths : List ByteEncoder, Nat -> Nat
|
||||
getWidths = \encoders, initial ->
|
||||
List.walk encoders initial \accum, encoder -> accum + getWidth encoder
|
||||
|
||||
encode : ByteEncoder -> List U8
|
||||
encode = \encoder ->
|
||||
output = List.repeat 0 (getWidth encoder)
|
||||
|
||||
encodeHelp encoder 0 output
|
||||
|> .output
|
||||
|
||||
encodeHelp : ByteEncoder, Nat, List U8 -> { output : List U8, offset : Nat }
|
||||
encodeHelp = \encoder, offset, output ->
|
||||
when encoder is
|
||||
Unsigned8 value ->
|
||||
{
|
||||
output: List.set output offset value,
|
||||
offset: offset + 1,
|
||||
}
|
||||
|
||||
Signed8 value ->
|
||||
cast : U8
|
||||
cast = Num.intCast value
|
||||
|
||||
{
|
||||
output: List.set output offset cast,
|
||||
offset: offset + 1,
|
||||
}
|
||||
|
||||
Unsigned16 endianness value ->
|
||||
a : U8
|
||||
a = Num.intCast (Num.shiftRightBy value 8)
|
||||
|
||||
b : U8
|
||||
b = Num.intCast value
|
||||
|
||||
newOutput =
|
||||
when endianness is
|
||||
BE ->
|
||||
output
|
||||
|> List.set (offset + 0) a
|
||||
|> List.set (offset + 1) b
|
||||
|
||||
LE ->
|
||||
output
|
||||
|> List.set (offset + 0) b
|
||||
|> List.set (offset + 1) a
|
||||
|
||||
{
|
||||
output: newOutput,
|
||||
offset: offset + 2,
|
||||
}
|
||||
|
||||
Signed16 endianness value ->
|
||||
a : U8
|
||||
a = Num.intCast (Num.shiftRightBy value 8)
|
||||
|
||||
b : U8
|
||||
b = Num.intCast value
|
||||
|
||||
newOutput =
|
||||
when endianness is
|
||||
BE ->
|
||||
output
|
||||
|> List.set (offset + 0) a
|
||||
|> List.set (offset + 1) b
|
||||
|
||||
LE ->
|
||||
output
|
||||
|> List.set (offset + 0) b
|
||||
|> List.set (offset + 1) a
|
||||
|
||||
{
|
||||
output: newOutput,
|
||||
offset: offset + 1,
|
||||
}
|
||||
|
||||
Bytes bs ->
|
||||
List.walk
|
||||
bs
|
||||
{ output, offset }
|
||||
\accum, byte -> {
|
||||
offset: accum.offset + 1,
|
||||
output: List.set accum.output offset byte,
|
||||
}
|
||||
|
||||
Sequence _ encoders ->
|
||||
List.walk
|
||||
encoders
|
||||
{ output, offset }
|
||||
\accum, single ->
|
||||
encodeHelp single accum.offset accum.output
|
||||
130
crates/cli_testing_examples/benchmarks/CFold.roc
Normal file
130
crates/cli_testing_examples/benchmarks/CFold.roc
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
app "cfold"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
# adapted from https://github.com/koka-lang/koka/blob/master/test/bench/haskell/cfold.hs
|
||||
main : Task.Task {} []
|
||||
main =
|
||||
Task.after
|
||||
Task.getInt
|
||||
\n ->
|
||||
e = mkExpr n 1 # original koka n = 20 (set `ulimit -s unlimited` to avoid stack overflow for n = 20)
|
||||
unoptimized = eval e
|
||||
optimized = eval (constFolding (reassoc e))
|
||||
|
||||
unoptimized
|
||||
|> Num.toStr
|
||||
|> Str.concat " & "
|
||||
|> Str.concat (Num.toStr optimized)
|
||||
|> Task.putLine
|
||||
|
||||
Expr : [
|
||||
Add Expr Expr,
|
||||
Mul Expr Expr,
|
||||
Val I64,
|
||||
Var I64,
|
||||
]
|
||||
|
||||
mkExpr : I64, I64 -> Expr
|
||||
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))
|
||||
|
||||
max : I64, I64 -> I64
|
||||
max = \a, b -> if a > b then a else b
|
||||
|
||||
appendAdd : Expr, Expr -> Expr
|
||||
appendAdd = \e1, e2 ->
|
||||
when e1 is
|
||||
Add a1 a2 ->
|
||||
Add a1 (appendAdd a2 e2)
|
||||
|
||||
_ ->
|
||||
Add e1 e2
|
||||
|
||||
appendMul : Expr, Expr -> Expr
|
||||
appendMul = \e1, e2 ->
|
||||
when e1 is
|
||||
Mul a1 a2 ->
|
||||
Mul a1 (appendMul a2 e2)
|
||||
|
||||
_ ->
|
||||
Mul e1 e2
|
||||
|
||||
eval : Expr -> I64
|
||||
eval = \e ->
|
||||
when e is
|
||||
Var _ ->
|
||||
0
|
||||
|
||||
Val v ->
|
||||
v
|
||||
|
||||
Add l r ->
|
||||
eval l + eval r
|
||||
|
||||
Mul l r ->
|
||||
eval l * eval r
|
||||
|
||||
reassoc : Expr -> Expr
|
||||
reassoc = \e ->
|
||||
when e is
|
||||
Add e1 e2 ->
|
||||
x1 = reassoc e1
|
||||
x2 = reassoc e2
|
||||
|
||||
appendAdd x1 x2
|
||||
|
||||
Mul e1 e2 ->
|
||||
x1 = reassoc e1
|
||||
x2 = reassoc e2
|
||||
|
||||
appendMul x1 x2
|
||||
|
||||
_ ->
|
||||
e
|
||||
|
||||
constFolding : Expr -> Expr
|
||||
constFolding = \e ->
|
||||
when e is
|
||||
Add e1 e2 ->
|
||||
x1 = constFolding e1
|
||||
x2 = constFolding e2
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
51
crates/cli_testing_examples/benchmarks/Closure.roc
Normal file
51
crates/cli_testing_examples/benchmarks/Closure.roc
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
app "closure"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
# see https://github.com/roc-lang/roc/issues/985
|
||||
main : Task.Task {} []
|
||||
main = closure1 {}
|
||||
# |> Task.after (\_ -> closure2 {})
|
||||
# |> Task.after (\_ -> closure3 {})
|
||||
# |> Task.after (\_ -> closure4 {})
|
||||
# ---
|
||||
closure1 : {} -> Task.Task {} []
|
||||
closure1 = \_ ->
|
||||
Task.succeed (foo toUnitBorrowed "a long string such that it's malloced")
|
||||
|> Task.map \_ -> {}
|
||||
|
||||
toUnitBorrowed = \x -> Str.countGraphemes x
|
||||
|
||||
foo = \f, x -> f x
|
||||
|
||||
# ---
|
||||
# closure2 : {} -> Task.Task {} []
|
||||
# closure2 = \_ ->
|
||||
# x : Str
|
||||
# x = "a long string such that it's malloced"
|
||||
#
|
||||
# Task.succeed {}
|
||||
# |> Task.map (\_ -> x)
|
||||
# |> Task.map toUnit
|
||||
#
|
||||
# toUnit = \_ -> {}
|
||||
#
|
||||
# # ---
|
||||
# closure3 : {} -> Task.Task {} []
|
||||
# closure3 = \_ ->
|
||||
# x : Str
|
||||
# x = "a long string such that it's malloced"
|
||||
#
|
||||
# Task.succeed {}
|
||||
# |> Task.after (\_ -> Task.succeed x |> Task.map (\_ -> {}))
|
||||
#
|
||||
# # ---
|
||||
# closure4 : {} -> Task.Task {} []
|
||||
# closure4 = \_ ->
|
||||
# x : Str
|
||||
# x = "a long string such that it's malloced"
|
||||
#
|
||||
# Task.succeed {}
|
||||
# |> Task.after (\_ -> Task.succeed x)
|
||||
# |> Task.map (\_ -> {})
|
||||
167
crates/cli_testing_examples/benchmarks/Deriv.roc
Normal file
167
crates/cli_testing_examples/benchmarks/Deriv.roc
Normal file
|
|
@ -0,0 +1,167 @@
|
|||
app "deriv"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
# based on: https://github.com/koka-lang/koka/blob/master/test/bench/haskell/deriv.hs
|
||||
IO a : Task.Task a []
|
||||
|
||||
main : Task.Task {} []
|
||||
main =
|
||||
Task.after
|
||||
Task.getInt
|
||||
\n ->
|
||||
x : Expr
|
||||
x = Var "x"
|
||||
|
||||
f : Expr
|
||||
f = pow x x
|
||||
|
||||
nest deriv n f # original koka n = 10
|
||||
|> Task.map \_ -> {}
|
||||
|
||||
nest : (I64, Expr -> IO Expr), I64, Expr -> IO Expr
|
||||
nest = \f, n, e -> Task.loop { s: n, f, m: n, x: e } nestHelp
|
||||
|
||||
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)
|
||||
_ ->
|
||||
w <- Task.after (f (s - m) x)
|
||||
|
||||
Task.succeed (Step { s, f, m: (m - 1), x: w })
|
||||
|
||||
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
|
||||
|
||||
pown : I64, I64 -> I64
|
||||
pown = \a, n ->
|
||||
when n is
|
||||
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
|
||||
|
||||
add : Expr, Expr -> Expr
|
||||
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
|
||||
|
||||
mul : Expr, Expr -> Expr
|
||||
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
|
||||
|
||||
ln : Expr -> Expr
|
||||
ln = \f ->
|
||||
when f is
|
||||
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))
|
||||
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
|
||||
|
||||
deriv : I64, Expr -> IO Expr
|
||||
deriv = \i, f ->
|
||||
fprime = d "x" f
|
||||
line =
|
||||
Num.toStr (i + 1)
|
||||
|> Str.concat " count: "
|
||||
|> Str.concat (Num.toStr (count fprime))
|
||||
|
||||
Task.putLine line
|
||||
|> Task.after \_ -> Task.succeed fprime
|
||||
13
crates/cli_testing_examples/benchmarks/Issue2279.roc
Normal file
13
crates/cli_testing_examples/benchmarks/Issue2279.roc
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
app "issue2279"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [Issue2279Help, pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
main =
|
||||
text =
|
||||
if Bool.true then
|
||||
Issue2279Help.text
|
||||
else
|
||||
Issue2279Help.asText 42
|
||||
|
||||
Task.putLine text
|
||||
7
crates/cli_testing_examples/benchmarks/Issue2279Help.roc
Normal file
7
crates/cli_testing_examples/benchmarks/Issue2279Help.roc
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
interface Issue2279Help
|
||||
exposes [text, asText]
|
||||
imports []
|
||||
|
||||
text = "Hello, world!"
|
||||
|
||||
asText = Num.toStr
|
||||
53
crates/cli_testing_examples/benchmarks/NQueens.roc
Normal file
53
crates/cli_testing_examples/benchmarks/NQueens.roc
Normal file
|
|
@ -0,0 +1,53 @@
|
|||
app "nqueens"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
main : Task.Task {} []
|
||||
main =
|
||||
Task.after
|
||||
Task.getInt
|
||||
\n ->
|
||||
queens n # original koka 13
|
||||
|> Num.toStr
|
||||
|> Task.putLine
|
||||
|
||||
ConsList a : [Nil, Cons a (ConsList a)]
|
||||
|
||||
queens = \n -> length (findSolutions n n)
|
||||
|
||||
length : ConsList a -> I64
|
||||
length = \xs -> lengthHelp xs 0
|
||||
|
||||
lengthHelp : ConsList a, I64 -> I64
|
||||
lengthHelp = \foobar, acc ->
|
||||
when foobar is
|
||||
Cons _ lrest -> lengthHelp lrest (1 + acc)
|
||||
Nil -> acc
|
||||
|
||||
safe : I64, I64, ConsList I64 -> Bool
|
||||
safe = \queen, diagonal, xs ->
|
||||
when xs is
|
||||
Nil -> Bool.true
|
||||
Cons q t ->
|
||||
queen != q && queen != q + diagonal && queen != q - diagonal && safe queen (diagonal + 1) t
|
||||
|
||||
appendSafe : I64, ConsList I64, ConsList (ConsList I64) -> ConsList (ConsList I64)
|
||||
appendSafe = \k, soln, solns ->
|
||||
if k <= 0 then
|
||||
solns
|
||||
else if safe k 1 soln then
|
||||
appendSafe (k - 1) soln (Cons (Cons k soln) solns)
|
||||
else
|
||||
appendSafe (k - 1) soln solns
|
||||
|
||||
extend = \n, acc, solutions ->
|
||||
when solutions is
|
||||
Nil -> acc
|
||||
Cons soln rest -> extend n (appendSafe n soln acc) rest
|
||||
|
||||
findSolutions = \n, k ->
|
||||
if k == 0 then
|
||||
Cons Nil Nil
|
||||
else
|
||||
extend n Nil (findSolutions n (k - 1))
|
||||
75
crates/cli_testing_examples/benchmarks/Quicksort.roc
Normal file
75
crates/cli_testing_examples/benchmarks/Quicksort.roc
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
interface Quicksort exposes [sortBy, sortWith, show] imports []
|
||||
|
||||
show : List I64 -> Str
|
||||
show = \list ->
|
||||
if List.isEmpty list then
|
||||
"[]"
|
||||
else
|
||||
content =
|
||||
list
|
||||
|> List.map Num.toStr
|
||||
|> Str.joinWith ", "
|
||||
|
||||
"[\(content)]"
|
||||
|
||||
sortBy : List a, (a -> Num *) -> List a
|
||||
sortBy = \list, toComparable ->
|
||||
sortWith list (\x, y -> Num.compare (toComparable x) (toComparable y))
|
||||
|
||||
Order a : a, a -> [LT, GT, EQ]
|
||||
|
||||
sortWith : List a, (a, a -> [LT, GT, EQ]) -> List a
|
||||
sortWith = \list, order ->
|
||||
n = List.len list
|
||||
|
||||
quicksortHelp list order 0 (n - 1)
|
||||
|
||||
quicksortHelp : List a, Order a, Nat, Nat -> List a
|
||||
quicksortHelp = \list, order, low, high ->
|
||||
if low < high then
|
||||
when partition low high list order is
|
||||
Pair partitionIndex partitioned ->
|
||||
partitioned
|
||||
|> quicksortHelp order low (Num.subSaturated partitionIndex 1)
|
||||
|> quicksortHelp order (partitionIndex + 1) high
|
||||
else
|
||||
list
|
||||
|
||||
partition : Nat, Nat, List a, Order a -> [Pair Nat (List a)]
|
||||
partition = \low, high, initialList, order ->
|
||||
when List.get initialList high is
|
||||
Ok pivot ->
|
||||
when partitionHelp low low initialList order high pivot is
|
||||
Pair newI newList ->
|
||||
Pair newI (swap newI high newList)
|
||||
|
||||
Err _ ->
|
||||
Pair low initialList
|
||||
|
||||
partitionHelp : Nat, Nat, List c, Order c, Nat, c -> [Pair Nat (List c)]
|
||||
partitionHelp = \i, j, list, order, high, pivot ->
|
||||
if j < high then
|
||||
when List.get list j is
|
||||
Ok value ->
|
||||
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
|
||||
Pair i list
|
||||
|
||||
swap : Nat, Nat, List a -> List a
|
||||
swap = \i, j, list ->
|
||||
when Pair (List.get list i) (List.get list j) is
|
||||
Pair (Ok atI) (Ok atJ) ->
|
||||
list
|
||||
|> List.set i atJ
|
||||
|> List.set j atI
|
||||
|
||||
_ ->
|
||||
[]
|
||||
25
crates/cli_testing_examples/benchmarks/QuicksortApp.roc
Normal file
25
crates/cli_testing_examples/benchmarks/QuicksortApp.roc
Normal file
File diff suppressed because one or more lines are too long
131
crates/cli_testing_examples/benchmarks/RBTreeCk.roc
Normal file
131
crates/cli_testing_examples/benchmarks/RBTreeCk.roc
Normal file
|
|
@ -0,0 +1,131 @@
|
|||
app "rbtree-ck"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
Color : [Red, Black]
|
||||
|
||||
Tree a b : [Leaf, Node Color (Tree a b) a b (Tree a b)]
|
||||
|
||||
Map : Tree I64 Bool
|
||||
|
||||
ConsList a : [Nil, Cons a (ConsList a)]
|
||||
|
||||
makeMap : I64, I64 -> ConsList Map
|
||||
makeMap = \freq, n ->
|
||||
makeMapHelp freq n Leaf Nil
|
||||
|
||||
makeMapHelp : I64, I64, Map, ConsList Map -> ConsList Map
|
||||
makeMapHelp = \freq, n, m, acc ->
|
||||
when n is
|
||||
0 -> Cons m acc
|
||||
_ ->
|
||||
powerOf10 =
|
||||
n % 10 == 0
|
||||
|
||||
m1 = insert m n powerOf10
|
||||
|
||||
isFrequency =
|
||||
n % freq == 0
|
||||
|
||||
x = (if isFrequency then Cons m1 acc else acc)
|
||||
|
||||
makeMapHelp freq (n - 1) m1 x
|
||||
|
||||
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))
|
||||
|
||||
main : Task.Task {} []
|
||||
main =
|
||||
Task.after
|
||||
Task.getInt
|
||||
\n ->
|
||||
# original koka n = 4_200_000
|
||||
ms : ConsList Map
|
||||
ms = makeMap 5 n
|
||||
|
||||
when ms is
|
||||
Cons head _ ->
|
||||
val = fold (\_, v, r -> if v then r + 1 else r) head 0
|
||||
|
||||
val
|
||||
|> Num.toStr
|
||||
|> Task.putLine
|
||||
|
||||
Nil ->
|
||||
Task.putLine "fail"
|
||||
|
||||
insert : Tree (Num k) v, Num k, v -> Tree (Num k) v
|
||||
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
|
||||
|
||||
isRed : Tree a b -> Bool
|
||||
isRed = \tree ->
|
||||
when tree is
|
||||
Node Red _ _ _ _ -> Bool.true
|
||||
_ -> Bool.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
|
||||
Node Red a ky vy b ->
|
||||
if lt kx ky then
|
||||
Node Red (ins a kx vx) ky vy b
|
||||
else if lt ky kx then
|
||||
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)
|
||||
else if lt ky kx then
|
||||
(if isRed b then balance2 (Node Black a ky vy Leaf) (ins b kx vx) else Node Black a ky vy (ins b kx vx))
|
||||
else
|
||||
Node Black a kx vx b
|
||||
|
||||
balance1 : Tree a b, Tree a b -> Tree a b
|
||||
balance1 = \tree1, tree2 ->
|
||||
when tree1 is
|
||||
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
|
||||
|
||||
balance2 : Tree a b, Tree a b -> Tree a b
|
||||
balance2 = \tree1, tree2 ->
|
||||
when tree1 is
|
||||
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
|
||||
247
crates/cli_testing_examples/benchmarks/RBTreeDel.roc
Normal file
247
crates/cli_testing_examples/benchmarks/RBTreeDel.roc
Normal file
|
|
@ -0,0 +1,247 @@
|
|||
app "rbtree-del"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
Color : [Red, Black]
|
||||
|
||||
Tree a b : [Leaf, Node Color (Tree a b) a b (Tree a b)]
|
||||
|
||||
Map : Tree I64 Bool
|
||||
|
||||
ConsList a : [Nil, Cons a (ConsList a)]
|
||||
|
||||
main : Task.Task {} []
|
||||
main =
|
||||
Task.after
|
||||
Task.getInt
|
||||
\n ->
|
||||
m = makeMap n # koka original n = 4_200_000
|
||||
val = fold (\_, v, r -> if v then r + 1 else r) m 0
|
||||
|
||||
val
|
||||
|> Num.toStr
|
||||
|> Task.putLine
|
||||
|
||||
boom : Str -> a
|
||||
boom = \_ -> boom ""
|
||||
|
||||
makeMap : I64 -> Map
|
||||
makeMap = \n ->
|
||||
makeMapHelp n n Leaf
|
||||
|
||||
makeMapHelp : I64, I64, Map -> Map
|
||||
makeMapHelp = \total, n, m ->
|
||||
when n is
|
||||
0 -> m
|
||||
_ ->
|
||||
n1 = n - 1
|
||||
|
||||
powerOf10 =
|
||||
n |> Num.isMultipleOf 10
|
||||
|
||||
t1 = insert m n powerOf10
|
||||
|
||||
isFrequency =
|
||||
n |> Num.isMultipleOf 4
|
||||
|
||||
key = n1 + ((total - n1) // 5)
|
||||
t2 = if isFrequency then delete t1 key else t1
|
||||
|
||||
makeMapHelp total n1 t2
|
||||
|
||||
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))
|
||||
|
||||
depth : Tree * * -> I64
|
||||
depth = \tree ->
|
||||
when tree is
|
||||
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
|
||||
|
||||
setBlack : Tree a b -> Tree a b
|
||||
setBlack = \tree ->
|
||||
when tree is
|
||||
Node _ l k v r -> Node Black l k v r
|
||||
_ -> tree
|
||||
|
||||
isRed : Tree a b -> Bool
|
||||
isRed = \tree ->
|
||||
when tree is
|
||||
Node Red _ _ _ _ -> Bool.true
|
||||
_ -> Bool.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)
|
||||
|
||||
Node Black a ky vy b ->
|
||||
when Num.compare kx ky is
|
||||
LT ->
|
||||
when isRed a is
|
||||
Bool.true -> balanceLeft (ins a kx vx) ky vy b
|
||||
Bool.false -> Node Black (ins a kx vx) ky vy b
|
||||
|
||||
GT ->
|
||||
when isRed b is
|
||||
Bool.true -> balanceRight a ky vy (ins b kx vx)
|
||||
Bool.false -> Node Black a ky vy (ins b kx vx)
|
||||
|
||||
EQ ->
|
||||
Node Black a kx vx b
|
||||
|
||||
balanceLeft : Tree a b, a, b, Tree a b -> Tree a b
|
||||
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
|
||||
|
||||
balanceRight : Tree a b, a, b, Tree a b -> Tree a b
|
||||
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 -> Bool.true
|
||||
Red -> Bool.false
|
||||
|
||||
Del a b : [Del (Tree a b) Bool]
|
||||
|
||||
setRed : Map -> Map
|
||||
setRed = \t ->
|
||||
when t is
|
||||
Node _ l k v r ->
|
||||
Node Red l k v r
|
||||
|
||||
_ ->
|
||||
t
|
||||
|
||||
makeBlack : Map -> Del I64 Bool
|
||||
makeBlack = \t ->
|
||||
when t is
|
||||
Node Red l k v r ->
|
||||
Del (Node Black l k v r) Bool.false
|
||||
|
||||
_ ->
|
||||
Del t Bool.true
|
||||
|
||||
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)) Bool.false
|
||||
|
||||
_ ->
|
||||
boom "unreachable"
|
||||
|
||||
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) Bool.false
|
||||
|
||||
_ ->
|
||||
boom "unreachable"
|
||||
|
||||
delMin = \t ->
|
||||
when t is
|
||||
Node Black Leaf k v r ->
|
||||
when r is
|
||||
Leaf ->
|
||||
Delmin (Del Leaf Bool.true) k v
|
||||
|
||||
_ ->
|
||||
Delmin (Del (setBlack r) Bool.false) k v
|
||||
|
||||
Node Red Leaf k v r ->
|
||||
Delmin (Del r Bool.false) k v
|
||||
|
||||
Node c l k v r ->
|
||||
when delMin l is
|
||||
Delmin (Del lx Bool.true) kx vx ->
|
||||
Delmin (rebalanceRight c lx k v r) kx vx
|
||||
|
||||
Delmin (Del lx Bool.false) kx vx ->
|
||||
Delmin (Del (Node c lx k v r) Bool.false) kx vx
|
||||
|
||||
Leaf ->
|
||||
Delmin (Del t Bool.false) 0 Bool.false
|
||||
|
||||
delete : Tree I64 Bool, I64 -> Tree I64 Bool
|
||||
delete = \t, k ->
|
||||
when del t k is
|
||||
Del tx _ ->
|
||||
setBlack tx
|
||||
|
||||
del : Tree I64 Bool, I64 -> Del I64 Bool
|
||||
del = \t, k ->
|
||||
when t is
|
||||
Leaf ->
|
||||
Del Leaf Bool.false
|
||||
|
||||
Node cx lx kx vx rx ->
|
||||
if (k < kx) then
|
||||
when del lx k is
|
||||
Del ly Bool.true ->
|
||||
rebalanceRight cx ly kx vx rx
|
||||
|
||||
Del ly Bool.false ->
|
||||
Del (Node cx ly kx vx rx) Bool.false
|
||||
else if (k > kx) then
|
||||
when del rx k is
|
||||
Del ry Bool.true ->
|
||||
rebalanceLeft cx lx kx vx ry
|
||||
|
||||
Del ry Bool.false ->
|
||||
Del (Node cx lx kx vx ry) Bool.false
|
||||
else
|
||||
when rx is
|
||||
Leaf ->
|
||||
if isBlack cx then makeBlack lx else Del lx Bool.false
|
||||
|
||||
Node _ _ _ _ _ ->
|
||||
when delMin rx is
|
||||
Delmin (Del ry Bool.true) ky vy ->
|
||||
rebalanceLeft cx lx ky vy ry
|
||||
|
||||
Delmin (Del ry Bool.false) ky vy ->
|
||||
Del (Node cx lx ky vy ry) Bool.false
|
||||
101
crates/cli_testing_examples/benchmarks/RBTreeInsert.roc
Normal file
101
crates/cli_testing_examples/benchmarks/RBTreeInsert.roc
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
app "rbtree-insert"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task]
|
||||
provides [main] to pf
|
||||
|
||||
main : Task.Task {} []
|
||||
main =
|
||||
tree : RedBlackTree I64 {}
|
||||
tree = insert 0 {} Empty
|
||||
|
||||
tree
|
||||
|> show
|
||||
|> Task.putLine
|
||||
|
||||
show : RedBlackTree I64 {} -> Str
|
||||
show = \tree -> showRBTree tree Num.toStr (\{} -> "{}")
|
||||
|
||||
showRBTree : RedBlackTree k v, (k -> Str), (v -> Str) -> Str
|
||||
showRBTree = \tree, showKey, showValue ->
|
||||
when tree is
|
||||
Empty -> "Empty"
|
||||
Node color key value left right ->
|
||||
sColor = showColor color
|
||||
sKey = showKey key
|
||||
sValue = showValue value
|
||||
sL = nodeInParens left showKey showValue
|
||||
sR = nodeInParens right showKey showValue
|
||||
|
||||
"Node \(sColor) \(sKey) \(sValue) \(sL) \(sR)"
|
||||
|
||||
nodeInParens : RedBlackTree k v, (k -> Str), (v -> Str) -> Str
|
||||
nodeInParens = \tree, showKey, showValue ->
|
||||
when tree is
|
||||
Empty ->
|
||||
showRBTree tree showKey showValue
|
||||
|
||||
Node _ _ _ _ _ ->
|
||||
inner = showRBTree tree showKey showValue
|
||||
|
||||
"(\(inner))"
|
||||
|
||||
showColor : NodeColor -> Str
|
||||
showColor = \color ->
|
||||
when color is
|
||||
Red -> "Red"
|
||||
Black -> "Black"
|
||||
|
||||
NodeColor : [Red, Black]
|
||||
|
||||
RedBlackTree k v : [Node NodeColor k v (RedBlackTree k v) (RedBlackTree k v), Empty]
|
||||
|
||||
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
|
||||
|
||||
insertHelp : Key k, v, RedBlackTree (Key k) v -> RedBlackTree (Key k) v
|
||||
insertHelp = \key, value, dict ->
|
||||
when dict is
|
||||
Empty ->
|
||||
# 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)
|
||||
|
||||
balance : NodeColor, k, v, RedBlackTree k v, RedBlackTree k v -> RedBlackTree k v
|
||||
balance = \color, key, value, left, right ->
|
||||
when right is
|
||||
Node Red rK rV rLeft rRight ->
|
||||
when left is
|
||||
Node Red lK lV lLeft lRight ->
|
||||
Node
|
||||
Red
|
||||
key
|
||||
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 ->
|
||||
Node
|
||||
Red
|
||||
lK
|
||||
lV
|
||||
(Node Black llK llV llLeft llRight)
|
||||
(Node Black key value lRight right)
|
||||
|
||||
_ ->
|
||||
Node color key value left right
|
||||
46
crates/cli_testing_examples/benchmarks/TestAStar.roc
Normal file
46
crates/cli_testing_examples/benchmarks/TestAStar.roc
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
app "test-astar"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task, AStar]
|
||||
provides [main] to pf
|
||||
|
||||
main : Task.Task {} []
|
||||
main =
|
||||
Task.putLine (showBool test1)
|
||||
|
||||
# Task.after Task.getInt \n ->
|
||||
# when n is
|
||||
# 1 ->
|
||||
# Task.putLine (showBool test1)
|
||||
#
|
||||
# _ ->
|
||||
# ns = Num.toStr n
|
||||
# Task.putLine "No test \(ns)"
|
||||
showBool : Bool -> Str
|
||||
showBool = \b ->
|
||||
if
|
||||
b
|
||||
then
|
||||
"True"
|
||||
else
|
||||
"False"
|
||||
|
||||
test1 : Bool
|
||||
test1 =
|
||||
example1 == [2, 4]
|
||||
|
||||
example1 : List I64
|
||||
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 []
|
||||
|
||||
cost : I64, I64 -> F64
|
||||
cost = \_, _ -> 1
|
||||
|
||||
when AStar.findPath cost step 1 4 is
|
||||
Ok path -> path
|
||||
Err _ -> []
|
||||
18
crates/cli_testing_examples/benchmarks/TestBase64.roc
Normal file
18
crates/cli_testing_examples/benchmarks/TestBase64.roc
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
app "test-base64"
|
||||
packages { pf: "platform/main.roc" }
|
||||
imports [pf.Task, Base64]
|
||||
provides [main] to pf
|
||||
|
||||
IO a : Task.Task a []
|
||||
|
||||
main : IO {}
|
||||
main =
|
||||
when Base64.fromBytes (Str.toUtf8 "Hello World") is
|
||||
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"
|
||||
10
crates/cli_testing_examples/benchmarks/platform/Effect.roc
Normal file
10
crates/cli_testing_examples/benchmarks/platform/Effect.roc
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
hosted Effect
|
||||
exposes [Effect, after, map, always, forever, loop, putLine, putInt, getInt]
|
||||
imports []
|
||||
generates Effect with [after, map, always, forever, loop]
|
||||
|
||||
putLine : Str -> Effect {}
|
||||
|
||||
putInt : I64 -> Effect {}
|
||||
|
||||
getInt : Effect { value : I64, isError : Bool }
|
||||
78
crates/cli_testing_examples/benchmarks/platform/Task.roc
Normal file
78
crates/cli_testing_examples/benchmarks/platform/Task.roc
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
interface Task
|
||||
exposes [Task, succeed, fail, after, map, putLine, putInt, getInt, forever, loop]
|
||||
imports [pf.Effect]
|
||||
|
||||
Task ok err : Effect.Effect (Result ok err)
|
||||
|
||||
forever : Task val err -> Task * err
|
||||
forever = \task ->
|
||||
looper = \{} ->
|
||||
task
|
||||
|> Effect.map
|
||||
\res ->
|
||||
when res is
|
||||
Ok _ -> Step {}
|
||||
Err e -> Done (Err e)
|
||||
|
||||
Effect.loop {} looper
|
||||
|
||||
loop : state, (state -> Task [Step state, Done done] err) -> Task done err
|
||||
loop = \state, step ->
|
||||
looper = \current ->
|
||||
step current
|
||||
|> Effect.map
|
||||
\res ->
|
||||
when res is
|
||||
Ok (Step newState) -> Step newState
|
||||
Ok (Done result) -> Done (Ok result)
|
||||
Err e -> Done (Err e)
|
||||
|
||||
Effect.loop state looper
|
||||
|
||||
succeed : val -> Task val *
|
||||
succeed = \val ->
|
||||
Effect.always (Ok val)
|
||||
|
||||
fail : err -> Task * err
|
||||
fail = \val ->
|
||||
Effect.always (Err val)
|
||||
|
||||
after : Task a err, (a -> Task b err) -> Task b err
|
||||
after = \effect, transform ->
|
||||
Effect.after
|
||||
effect
|
||||
\result ->
|
||||
when result is
|
||||
Ok a -> transform a
|
||||
Err err -> Task.fail err
|
||||
|
||||
map : Task a err, (a -> b) -> Task b err
|
||||
map = \effect, transform ->
|
||||
Effect.map
|
||||
effect
|
||||
\result ->
|
||||
when result is
|
||||
Ok a -> Ok (transform a)
|
||||
Err err -> Err err
|
||||
|
||||
putLine : Str -> Task {} *
|
||||
putLine = \line -> Effect.map (Effect.putLine line) (\_ -> Ok {})
|
||||
|
||||
putInt : I64 -> Task {} *
|
||||
putInt = \line -> Effect.map (Effect.putInt line) (\_ -> Ok {})
|
||||
|
||||
getInt : Task I64 []
|
||||
getInt =
|
||||
Effect.after
|
||||
Effect.getInt
|
||||
\{ isError, value } ->
|
||||
if
|
||||
isError
|
||||
then
|
||||
# when errorCode is
|
||||
# # A -> Task.fail InvalidCharacter
|
||||
# # B -> Task.fail IOError
|
||||
# _ ->
|
||||
Task.succeed -1
|
||||
else
|
||||
Task.succeed value
|
||||
217
crates/cli_testing_examples/benchmarks/platform/host.zig
Normal file
217
crates/cli_testing_examples/benchmarks/platform/host.zig
Normal file
|
|
@ -0,0 +1,217 @@
|
|||
const std = @import("std");
|
||||
const str = @import("str");
|
||||
const RocStr = str.RocStr;
|
||||
const testing = std.testing;
|
||||
const expectEqual = testing.expectEqual;
|
||||
const expect = testing.expect;
|
||||
const maxInt = std.math.maxInt;
|
||||
|
||||
comptime {
|
||||
// This is a workaround for https://github.com/ziglang/zig/issues/8218
|
||||
// which is only necessary on macOS.
|
||||
//
|
||||
// Once that issue is fixed, we can undo the changes in
|
||||
// 177cf12e0555147faa4d436e52fc15175c2c4ff0 and go back to passing
|
||||
// -fcompiler-rt in link.rs instead of doing this. Note that this
|
||||
// workaround is present in many host.zig files, so make sure to undo
|
||||
// it everywhere!
|
||||
const builtin = @import("builtin");
|
||||
if (builtin.os.tag == .macos) {
|
||||
_ = @import("compiler_rt");
|
||||
}
|
||||
}
|
||||
|
||||
const mem = std.mem;
|
||||
const Allocator = mem.Allocator;
|
||||
|
||||
extern fn roc__mainForHost_1_exposed_generic([*]u8) void;
|
||||
extern fn roc__mainForHost_size() i64;
|
||||
extern fn roc__mainForHost_1__Fx_caller(*const u8, [*]u8, [*]u8) void;
|
||||
extern fn roc__mainForHost_1__Fx_size() i64;
|
||||
extern fn roc__mainForHost_1__Fx_result_size() i64;
|
||||
|
||||
const Align = 2 * @alignOf(usize);
|
||||
extern fn malloc(size: usize) callconv(.C) ?*align(Align) anyopaque;
|
||||
extern fn realloc(c_ptr: [*]align(Align) u8, size: usize) callconv(.C) ?*anyopaque;
|
||||
extern fn free(c_ptr: [*]align(Align) u8) callconv(.C) void;
|
||||
extern fn memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void;
|
||||
extern fn memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void;
|
||||
|
||||
const DEBUG: bool = false;
|
||||
|
||||
export fn roc_alloc(size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
var ptr = malloc(size);
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("alloc: {d} (alignment {d}, size {d})\n", .{ ptr, alignment, size }) catch unreachable;
|
||||
return ptr;
|
||||
} else {
|
||||
return malloc(size);
|
||||
}
|
||||
}
|
||||
|
||||
export fn roc_realloc(c_ptr: *anyopaque, new_size: usize, old_size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("realloc: {d} (alignment {d}, old_size {d})\n", .{ c_ptr, alignment, old_size }) catch unreachable;
|
||||
}
|
||||
|
||||
return realloc(@alignCast(Align, @ptrCast([*]u8, c_ptr)), new_size);
|
||||
}
|
||||
|
||||
export fn roc_dealloc(c_ptr: *anyopaque, alignment: u32) callconv(.C) void {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("dealloc: {d} (alignment {d})\n", .{ c_ptr, alignment }) catch unreachable;
|
||||
}
|
||||
|
||||
free(@alignCast(Align, @ptrCast([*]u8, c_ptr)));
|
||||
}
|
||||
|
||||
export fn roc_panic(c_ptr: *anyopaque, tag_id: u32) callconv(.C) void {
|
||||
_ = tag_id;
|
||||
|
||||
const stderr = std.io.getStdErr().writer();
|
||||
const msg = @ptrCast([*:0]const u8, c_ptr);
|
||||
stderr.print("Application crashed with message\n\n {s}\n\nShutting down\n", .{msg}) catch unreachable;
|
||||
std.process.exit(0);
|
||||
}
|
||||
|
||||
export fn roc_memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void {
|
||||
return memcpy(dst, src, size);
|
||||
}
|
||||
|
||||
export fn roc_memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void {
|
||||
return memset(dst, value, size);
|
||||
}
|
||||
|
||||
const Unit = extern struct {};
|
||||
|
||||
pub fn main() !u8 {
|
||||
const stderr = std.io.getStdErr().writer();
|
||||
|
||||
// The size might be zero; if so, make it at least 8 so that we don't have a nullptr
|
||||
const size = std.math.max(@intCast(usize, roc__mainForHost_size()), 8);
|
||||
const raw_output = roc_alloc(@intCast(usize, size), @alignOf(u64)).?;
|
||||
var output = @ptrCast([*]u8, raw_output);
|
||||
|
||||
defer {
|
||||
roc_dealloc(raw_output, @alignOf(u64));
|
||||
}
|
||||
|
||||
var timer = std.time.Timer.start() catch unreachable;
|
||||
|
||||
roc__mainForHost_1_exposed_generic(output);
|
||||
|
||||
const closure_data_pointer = @ptrCast([*]u8, output);
|
||||
|
||||
call_the_closure(closure_data_pointer);
|
||||
|
||||
const nanos = timer.read();
|
||||
const seconds = (@intToFloat(f64, nanos) / 1_000_000_000.0);
|
||||
|
||||
stderr.print("runtime: {d:.3}ms\n", .{seconds * 1000}) catch unreachable;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
fn to_seconds(tms: std.os.timespec) f64 {
|
||||
return @intToFloat(f64, tms.tv_sec) + (@intToFloat(f64, tms.tv_nsec) / 1_000_000_000.0);
|
||||
}
|
||||
|
||||
fn call_the_closure(closure_data_pointer: [*]u8) void {
|
||||
const allocator = std.heap.page_allocator;
|
||||
|
||||
// The size might be zero; if so, make it at least 8 so that we don't have a nullptr
|
||||
const size = std.math.max(roc__mainForHost_1__Fx_result_size(), 8);
|
||||
const raw_output = allocator.allocAdvanced(u8, @alignOf(u64), @intCast(usize, size), .at_least) catch unreachable;
|
||||
var output = @ptrCast([*]u8, raw_output);
|
||||
|
||||
defer {
|
||||
allocator.free(raw_output);
|
||||
}
|
||||
|
||||
const flags: u8 = 0;
|
||||
|
||||
roc__mainForHost_1__Fx_caller(&flags, closure_data_pointer, output);
|
||||
|
||||
// The closure returns result, nothing interesting to do with it
|
||||
return;
|
||||
}
|
||||
|
||||
pub export fn roc_fx_putInt(int: i64) i64 {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
|
||||
stdout.print("{d}", .{int}) catch unreachable;
|
||||
|
||||
stdout.print("\n", .{}) catch unreachable;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
export fn roc_fx_putLine(rocPath: *str.RocStr) callconv(.C) void {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
|
||||
for (rocPath.asSlice()) |char| {
|
||||
stdout.print("{c}", .{char}) catch unreachable;
|
||||
}
|
||||
|
||||
stdout.print("\n", .{}) catch unreachable;
|
||||
}
|
||||
|
||||
const GetInt = extern struct {
|
||||
value: i64,
|
||||
is_error: bool,
|
||||
};
|
||||
|
||||
comptime {
|
||||
if (@sizeOf(usize) == 8) {
|
||||
@export(roc_fx_getInt_64bit, .{ .name = "roc_fx_getInt" });
|
||||
} else {
|
||||
@export(roc_fx_getInt_32bit, .{ .name = "roc_fx_getInt" });
|
||||
}
|
||||
}
|
||||
|
||||
fn roc_fx_getInt_64bit() callconv(.C) GetInt {
|
||||
if (roc_fx_getInt_help()) |value| {
|
||||
const get_int = GetInt{ .is_error = false, .value = value };
|
||||
return get_int;
|
||||
} else |err| switch (err) {
|
||||
error.InvalidCharacter => {
|
||||
return GetInt{ .is_error = true, .value = 0 };
|
||||
},
|
||||
else => {
|
||||
return GetInt{ .is_error = true, .value = 0 };
|
||||
},
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
fn roc_fx_getInt_32bit(output: *GetInt) callconv(.C) void {
|
||||
if (roc_fx_getInt_help()) |value| {
|
||||
const get_int = GetInt{ .is_error = false, .value = value, .error_code = false };
|
||||
output.* = get_int;
|
||||
} else |err| switch (err) {
|
||||
error.InvalidCharacter => {
|
||||
output.* = GetInt{ .is_error = true, .value = 0, .error_code = false };
|
||||
},
|
||||
else => {
|
||||
output.* = GetInt{ .is_error = true, .value = 0, .error_code = true };
|
||||
},
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
fn roc_fx_getInt_help() !i64 {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("Please enter an integer\n", .{}) catch unreachable;
|
||||
|
||||
const stdin = std.io.getStdIn().reader();
|
||||
var buf: [40]u8 = undefined;
|
||||
|
||||
const line: []u8 = (try stdin.readUntilDelimiterOrEof(&buf, '\n')) orelse "";
|
||||
|
||||
return std.fmt.parseInt(i64, line, 10);
|
||||
}
|
||||
9
crates/cli_testing_examples/benchmarks/platform/main.roc
Normal file
9
crates/cli_testing_examples/benchmarks/platform/main.roc
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
platform "benchmarks"
|
||||
requires {} { main : Task {} [] }
|
||||
exposes []
|
||||
packages {}
|
||||
imports [Task.{ Task }]
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : Task {} [] as Fx
|
||||
mainForHost = main
|
||||
7
crates/cli_testing_examples/platform-switching/.gitignore
vendored
Normal file
7
crates/cli_testing_examples/platform-switching/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
rocLovesC
|
||||
rocLovesPlatforms
|
||||
rocLovesRust
|
||||
rocLovesSwift
|
||||
rocLovesWebAssembly
|
||||
rocLovesZig
|
||||
*.wasm
|
||||
20
crates/cli_testing_examples/platform-switching/README.md
Normal file
20
crates/cli_testing_examples/platform-switching/README.md
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
# Platform switching
|
||||
|
||||
To run, `cd` into this directory and run this in your terminal:
|
||||
|
||||
```bash
|
||||
roc run
|
||||
```
|
||||
|
||||
This will run `main.roc` because, unless you explicitly give it a filename, `roc run`
|
||||
defaults to running a file named `main.roc`. Other `roc` commands (like `roc build`, `roc test`, and so on) also default to `main.roc` unless you explicitly give them a filename.
|
||||
|
||||
## About this example
|
||||
|
||||
This uses a very simple platform which does nothing more than printing the string you give it.
|
||||
|
||||
The line `main = "Which platform am I running on now?\n"` sets this string to be `"Which platform am I running on now?"` with a newline at the end, and the lines `packages { pf: "c-platform/main.roc" }` and `provides [main] to pf` specify that the `c-platform/` directory contains this app's platform.
|
||||
|
||||
This platform is called `c-platform` because its lower-level code is written in C. There's also a `rust-platform`, `zig-platform`, and so on; if you like, you can try switching `pf: "c-platform/main.roc"` to `pf: "zig-platform/main.roc"` or `pf: "rust-platform/main.roc"` to try one of those platforms instead. They all do similar things, so the application won't look any different.
|
||||
|
||||
If you want to start building your own platforms, these are some very simple example platforms to use as starting points.
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
#include <errno.h>
|
||||
#include <stdbool.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <unistd.h>
|
||||
|
||||
void* roc_alloc(size_t size, unsigned int alignment) { return malloc(size); }
|
||||
|
||||
void* roc_realloc(void* ptr, size_t new_size, size_t old_size,
|
||||
unsigned int alignment) {
|
||||
return realloc(ptr, new_size);
|
||||
}
|
||||
|
||||
void roc_dealloc(void* ptr, unsigned int alignment) { free(ptr); }
|
||||
|
||||
void roc_panic(void* ptr, unsigned int alignment) {
|
||||
char* msg = (char*)ptr;
|
||||
fprintf(stderr,
|
||||
"Application crashed with message\n\n %s\n\nShutting down\n", msg);
|
||||
exit(0);
|
||||
}
|
||||
|
||||
void* roc_memcpy(void* dest, const void* src, size_t n) {
|
||||
return memcpy(dest, src, n);
|
||||
}
|
||||
|
||||
void* roc_memset(void* str, int c, size_t n) { return memset(str, c, n); }
|
||||
|
||||
struct RocStr {
|
||||
char* bytes;
|
||||
size_t len;
|
||||
size_t capacity;
|
||||
};
|
||||
|
||||
bool is_small_str(struct RocStr str) { return ((ssize_t)str.capacity) < 0; }
|
||||
|
||||
// Determine the length of the string, taking into
|
||||
// account the small string optimization
|
||||
size_t roc_str_len(struct RocStr str) {
|
||||
char* bytes = (char*)&str;
|
||||
char last_byte = bytes[sizeof(str) - 1];
|
||||
char last_byte_xored = last_byte ^ 0b10000000;
|
||||
size_t small_len = (size_t)(last_byte_xored);
|
||||
size_t big_len = str.len;
|
||||
|
||||
// Avoid branch misprediction costs by always
|
||||
// determining both small_len and big_len,
|
||||
// so this compiles to a cmov instruction.
|
||||
if (is_small_str(str)) {
|
||||
return small_len;
|
||||
} else {
|
||||
return big_len;
|
||||
}
|
||||
}
|
||||
|
||||
extern void roc__mainForHost_1_exposed_generic(struct RocStr *string);
|
||||
|
||||
int main() {
|
||||
|
||||
struct RocStr str;
|
||||
roc__mainForHost_1_exposed_generic(&str);
|
||||
|
||||
// Determine str_len and the str_bytes pointer,
|
||||
// taking into account the small string optimization.
|
||||
size_t str_len = roc_str_len(str);
|
||||
char* str_bytes;
|
||||
|
||||
if (is_small_str(str)) {
|
||||
str_bytes = (char*)&str;
|
||||
} else {
|
||||
str_bytes = str.bytes;
|
||||
}
|
||||
|
||||
// Write to stdout
|
||||
if (write(1, str_bytes, str_len) >= 0) {
|
||||
// Writing succeeded!
|
||||
|
||||
// NOTE: the string is a static string, read from in the binary
|
||||
// if you make it a heap-allocated string, it'll be leaked here
|
||||
return 0;
|
||||
} else {
|
||||
printf("Error writing to stdout: %s\n", strerror(errno));
|
||||
|
||||
// NOTE: the string is a static string, read from in the binary
|
||||
// if you make it a heap-allocated string, it'll be leaked here
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
platform "echo-in-c"
|
||||
requires {} { main : Str }
|
||||
exposes []
|
||||
packages {}
|
||||
imports []
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : Str
|
||||
mainForHost = main
|
||||
11
crates/cli_testing_examples/platform-switching/main.roc
Normal file
11
crates/cli_testing_examples/platform-switching/main.roc
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
app "rocLovesPlatforms"
|
||||
packages { pf: "c-platform/main.roc" }
|
||||
# To switch platforms, comment-out the line above and un-comment one below.
|
||||
# packages { pf: "rust-platform/main.roc" }
|
||||
# packages { pf: "swift-platform/main.roc" }
|
||||
# packages { pf: "web-assembly-platform/main.roc" } # See ./web-assembly-platform/README.md
|
||||
# packages { pf: "zig-platform/main.roc" }
|
||||
imports []
|
||||
provides [main] to pf
|
||||
|
||||
main = "Which platform am I running on now?\n"
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
app "rocLovesC"
|
||||
packages { pf: "c-platform/main.roc" }
|
||||
imports []
|
||||
provides [main] to pf
|
||||
|
||||
main = "Roc <3 C!\n"
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
app "rocLovesRust"
|
||||
packages { pf: "rust-platform/main.roc" }
|
||||
imports []
|
||||
provides [main] to pf
|
||||
|
||||
main = "Roc <3 Rust!\n"
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
app "rocLovesSwift"
|
||||
packages { pf: "swift-platform/main.roc" }
|
||||
imports []
|
||||
provides [main] to pf
|
||||
|
||||
main = "Roc <3 Swift!\n"
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
app "rocLovesWebAssembly"
|
||||
packages { pf: "web-assembly-platform/main.roc" }
|
||||
imports []
|
||||
provides [main] to pf
|
||||
|
||||
main = "Roc <3 Web Assembly!\n"
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
app "rocLovesZig"
|
||||
packages { pf: "zig-platform/main.roc" }
|
||||
imports []
|
||||
provides [main] to pf
|
||||
|
||||
main = "Roc <3 Zig!\n"
|
||||
37
crates/cli_testing_examples/platform-switching/rust-platform/Cargo.lock
generated
Normal file
37
crates/cli_testing_examples/platform-switching/rust-platform/Cargo.lock
generated
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
# This file is automatically @generated by Cargo.
|
||||
# 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.0.1"
|
||||
dependencies = [
|
||||
"libc",
|
||||
"roc_std",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "libc"
|
||||
version = "0.2.92"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "56d855069fafbb9b344c0f962150cd2c1187975cb1c22c1522c240d8c4986714"
|
||||
|
||||
[[package]]
|
||||
name = "roc_std"
|
||||
version = "0.0.1"
|
||||
dependencies = [
|
||||
"arrayvec",
|
||||
"static_assertions",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "static_assertions"
|
||||
version = "1.1.0"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "a2eb9349b6444b326872e140eb1cf5e7c522154d69e7a0ffb0fb81c06b37543f"
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
[package]
|
||||
name = "host"
|
||||
version = "0.0.1"
|
||||
authors = ["The Roc Contributors"]
|
||||
license = "UPL-1.0"
|
||||
edition = "2021"
|
||||
links = "app"
|
||||
|
||||
[lib]
|
||||
name = "host"
|
||||
path = "src/lib.rs"
|
||||
crate-type = ["staticlib", "rlib"]
|
||||
|
||||
[[bin]]
|
||||
name = "host"
|
||||
path = "src/main.rs"
|
||||
|
||||
[dependencies]
|
||||
roc_std = { path = "../../../../crates/roc_std" }
|
||||
libc = "0.2"
|
||||
|
||||
[workspace]
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
fn main() {
|
||||
println!("cargo:rustc-link-lib=dylib=app");
|
||||
println!("cargo:rustc-link-search=.");
|
||||
}
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
extern int rust_main();
|
||||
|
||||
int main() { return rust_main(); }
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
platform "echo-in-rust"
|
||||
requires {} { main : Str }
|
||||
exposes []
|
||||
packages {}
|
||||
imports []
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : Str
|
||||
mainForHost = main
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
#![allow(non_snake_case)]
|
||||
|
||||
use core::ffi::c_void;
|
||||
use roc_std::RocStr;
|
||||
use std::ffi::CStr;
|
||||
use std::mem::ManuallyDrop;
|
||||
use std::os::raw::c_char;
|
||||
|
||||
extern "C" {
|
||||
#[link_name = "roc__mainForHost_1_exposed_generic"]
|
||||
fn roc_main(_: &mut RocStr);
|
||||
}
|
||||
|
||||
#[no_mangle]
|
||||
pub unsafe extern "C" fn roc_alloc(size: usize, _alignment: u32) -> *mut c_void {
|
||||
return libc::malloc(size);
|
||||
}
|
||||
|
||||
#[no_mangle]
|
||||
pub unsafe extern "C" fn roc_realloc(
|
||||
c_ptr: *mut c_void,
|
||||
new_size: usize,
|
||||
_old_size: usize,
|
||||
_alignment: u32,
|
||||
) -> *mut c_void {
|
||||
return libc::realloc(c_ptr, new_size);
|
||||
}
|
||||
|
||||
#[no_mangle]
|
||||
pub unsafe extern "C" fn roc_dealloc(c_ptr: *mut c_void, _alignment: u32) {
|
||||
return libc::free(c_ptr);
|
||||
}
|
||||
|
||||
#[no_mangle]
|
||||
pub unsafe extern "C" fn roc_panic(c_ptr: *mut c_void, tag_id: u32) {
|
||||
match tag_id {
|
||||
0 => {
|
||||
let slice = CStr::from_ptr(c_ptr as *const c_char);
|
||||
let string = slice.to_str().unwrap();
|
||||
eprintln!("Roc hit a panic: {}", string);
|
||||
std::process::exit(1);
|
||||
}
|
||||
_ => todo!(),
|
||||
}
|
||||
}
|
||||
|
||||
#[no_mangle]
|
||||
pub unsafe extern "C" fn roc_memcpy(dst: *mut c_void, src: *mut c_void, n: usize) -> *mut c_void {
|
||||
libc::memcpy(dst, src, n)
|
||||
}
|
||||
|
||||
#[no_mangle]
|
||||
pub unsafe extern "C" fn roc_memset(dst: *mut c_void, c: i32, n: usize) -> *mut c_void {
|
||||
libc::memset(dst, c, n)
|
||||
}
|
||||
|
||||
#[no_mangle]
|
||||
pub extern "C" fn rust_main() -> i32 {
|
||||
unsafe {
|
||||
// ManuallyDrop must be used here in order to prevent the RocStr from
|
||||
// getting dropped as soon as it's no longer referenced anywhere, which
|
||||
// happens earlier than the libc::write that receives a pointer to its data.
|
||||
let mut roc_str = ManuallyDrop::new(RocStr::default());
|
||||
roc_main(&mut roc_str);
|
||||
|
||||
let len = roc_str.len();
|
||||
let str_bytes = roc_str.as_bytes().as_ptr() as *const libc::c_void;
|
||||
|
||||
if libc::write(1, str_bytes, len) < 0 {
|
||||
panic!("Writing to stdout failed!");
|
||||
}
|
||||
|
||||
ManuallyDrop::drop(&mut roc_str)
|
||||
}
|
||||
|
||||
// Exit code
|
||||
0
|
||||
}
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
fn main() {
|
||||
std::process::exit(host::rust_main() as _);
|
||||
}
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
#include <stdlib.h>
|
||||
|
||||
struct RocStr {
|
||||
char* bytes;
|
||||
size_t len;
|
||||
size_t capacity;
|
||||
};
|
||||
|
||||
extern void roc__mainForHost_1_exposed_generic(const struct RocStr *data);
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
import Foundation
|
||||
|
||||
@_cdecl("roc_alloc")
|
||||
func rocAlloc(size: Int, _alignment: UInt) -> UInt {
|
||||
guard let ptr = malloc(size) else {
|
||||
return 0
|
||||
}
|
||||
return UInt(bitPattern: ptr)
|
||||
}
|
||||
|
||||
@_cdecl("roc_dealloc")
|
||||
func rocDealloc(ptr: UInt, _alignment: UInt) {
|
||||
free(UnsafeMutableRawPointer(bitPattern: ptr))
|
||||
}
|
||||
|
||||
@_cdecl("roc_realloc")
|
||||
func rocRealloc(ptr: UInt, _oldSize: Int, newSize: Int, _alignment: UInt) -> UInt {
|
||||
guard let ptr = realloc(UnsafeMutableRawPointer(bitPattern: ptr), newSize) else {
|
||||
return 0
|
||||
}
|
||||
return UInt(bitPattern: ptr)
|
||||
}
|
||||
|
||||
func isSmallString(rocStr: RocStr) -> Bool {
|
||||
return rocStr.capacity < 0
|
||||
}
|
||||
|
||||
func getStrLen(rocStr: RocStr) -> Int {
|
||||
if isSmallString(rocStr: rocStr) {
|
||||
// Small String length is last in the byte of capacity.
|
||||
var cap = rocStr.capacity
|
||||
let count = MemoryLayout.size(ofValue: cap)
|
||||
let bytes = Data(bytes: &cap, count: count)
|
||||
let lastByte = bytes[count - 1]
|
||||
return Int(lastByte ^ 0b1000_0000)
|
||||
} else {
|
||||
return rocStr.len
|
||||
}
|
||||
}
|
||||
|
||||
func getSwiftString(rocStr: RocStr) -> String {
|
||||
let length = getStrLen(rocStr: rocStr)
|
||||
|
||||
if isSmallString(rocStr: rocStr) {
|
||||
let data: Data = withUnsafePointer(to: rocStr) { ptr in
|
||||
Data(bytes: ptr, count: length)
|
||||
}
|
||||
return String(data: data, encoding: .utf8)!
|
||||
} else {
|
||||
let data = Data(bytes: rocStr.bytes, count: length)
|
||||
return String(data: data, encoding: .utf8)!
|
||||
}
|
||||
}
|
||||
|
||||
@_cdecl("main")
|
||||
func main() -> UInt8 {
|
||||
var rocStr = RocStr()
|
||||
roc__mainForHost_1_exposed_generic(&rocStr)
|
||||
|
||||
print(getSwiftString(rocStr: rocStr), terminator: "")
|
||||
return 0
|
||||
}
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
platform "echo-in-swift"
|
||||
requires {} { main : Str }
|
||||
exposes []
|
||||
packages {}
|
||||
imports []
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : Str
|
||||
mainForHost = main
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
# Hello, World!
|
||||
|
||||
To run this website, first compile either of these identical apps:
|
||||
|
||||
```bash
|
||||
# Option A: Compile crates/cli_testing_examples/platform-switching/rocLovesWebAssembly.roc
|
||||
cargo run -- build --target=wasm32 crates/cli_testing_examples/platform-switching/rocLovesWebAssembly.roc
|
||||
|
||||
# Option B: Compile crates/cli_testing_examples/platform-switching/main.roc with `pf: "web-assembly-platform/main.roc"` and move the result
|
||||
cargo run -- build --target=wasm32 crates/cli_testing_examples/platform-switching/main.roc
|
||||
(cd crates/cli_testing_examples/platform-switching && mv rocLovesPlatforms.wasm web-assembly-platform/rocLovesWebAssembly.wasm)
|
||||
```
|
||||
|
||||
Then `cd` into the website directory
|
||||
and run any web server that can handle WebAssembly.
|
||||
For example, with `http-server`:
|
||||
|
||||
```bash
|
||||
cd crates/cli_testing_examples/platform-switching/web-assembly-platform
|
||||
npm install -g http-server
|
||||
http-server
|
||||
```
|
||||
|
||||
Now open your browser at <http://localhost:8080>
|
||||
|
||||
## Design Notes
|
||||
|
||||
This demonstrates the basic design of hosts: Roc code gets compiled into a pure
|
||||
function (in this case, a thunk that always returns `"Hello, World!\n"`) and
|
||||
then the host calls that function. Fundamentally, that's the whole idea! The host
|
||||
might not even have a `main` - it could be a library, a plugin, anything.
|
||||
Everything else is built on this basic "hosts calling linked pure functions" design.
|
||||
|
||||
For example, things get more interesting when the compiled Roc function returns
|
||||
a `Task` - that is, a tagged union data structure containing function pointers
|
||||
to callback closures. This lets the Roc pure function describe arbitrary
|
||||
chainable effects, which the host can interpret to perform I/O as requested by
|
||||
the Roc program. (The tagged union `Task` would have a variant for each supported
|
||||
I/O operation.)
|
||||
|
||||
In this trivial example, it's very easy to line up the API between the host and
|
||||
the Roc program. In a more involved host, this would be much trickier - especially
|
||||
if the API were changing frequently during development.
|
||||
|
||||
The idea there is to have a first-class concept of "glue code" which host authors
|
||||
can write (it would be plain Roc code, but with some extra keywords that aren't
|
||||
available in normal modules - kinda like `port module` in Elm), and which
|
||||
describe both the Roc-host/C boundary as well as the Roc-host/Roc-app boundary.
|
||||
Roc application authors only care about the Roc-host/Roc-app portion, and the
|
||||
host author only cares about the Roc-host/C boundary when implementing the host.
|
||||
|
||||
Using this glue code, the Roc compiler can generate C header files describing the
|
||||
boundary. This not only gets us host compatibility with C compilers, but also
|
||||
Rust FFI for free, because [`rust-bindgen`](https://github.com/rust-lang/rust-bindgen)
|
||||
generates correct Rust FFI bindings from C headers.
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
async function roc_web_platform_run(wasm_filename, callback) {
|
||||
const decoder = new TextDecoder();
|
||||
let memory_bytes;
|
||||
let exit_code;
|
||||
|
||||
function js_display_roc_string(str_bytes, str_len) {
|
||||
const utf8_bytes = memory_bytes.subarray(str_bytes, str_bytes + str_len);
|
||||
const js_string = decoder.decode(utf8_bytes);
|
||||
callback(js_string);
|
||||
}
|
||||
|
||||
const importObj = {
|
||||
wasi_snapshot_preview1: {
|
||||
proc_exit: (code) => {
|
||||
if (code !== 0) {
|
||||
console.error(`Exited with code ${code}`);
|
||||
}
|
||||
exit_code = code;
|
||||
},
|
||||
fd_write: (x) => { console.error(`fd_write not supported: ${x}`); }
|
||||
},
|
||||
env: {
|
||||
js_display_roc_string,
|
||||
roc_panic: (_pointer, _tag_id) => {
|
||||
throw "Roc panicked!";
|
||||
},
|
||||
},
|
||||
};
|
||||
|
||||
let wasm;
|
||||
|
||||
const response = await fetch(wasm_filename);
|
||||
|
||||
if (WebAssembly.instantiateStreaming) {
|
||||
// streaming API has better performance if available
|
||||
wasm = await WebAssembly.instantiateStreaming(response, importObj);
|
||||
} else {
|
||||
const module_bytes = await response.arrayBuffer();
|
||||
wasm = await WebAssembly.instantiate(module_bytes, importObj);
|
||||
}
|
||||
|
||||
memory_bytes = new Uint8Array(wasm.instance.exports.memory.buffer);
|
||||
|
||||
try {
|
||||
wasm.instance.exports._start();
|
||||
} catch (e) {
|
||||
const is_ok = e.message === "unreachable" && exit_code === 0;
|
||||
if (!is_ok) {
|
||||
console.error(e);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (typeof module !== "undefined") {
|
||||
module.exports = {
|
||||
roc_web_platform_run,
|
||||
};
|
||||
}
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
/**
|
||||
* Node.js test file for helloWeb example
|
||||
* We are not running this in CI currently, and Node.js is not a Roc dependency.
|
||||
* But if you happen to have it, you can run this.
|
||||
*/
|
||||
|
||||
// Node doesn't have the fetch API
|
||||
const fs = require("fs/promises");
|
||||
global.fetch = (filename) =>
|
||||
fs.readFile(filename).then((buffer) => ({
|
||||
arrayBuffer() {
|
||||
return buffer;
|
||||
},
|
||||
}));
|
||||
|
||||
const { roc_web_platform_run } = require("./host");
|
||||
|
||||
roc_web_platform_run("./rocLovesWebAssembly.wasm", (string_from_roc) => {
|
||||
const expected = "Roc <3 Web Assembly!\n";
|
||||
if (string_from_roc !== expected) {
|
||||
console.error(`Expected "${expected}", but got "${string_from_roc}"`);
|
||||
process.exit(1);
|
||||
}
|
||||
console.log("OK");
|
||||
});
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
const std = @import("std");
|
||||
const str = @import("str");
|
||||
const builtin = @import("builtin");
|
||||
const RocStr = str.RocStr;
|
||||
const testing = std.testing;
|
||||
const expectEqual = testing.expectEqual;
|
||||
const expect = testing.expect;
|
||||
|
||||
comptime {
|
||||
// This is a workaround for https://github.com/ziglang/zig/issues/8218
|
||||
// which is only necessary on macOS.
|
||||
//
|
||||
// Once that issue is fixed, we can undo the changes in
|
||||
// 177cf12e0555147faa4d436e52fc15175c2c4ff0 and go back to passing
|
||||
// -fcompiler-rt in link.rs instead of doing this. Note that this
|
||||
// workaround is present in many host.zig files, so make sure to undo
|
||||
// it everywhere!
|
||||
if (builtin.os.tag == .macos) {
|
||||
_ = @import("compiler_rt");
|
||||
}
|
||||
}
|
||||
|
||||
const Align = extern struct { a: usize, b: usize };
|
||||
extern fn malloc(size: usize) callconv(.C) ?*align(@alignOf(Align)) anyopaque;
|
||||
extern fn realloc(c_ptr: [*]align(@alignOf(Align)) u8, size: usize) callconv(.C) ?*anyopaque;
|
||||
extern fn free(c_ptr: [*]align(@alignOf(Align)) u8) callconv(.C) void;
|
||||
extern fn memcpy(dest: *anyopaque, src: *anyopaque, count: usize) *anyopaque;
|
||||
|
||||
export fn roc_alloc(size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
_ = alignment;
|
||||
|
||||
return malloc(size);
|
||||
}
|
||||
|
||||
export fn roc_realloc(c_ptr: *anyopaque, new_size: usize, old_size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
_ = old_size;
|
||||
_ = alignment;
|
||||
|
||||
return realloc(@alignCast(@alignOf(Align), @ptrCast([*]u8, c_ptr)), new_size);
|
||||
}
|
||||
|
||||
export fn roc_dealloc(c_ptr: *anyopaque, alignment: u32) callconv(.C) void {
|
||||
_ = alignment;
|
||||
|
||||
free(@alignCast(@alignOf(Align), @ptrCast([*]u8, c_ptr)));
|
||||
}
|
||||
|
||||
export fn roc_memcpy(dest: *anyopaque, src: *anyopaque, count: usize) callconv(.C) void {
|
||||
_ = memcpy(dest, src, count);
|
||||
}
|
||||
|
||||
// NOTE roc_panic is provided in the JS file, so it can throw an exception
|
||||
|
||||
const mem = std.mem;
|
||||
const Allocator = mem.Allocator;
|
||||
|
||||
extern fn roc__mainForHost_1_exposed(*RocStr) void;
|
||||
|
||||
const Unit = extern struct {};
|
||||
|
||||
extern fn js_display_roc_string(str_bytes: ?[*]u8, str_len: usize) void;
|
||||
|
||||
pub fn main() u8 {
|
||||
// actually call roc to populate the callresult
|
||||
var callresult = RocStr.empty();
|
||||
roc__mainForHost_1_exposed(&callresult);
|
||||
|
||||
// display the result using JavaScript
|
||||
js_display_roc_string(callresult.asU8ptr(), callresult.len());
|
||||
|
||||
callresult.deinit();
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
<html>
|
||||
<body>
|
||||
<div id="output"></div>
|
||||
<script src="./host.js"></script>
|
||||
<script>
|
||||
const elem = document.getElementById("output");
|
||||
roc_web_platform_run("./rocLovesWebAssembly.wasm", (string_from_roc) => {
|
||||
elem.textContent = string_from_roc;
|
||||
});
|
||||
</script>
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
platform "echo-in-web-assembly"
|
||||
requires {} { main : Str }
|
||||
exposes []
|
||||
packages {}
|
||||
imports []
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : Str
|
||||
mainForHost = main
|
||||
|
|
@ -0,0 +1,106 @@
|
|||
const std = @import("std");
|
||||
const builtin = @import("builtin");
|
||||
const str = @import("str");
|
||||
const RocStr = str.RocStr;
|
||||
const testing = std.testing;
|
||||
const expectEqual = testing.expectEqual;
|
||||
const expect = testing.expect;
|
||||
|
||||
comptime {
|
||||
// This is a workaround for https://github.com/ziglang/zig/issues/8218
|
||||
// which is only necessary on macOS.
|
||||
//
|
||||
// Once that issue is fixed, we can undo the changes in
|
||||
// 177cf12e0555147faa4d436e52fc15175c2c4ff0 and go back to passing
|
||||
// -fcompiler-rt in link.rs instead of doing this. Note that this
|
||||
// workaround is present in many host.zig files, so make sure to undo
|
||||
// it everywhere!
|
||||
if (builtin.os.tag == .macos) {
|
||||
_ = @import("compiler_rt");
|
||||
}
|
||||
}
|
||||
|
||||
const Align = 2 * @alignOf(usize);
|
||||
extern fn malloc(size: usize) callconv(.C) ?*align(Align) anyopaque;
|
||||
extern fn realloc(c_ptr: [*]align(Align) u8, size: usize) callconv(.C) ?*anyopaque;
|
||||
extern fn free(c_ptr: [*]align(Align) u8) callconv(.C) void;
|
||||
extern fn memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void;
|
||||
extern fn memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void;
|
||||
|
||||
const DEBUG: bool = false;
|
||||
|
||||
export fn roc_alloc(size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
var ptr = malloc(size);
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("alloc: {d} (alignment {d}, size {d})\n", .{ ptr, alignment, size }) catch unreachable;
|
||||
return ptr;
|
||||
} else {
|
||||
return malloc(size);
|
||||
}
|
||||
}
|
||||
|
||||
export fn roc_realloc(c_ptr: *anyopaque, new_size: usize, old_size: usize, alignment: u32) callconv(.C) ?*anyopaque {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("realloc: {d} (alignment {d}, old_size {d})\n", .{ c_ptr, alignment, old_size }) catch unreachable;
|
||||
}
|
||||
|
||||
return realloc(@alignCast(Align, @ptrCast([*]u8, c_ptr)), new_size);
|
||||
}
|
||||
|
||||
export fn roc_dealloc(c_ptr: *anyopaque, alignment: u32) callconv(.C) void {
|
||||
if (DEBUG) {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
stdout.print("dealloc: {d} (alignment {d})\n", .{ c_ptr, alignment }) catch unreachable;
|
||||
}
|
||||
|
||||
free(@alignCast(Align, @ptrCast([*]u8, c_ptr)));
|
||||
}
|
||||
|
||||
export fn roc_panic(c_ptr: *anyopaque, tag_id: u32) callconv(.C) void {
|
||||
_ = tag_id;
|
||||
|
||||
const stderr = std.io.getStdErr().writer();
|
||||
const msg = @ptrCast([*:0]const u8, c_ptr);
|
||||
stderr.print("Application crashed with message\n\n {s}\n\nShutting down\n", .{msg}) catch unreachable;
|
||||
std.process.exit(0);
|
||||
}
|
||||
|
||||
export fn roc_memcpy(dst: [*]u8, src: [*]u8, size: usize) callconv(.C) void {
|
||||
return memcpy(dst, src, size);
|
||||
}
|
||||
|
||||
export fn roc_memset(dst: [*]u8, value: i32, size: usize) callconv(.C) void {
|
||||
return memset(dst, value, size);
|
||||
}
|
||||
|
||||
const mem = std.mem;
|
||||
const Allocator = mem.Allocator;
|
||||
|
||||
extern fn roc__mainForHost_1_exposed_generic(*RocStr) void;
|
||||
|
||||
const Unit = extern struct {};
|
||||
|
||||
pub fn main() u8 {
|
||||
const stdout = std.io.getStdOut().writer();
|
||||
const stderr = std.io.getStdErr().writer();
|
||||
|
||||
var timer = std.time.Timer.start() catch unreachable;
|
||||
|
||||
// actually call roc to populate the callresult
|
||||
var callresult = RocStr.empty();
|
||||
roc__mainForHost_1_exposed_generic(&callresult);
|
||||
|
||||
const nanos = timer.read();
|
||||
const seconds = (@intToFloat(f64, nanos) / 1_000_000_000.0);
|
||||
|
||||
// stdout the result
|
||||
stdout.print("{s}", .{callresult.asSlice()}) catch unreachable;
|
||||
|
||||
callresult.deinit();
|
||||
|
||||
stderr.print("runtime: {d:.3}ms\n", .{seconds * 1000}) catch unreachable;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
platform "echo-in-zig"
|
||||
requires {} { main : Str }
|
||||
exposes []
|
||||
packages {}
|
||||
imports []
|
||||
provides [mainForHost]
|
||||
|
||||
mainForHost : Str
|
||||
mainForHost = main
|
||||
Loading…
Add table
Add a link
Reference in a new issue