-- Prelude
-- -------
-- 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 == 0
-- Numbers
-- -------
-- Some 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 = false
-- And 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)
-- Speed
-- -----
-- 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)
-- Function Combinators
-- --------------------
-- 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 {}
-- Strings
-- -------
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 string
-- Tests
-- -----
-- By invoking javascript, we can listen for exceptions.
err x = do! `try {
x();
return false;
} catch (e) {
return e;
}`
-- Option
-- ------
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
-- HTML
-- ------
module html
HTML = { element: a
inner: JS String
on_click: JS {} -> JS {}
set: b -> 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 ""
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 -> JS
| 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
-- Arrays
-- ------
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 =
if x > y
then do! reverse (y .. x)
else do!
`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]
-- Lists
-- -----
-- 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 ] == 4
-- Generators
init 0 _ = {nil}
| n x = x :: init (n - 1) x
length (init 30 0) == 30
tail (init 3 0) == init 2 0
-- List 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 x
-- Folds
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
-- ---------
-- 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
|> last
-- FormlZ
-- -------
-- Demonstration 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]