The standard library for the programming language Forml
If you are familiar with Haskell or ML, the prelude may serve as a good introduction to forml. Forml's syntax is quite liberal; to illustrate, the prelude will maintain an intentionally inconsistent style throughout.
First, we need to create a namespace with the module keyword.
module prelude
JS a = {} -> a
inline object? x = do! `typeof x === "object"`
inline array? = do! `is_array`
inline string? x = do! `typeof x === "string"`
inline cast: _ -> _ | x = do! `x`
inline
num? x = do! `typeof x == "number"`
inline type? x = do! `typeof x`
inline
not: Bool -> Bool
not x = do! `!x`
not false
object? {}
array? []
not (array? {})
not (object? 0)Side effects can only happen in Javascript, so we use a monadic container to compose these bits.
inline
(>>=): JS a -> (a -> JS b) -> JS b
(>>=) x y = `y(x())()`
inline
(>>): JS a -> JS b -> JS b
(>>) x y = `x(); return y();`
inline return:
a -> JS a
return x = `x`
do! x <- `1 + 4`
y <- `2 + 3`
ans <- `x + y`
return (10 == ans)
5 == do! return 5
10 == do! `5 + 5`
do_times 0 _ = `undefined`
do_times n f =
f >> do_times (n - 1) f
inline fmap:
(a -> b) -> JS a -> JS b
| f js = do
val <- js
yield f val
inline clone: a -> JS a | x =
if array? x
`$.extend(true, [], x)`
else
`$.extend(true, {}, x)`
inline log: a -> JS {}
| x = `console.log(x)`Testing to verify that escaping Javascript & utilizing escaped Javascript with do sugar and composition in general works as expected.
var x = 0
y = do z <- `x = 1`
return z
x == 0Some basic aliases to native javascript infix functions. These are type annotated to constrain inferrence - otherwise, these functions would all be inferred as a -> b -> c.
inline (&&): Bool -> Bool -> Bool | x y = do! `x && y`
inline (||): Bool -> Bool -> Bool | x y = do! `x || y`
inline (*): Num -> Num -> Num | x y = do! `x * y`
inline (/): Num -> Num -> Num | x y = do! `x / y`
inline (%): Num -> Num -> Num | x y = do! `x % y`
inline (+): Num -> Num -> Num | x y = do! `x + y`
inline (-): Num -> Num -> Num | x y = do! `x - y`
inline (<=): Num -> Num -> Bool | x y = do! `x <= y`
inline (>=): Num -> Num -> Bool | x y = do! `x >= y`
inline (<): Num -> Num -> Bool | x y = do! `x < y`
inline (>): Num -> Num -> Bool | x y = do! `x > y`
inline (^): Num -> Num -> Num | x y = do! `Math.pow(x, y)`Equality is overloaded to match records and arrays. By constraining the type of this operator, we need only dispatch on the type of the first element, constraining
inline x != y = not (x is y)
inline x /= y = not (x == y)
(==): a -> a -> Bool
| x y when do! `x === y` = true
| x y when object? x =
do! `var result = true;
for (key in x) {
result = result && y.hasOwnProperty(key) && _eq_eq(x[key])(y[key]);
};
var z = Object.keys(x).length
=== Object.keys(y).length;
result && z`
| x y when array? x =
do! `var result = true;
for (z in x) {
result = result && _eq_eq(x[z])(y[z]);
};
result && x.length == y.length`
| x y = falseAnd a few simple tests to verify the correctness of these implementations. This is not meant to be exhaustive, only a smoke test against regressions.
(3 * 4) + 5 * 4 == 64 / 2
4 - 1 != 5 - 10
(10 >= 5 + 5) != (4 + 5 <= 10 - 2)
({test: 1} == {test: 1}) == true
({test: 1} != {test: 1}) == false
inline
rand: Num -> JS Num | x =
`Math.floor(Math.random() * x)`
Fibonacci function
fib 0 = 0 | 1 = 1 | n = fib(n - 1) + fib(n - 2)Due to the nested recursion, fib is an excellent function for testing the runtime speed versus raw javascript. fast_fib is a trivial javascript implementation of the same function, recursed itself to remove any potential overhead from forml's dispatch mechanism.
module speedtest
private inline get_time = `new Date().getTime()`
time js =
do start <- get_time
js
stop <- get_time
return (stop - start)
private inline
fast_fib =
do! `var f = function(n) {
return 0 === n ? 0 : 1 === n ? 1 : f(n - 1) + f(n - 2)
}; f`
fast_fib 7 == fib 7
With this, we can set up a simple canary to let us know if the prelude is suddenly dramatically slower than it previously was; in this case, we fail a test if the forml version isn't at least 90% as fast as the native javascript version.
floor: Num -> Num = do! `Math.floor`
do! fast_time <- time yield fast_fib 30
slow_time <- time yield fib 30
return (floor (fast_time / slow_time * 100) >= 80)Simple left & right pipes, ala F#.
inline x <| y = x y
inline x |> y = y x
3 |> (λy = y + 1) |> λy = y + 1 == 5
(λy x z = x + y + z + 1) 1 <| 3 <| 4 == 9
Alternatively, there is a right associative version of <|, ala haskell. All operators which end with a : are right associative.
inline x <: y = x y
(λx = x - 3) <: (λx = x - 3) <: 5 + 5 == 4
Function composition
x .: y = λz = x y(z)
inline id x = x
inline flip(f) x y = f(y, x)
inline x ' y = y x
((λx = x + 1) .: (λx = x * 2) .: λx = x - 3) 4 == 3
id [1, 2, 3] == [1, 2, 3]
flip (λx y = x - y) 3 5 == 2
inline ignore = flip (>>) yield {} module string
inline
lstrip: String -> String
lstrip x = do! `x.replace(/^\s+/, '')`
inline rstrip: String -> String | x = do! `x.replace(/\s+$/, '')`
inline strip: String -> String | = lstrip .: rstrip
length: String -> Num | n = do! `n.length`
TODO concat cannot be inlined because it shadows concat in other modules, and inlines currently do not respect shadows.
concat: Array String -> String
concat xs = do! `xs.join("")`
inline
(+++): _ -> _ -> String
x +++ y = do! `"" + x + y`
strip " test " is "test"interpolated strings
let x = "test"
in "hello `x`" is "hello test"
Regex = { regex: {} }
regex: String -> String -> Regex | r o = do! `new RegExp(r, o)`
replace: Regex -> String -> String -> String
| r s t =
do! `(t).replace(r, s)`
to_string: _ -> String | x = do! `x + ""`
open stringBy invoking javascript, we can listen for exceptions.
err x = do! `try {
x();
return false;
} catch (e) {
return e;
}` module option
Option a = {some: a} | {none}
option b {none} = b
| _ {some: x} = x
{none} == {none}
{some: 2} == {some: 2}
option 3 {some: 2} == 2 module html
HTML = { element: _
inner: JS String
on_click: JS {} -> JS {}
set: _w -> JS {}
add_class: String -> JS {}
add_style: String -> String -> JS {} }
get:
String -> JS HTML
| x = do el <- `$(x).get(0)`
return { element = el
inner = `el.innerHTML`
on_click y = `el.onclick = y`
set y = `el.innerHTML = y`
add_class y =
`el.setAttribute("class", el.getAttribute("class") + " " + y)`
add_style y z = `el.style[y] = z` }
inline ($=):
String -> _ -> JS {}
x $= y =
`if (typeof $ != "undefined") {
var xx = $(x).get(0);
if (typeof xx != "undefined") {
xx.innerHTML = y;
}
}`
inline ($|):
String -> String -> String -> JS {}
selector $| rule value = `$(selector).css(rule, value)`
inline
($.): String -> String -> JS {}
($.) x y = `$(x).addClass(y)`
inline ($+): String -> String -> JS {}
| x y = `$(x).append(y)`
div: String -> JS String
| x = yield "<div id='`x`'/>"
move: HTML -> HTML -> JS _
| x y = `$(y.element).append($(x.element).detach())`
on_load: JS {} -> JS {}
| x = `window.addEventListener("load", x, false)`
inline stringify: _ -> String | x = do! `JSON.stringify(x)`
inline (!!): Array a -> Num -> a | x y = do! `x[y]`
with_page: JS<a> -> JS<a>
| x = do old <- `$("body").clone()`
xx <- x
`$("body").replaceWith(old)`
return xx
inline on_key:
Num -> JS _ -> JS {}
| key action =
`jQuery(window).keydown(function(event) {
if (event.keyCode == key) {
event.preventDefault();
action();
}
})`do! with_page do "body" $= "Test" text <- get "body" text <- text.inner return (text == "Test")
do! d <- div "test1"
"body" $+ d
"#test1" $= "I am a test!"
text <- get "#test1"
text <- text.inner
"#test1" $= ""
return (text == "I am a test!")
inline split: String -> String -> Array String | y x = do! `x.split(y)`This is the initializer for prelude's console test suite.
console_runner: JS {} =
var is_error = 0
var get_line x = x |> split "__::__"
|> \x = x !! 0
|> split "_"
|> \x = x !! 0
|> \x = do! `parseInt x`
|> \x = x + 1
|> stringify
var report_failed spec results =
let items = spec.results_.items_
desc = split "__::__" spec.description !! 1
exp = stringify (items !! 0).expected
act = stringify (items !! 0).actual
line = get_line spec.description
do if is_error == 0
then log "\r "
else return {}
`is_error = 1`
log "Test failed at line `line`
`desc`
Expected `exp`
Actual `act`"
log ""
var report spec =
do! results <- `spec.results()`
passed <- `results.passed()`
if passed
then return {}
else report_failed spec results
var reporter = { reportSpecResults: report
reportRunnerResults: `if (typeof phantom != "undefined") { phantom.exit(is_error); }` }
var jasmine: a
do env <- jasmine.getEnv
yield
env.addReporter reporter
env.execute
push : a -> Array a -> JS (Array a)
push xs x = `xs.push(x)`
private console_reporter = {
total = 0
failed = 0
messages = []
reportSpecResults spec = do!
results <- `spec.results()`
passed <- `results.passed()`
`console_reporter.total++`
if not passed then do
`console_reporter.failed++`
push console_reporter.messages spec.description
return {}
return {}
reportRunnerResults = do
if console_reporter.failed > 0
log console_reporter.messages
log "`console_reporter.total - console_reporter.failed`/`console_reporter.total` tests passed"
}This is the initializer for prelude's HTML test suite.
table_of_contents = do
let jasmine: a
".test" $| "position" <| "relative"
".test" $| "left" <| "50px"
trivial <- `new jasmine.TrivialReporter`
forml <- `new jasmine.FormlReporter`
env <- jasmine.getEnv
`env.addReporter trivial`
`env.addReporter forml`
`env.addReporter console_reporter`
env.execute
reporter <- get ".jasmine_reporter"
body <- get "#test_suite"
move reporter body
module array
type UnboxedArray x = {
unshift: x -> Num
push: x -> Num
length: Num
map: (x -> y) -> (UnboxedArray y)
forEach: (x -> _) -> {}
reverse: JS (UnboxedArray x)
reduce: (x -> x -> x) -> x
}
private inline unbox: Array a -> UnboxedArray a = cast
private inline box: UnboxedArray a -> Array a = cast
private inline
chain f xs =
let _ = f (unbox xs)
in xs
inline length = .length .: unbox
inline map f = box .: .map f .: unbox
inline push! x = chain (.push x)
inline unshift! x = chain (.unshift x)
reverse x = do yield do! (unbox x).reverse
yield x
reduce f = .reduce (do! `function(x, y) { return f(x)(y); }`) .: unbox
inline get: Num -> Array x -> x
| x xs = do! `xs[x]`
inline set: Num -> a -> Array a -> JS (Array a)
| idx i arr = `arr[idx] = i; return arr`
inline sequence: Array (JS a) -> JS (Array a)
| xs = `xs.map(run)`
(..): Num -> Num -> Array Num
x .. y = do!
if x > y
then reverse (y .. x)
else
`var z = [];
for (var i = x; i <= y; i++) z.push(i);
return z`
times: Num -> a -> Array a
| n _ when n < 0 = []
| n yld = 0 .. (n - 1) 'map \_ = yld
inline
put: a -> Array a -> JS (Array a)
| x xs = do
y <- clone xs
yield push! x y
all? = reduce (&&)
sum = reduce (+)
inline
for_each: (Num -> _) -> Array _ -> JS {}
| f xs = `for (x in xs) { f(parseInt(x)); }`
inline
zip_with: (a -> b -> c) -> Array a -> Array b -> Array c
zip_with f xs ys =
let z = []
h m = m ys 'f (m xs)
g = flip push! z .: h .: get
in do! xs 'for_each g
yield z
[3, 2, 1] == do! reverse [1, 2, 3]
let x = []
_ = push! 1 x
x == [1]
1 .. 3 == [1, 2, 3]
3 .. 1 == [3, 2, 1]
reduce (&&) [true, true, true]
5 'times 5 == [5, 5, 5, 5, 5]
[1, 2, 3] == do! put 3 [1, 2]
map (.x) [{x: 1}, {x: 2}] == [1, 2]
zip_with (\x y = x + y) [1, 2, 3] [3, 2, 1] == [4, 4, 4]
A simple implementation of a library for manipulating linked lists.
module list
open option
List a = { head: a, tail: List a }
| { nil }
This complex type can be hidden behind a constructor function which works more like a traditional cons.
inline
x :: y = { head = x, tail = y }The compiler itself also supports the list sugar [: 1, 2, 3 ] (or [: 1, 2, 3 :], if you prefer symmetry). All of these lists are synonyms.
var xs = [:
[:1,2,3]
[:1,2,3:]
(1::2::3::{nil})
{ head = 1
tail = { head = 2
tail = { head = 3
tail = {nil} }}}
]
all? (λy = [:1,2,3] == y) xs
Simple implementations of list accessors, which illustrate incomplete definition.
empty? { nil } = true | _ = false
head { head: x, tail: _ } = x
| { nil } = error "Head called on empty list"
tail { head: _, tail: x } = x
| { nil } = error "Tail called on empty list"
last { head: x, tail: { nil } } = x
last { head: _, tail: x } = last x
last { nil } = error "Last called on empty list"
take 0 x = { nil } | n x = head x :: take (n - 1) (tail x)
drop 0 x = x | n x = drop (n - 1) (tail x)
x .. y =
let f xx z when xx >= x = f (xx - 1) (xx :: z)
f _ z = z
f y {nil}
1 .. 5 == [:1,2,3,4,5]Project Euler problem 1, modified to protect the innocent:
288045 == 1 .. 1111 |> filter (λx = x % 3 == 0 || x % 5 == 0) |> sum
take_while f { nil } = { nil }
| f x when f (head x) = head x :: filter f (tail x)
| _ _ = { nil }
drop_while f { nil } = { nil }
| f x when f (head x) = drop_while f (tail x)
| _ x = x
inits [:] = [:[:]]
| {head: x, tail: xs} = [:[:]] ++ (map (λy = x::y) (inits xs))
tails [:] = [:[:]]
| xxs = xxs :: tails <| tail xxs
not (empty? (1 :: {nil}))
empty? [:]
head [: 1, 2 ] is 1
tail [: 1, 2 ] is [:2]
last [: 1, 2 ] is 2
err (lazy head {nil}) is "Head called on empty list"
err (lazy tail {nil}) is "Tail called on empty list"
err (lazy last {nil}) is "Last called on empty list"
take(2, [: 1, 2, 3 ]) == [: 1, 2 ]
drop(2, [: 1, 2, 3 ]) == [: 3 ]
take_while (λx = x < 0) [:] == [:]
take_while (λx = x > 0) [: 2, 1, 0 ] == [: 2, 1 ]
drop_while (λx = x < 0) {nil} == {nil}
drop_while (λx = x > 0) [: 2, 1, 0 ] == [: 0 ]
inits [:] is [:[:]]
inits [:1,2,3] is [:[:],[:1],[:1,2],[:1,2,3]]
tails [:] is [:[:]]
tails [:1,2,3] is [:[:1,2,3],[:2,3],[:3],[:]]Cardinality
length
| {nil} = 0
| {head: _, tail: x} = 1 + length x
length [: 1, 2, 3, 4 ] == 4Generators
init 0 _ = {nil}
| n x = x :: init (n - 1) x
length (init 30 0) == 30
tail (init 3 0) == init 2 0List concatenation
(++)
| {nil} y = y
| {head: y, tail: ys} xs = y :: (ys ++ xs)
{nil} ++ (1 :: 2 :: {nil}) == 1 :: 2 :: {nil}
[: 1, 2 ] ++ [: 3, 4 ] == [: 1, 2, 3, 4 ]Map
map(f, {nil}) = {nil}
map(f, x) = f(head(x)) :: map(f, tail(x))
[: 2, 3, 4 ] == [: 1, 2, 3 ] |> map λx = x + 1
Reverse
reverse y =
let r rest [:] = rest
r rest { head: x, tail: xs } =
r (x :: rest) xs
in r {nil} y
reverse [: 1, 2, 3, 4 ] == [: 4, 3, 2, 1 ]
var test_x = [: 1, 2, 3, 4 ]
test_x == reverse <| reverse test_x
take' x y =
let t(0, _, acc) = acc
t(n, x, acc) = t(n - 1, tail x, head x :: acc)
in reverse t(x, y, {nil})
var x = [: 1, 2, 3, 4, 5, 6, 7, 8 ]
take 5 x == take' 5 xFolds
foldl f x xs =
var g y {nil} = y
| y { head: z, tail: zs } = g (f y z) zs
g x xs
foldl1 _ {nil} = error "Foldl1 called on empty list"
| f x = foldl f (head x) (tail x)
foldr f x =
var g {nil} = x
g { head: y, tail: ys } = f y (g ys)
g
foldr1 _ {nil} = error "Foldr1 called on empty list"
| f x = foldr f (head x) (tail x)
foldl (+) 0 [: 1, 2, 3, 4 ] == 10
foldr (+) 0 [: 1, 2, 3, 4 ] == 10
sum = foldl1 (+)
sum [:1,2,3] == 6
product = foldl1 (*)
product [:1,2,4] == 8
Find
find: (a -> Bool) -> List a -> Option a
| f {nil} = {none}
| f {head: h, tail: _} when f h = {some = h}
| f {head: _, tail: t} = find f t
[: 1,2] 'find (λx = x > 2) == {none}
[: 1,2,3,4] 'find (λx = x > 2) == {some: 3}
option 1 <| find (λx = x > 2) [: 1,2,3,4] == 3
Filter
filter: (a -> Bool) -> List a -> List a
| f {nil} = {nil}
| f x when f (head x) = head x :: filter f (tail x)
| f x = filter f <| tail x
[: 1, 2, 3, 4 ] 'filter (λx = x > 2) == [: 3, 4 ]
Partition
partition f =
let s x {head: l1, tail: l2} =
let l2' = head l2
if f x then [: x::l1,l2'] else [: l1,x::l2']
foldr s [:[:],[:]]
partition (λx = true) [:] == [: [:],[:]]
partition (λx = x < 3) [:1,2,3,4] == [: [:1,2],[:3,4]]
All? & Any?
all? f = foldl1 (&&) .: map f
any? f = foldl1 (||) .: map f
all? id [:true,true]
not (all? id [:true,false])
any? id [:true,false]
not (any? id [:false,false])
concat = foldl1 λx y = x ++ y
concat_map f xs = concat (map f xs)
maximum = foldl1 λ(x, y) when x > y = x
|(_, y) = y
maximum [: 1, 2, 3 ] == 3
minimum = foldl1 λx y = if x > y then y else x
minimum [: 1, 2, 3 ] == 1
let x = [:1,2], y = [:3,4]
concat [:x,y] == [:1,2,3,4]
concat_map (λx = [:x,x+1]) [:1,2] == [:1,2,2,3]
Sequences are an abstract data type which resembles a list, except that elements Sequences may be infinite, as long as you never try to read every element. However, the current implementation is stack-consuming and thus limited by the underlying javascript runtime [TODO].
module seq
open list
open speedtest
open html
Seq a = { seq: JS { elem: a, next: Seq a}}
| { end }
inline seq x = {seq: x}
iterate f x = seq yield { elem: x, next: iterate f (f x) }
from_list {nil} = {end}
| { head: x, tail: xs } =
{ seq: yield { elem: x, next: from_list xs }}
to_list { end } = {nil}
| { seq: x } = do! { elem: y, next: ys } <- x
return (y :: to_list ys)
take _ {end} = {end}
| 0 _ = {end}
| x { seq: y } = seq do { elem: z, next: zs } <- y
return { elem: z, next: take (x - 1) zs }
to_list (from_list [:1,2]) == [:1,2]
iterate (λx = x + 1) 0 |> take 100 |> to_list |> length == 100
zip_with:
(a -> b -> c) -> Seq a -> Seq b -> Seq c
| _ {end} _____ = {end}
| _ _____ {end} = {end}
| f {seq: a} {seq: b} = seq do
{ elem: xx, next: xs } <- a
{ elem: yy, next: ys } <- b
return { elem: f xx yy, next: zip_with f xs ys }
inline x ::: y = seq yield { elem: x, next: do! y }
tail:
Seq a -> Seq a
| {end} = error "tail called on empty seq"
| {seq: t} = do! t >>= λx = return x.next
to_lazy
| {end} = {end}
| {seq: y} = seq lazy do!
{elem: x, next: xs} <- y
return {elem: x, next: to_lazy xs}
Infinite sequence example
fibs = to_lazy <: 1 ::: return <: 1 ::: yield zip_with (λx y = x + y) fibs <: tail fibs
Since the lazy keyword memoizes it's argument, this fibonacci implementation is ridiculously faster than the recursive version. For example, the runtime speed of this fib implementation compared to the native recursive one is __________%.
do! fast_time <- time yield fast_fib 30
slow_time <- time yield fibs |> take 30 |> to_list |> last
let ratio = floor (fast_time / slow_time * 100)
"#speedtest" $= ratio
return (ratio >= 2)
fibs |> take 5 |> to_list == [:1,1,2,3,5]
fast_fib 15 == fibs |> take 15
|> to_list
|> lastDemonstration of some classic FP data structures. This form of polymorphism can be simulated in Forml the same way they are implemented in Haskell - as a function dictionary, the only difference being that you must explicitly bind the dictionary instance to a symbol (as opposed to it being referenced by the type variable's instantiation).
module "Forml Z"
open list
Functor f =
{ map: (a -> b) -> f a -> f b }
Monad m =
{ (>>=): m a -> (a -> m b) -> m b
ret: a -> m a }
map z x f = z.map f x
bind { ret: f, _ } x = f x
list_functor =
{ map _ {nil} = {nil}
| f { head: x, tail: xs } =
{ head: f x
tail: list_functor.map f xs }}
list_monad =
{ (>>=) x g = concat_map g x
return x = [:x] }
js_monad =
{ (>>=) x f = x >>= f
return x = return x }
let (>>>=) x g = concat_map g x
z = 1 .. 3 >>>= λx = [:x, x + 1, x + 2]
z == [:1,2,3,2,3,4,3,4,5]