├── tests ├── oracles │ ├── list.js │ ├── tce.js │ ├── tree.js │ ├── builtin-errors.js │ ├── concat.js │ ├── guards.js │ ├── if-false.js │ ├── int-type.js │ ├── ioref.js │ ├── lambdas.js │ ├── random.js │ ├── repeat.js │ ├── zipwith.js │ ├── case.js │ ├── guard-false.js │ ├── homegrown-list.js │ ├── import-type.js │ ├── jsfun-return-args.js │ ├── lazy-binding.js │ ├── local-function.js │ ├── mapm.js │ ├── return-list.js │ ├── boolean-in-pattern.js │ ├── call-io-from-js.js │ ├── call-to-js.js │ ├── cant-force-io-exec.js │ ├── case-within-expr.js │ ├── eval-in-cons-match.js │ ├── global-thunk.js │ ├── import-from-prelude.js │ ├── integer-division.js │ ├── multiarg-function.js │ ├── multiarg-js-call.js │ ├── multiarg-lambdas.js │ ├── nested-do-blocks.js │ ├── nullary-constructor.js │ ├── partial-application.js │ ├── properly-eval-io.js │ ├── basic-io.js │ ├── call-js-and-back-again.js │ ├── import-from-two-places.js │ ├── list-literal-matching.js │ ├── non-nullary-constructor.js │ ├── shadowing-const-bindings.js │ ├── statements-are-thunked.js │ ├── unary-do-block.js │ ├── always-perform-io.js │ ├── assign-function-to-function.js │ ├── complex-compare.js │ ├── correctly-unify-list-literals.js │ ├── eval-in-constructor-match.js │ ├── lists-dont-eval-unnecessarily.js │ ├── thunk-globals-when-argpassing.js │ ├── unit-type-function.js │ ├── imported-higher-order-function.js │ ├── partial-application-in-generic.js │ ├── return-as-higher-order-function.js │ ├── sequence.js │ ├── binary-do-block.js │ └── js-call-and-back-with-complex-datatypes.js ├── should-fail │ ├── modulo.ls │ ├── integer-slash-division.ls │ ├── type-name-clash.ls │ ├── double-div-division.ls │ ├── unknown-constructor.ls │ ├── constructor-name-clash.ls │ ├── function-comparison.ls │ ├── higher-order-tv-in-adt.ls │ ├── export-nonexistent-function.ls │ ├── wrong-type-of-import.ls │ ├── typedecl-no-binding.ls │ ├── using-non-exported-constructor.ls │ ├── higher-order-tv.ls │ ├── type-redeclaration.ls │ ├── arrow-at-end-of-do.ls │ ├── unknown-type.ls │ ├── occurs-check.ls │ ├── use-the-import-of-an-import.ls │ └── use-type-imported-by-import.ls └── should-work │ ├── return-list.ls │ ├── integer-division.ls │ ├── multiarg-lambdas.ls │ ├── call-io-from-js.ls │ ├── lazy-binding.ls │ ├── multiarg-function.ls │ ├── guard-false.ls │ ├── list-literal-matching.ls │ ├── multiarg-js-call.ls │ ├── assign-function-to-function.ls │ ├── nullary-constructor.ls │ ├── global-thunk.ls │ ├── mapm.ls │ ├── partial-application.ls │ ├── builtin-errors.ls │ ├── call-js-and-back-again.ls │ ├── concat.ls │ ├── if-false.ls │ ├── tce.ls │ ├── thunk-globals-when-argpassing.ls │ ├── correctly-unify-list-literals.ls │ ├── imported-higher-order-function.ls │ ├── return-as-higher-order-function.ls │ ├── import-from-two-places.ls │ ├── eval-in-cons-match.ls │ ├── int-type.ls │ ├── lists-dont-eval-unnecessarily.ls │ ├── call-to-js.ls │ ├── guards.ls │ ├── repeat.ls │ ├── partial-application-in-generic.ls │ ├── import-type.ls │ ├── non-nullary-constructor.ls │ ├── zipwith.ls │ ├── homegrown-list.ls │ ├── import-from-prelude.ls │ ├── statements-are-thunked.ls │ ├── case-within-expr.ls │ ├── js-call-and-back-with-complex-datatypes.ls │ ├── unit-type-function.ls │ ├── local-function.ls │ ├── shadowing-const-bindings.ls │ ├── nested-do-blocks.ls │ ├── boolean-in-pattern.ls │ ├── basic-io.ls │ ├── unary-do-block.ls │ ├── always-perform-io.ls │ ├── ioref.ls │ ├── eval-in-constructor-match.ls │ ├── binary-do-block.ls │ ├── sequence.ls │ ├── jsfun-return-args.ls │ ├── random.ls │ ├── case.ls │ ├── lambdas.ls │ ├── properly-eval-io.ls │ ├── list.ls │ ├── cant-force-io-exec.ls │ ├── complex-compare.ls │ └── tree.ls ├── docs ├── TODO ├── jsfun-howto.txt └── tutorial.html ├── examples ├── gradient │ ├── Makefile │ ├── gradient.ls │ └── gradient.html ├── scroller │ ├── Makefile │ ├── scroller.ls │ └── scroller.html ├── tetris │ ├── Makefile │ ├── colors.ls │ ├── tetris.html │ ├── shapes.ls │ └── tetris.ls └── Makefile ├── src ├── LambdaScript │ ├── Makefile │ ├── CodeGen │ │ ├── Errors.hs │ │ ├── GenTypes.hs │ │ ├── Module.hs │ │ ├── Ops.hs │ │ ├── Monad.hs │ │ ├── ShowJS.hs │ │ └── Generate.hs │ ├── Opt │ │ ├── ZapArrays.hs │ │ ├── InlineReturn.hs │ │ ├── NoZeroCompares.hs │ │ ├── RemoveDeadCode.hs │ │ ├── FoldCalls.hs │ │ ├── ReduceBlocks.hs │ │ ├── NoObviousIfs.hs │ │ ├── InlineJSFun.hs │ │ ├── ClosuresFromFoldedCalls.hs │ │ ├── BooleanSimplifier.hs │ │ ├── Optimize.hs │ │ ├── NoUselessAssigns.hs │ │ ├── Uncurry.hs │ │ ├── UnThunkFunc.hs │ │ ├── TCE.hs │ │ └── Core.hs │ ├── Builtins.hs │ ├── TCM.hs │ ├── Config.hs │ ├── Annotate.hs │ ├── Desugar.hs │ ├── Types.hs │ ├── Make.hs │ ├── Depends.hs │ └── TypeChecker.hs ├── Makefile ├── Main.hs ├── Args.hs └── LambdaScript.cf ├── Makefile ├── lib ├── std.ls ├── io.ls ├── canvas.ls ├── dom.ls └── runtime.js ├── README └── runtests.sh /tests/oracles/list.js: -------------------------------------------------------------------------------- 1 | 21 2 | -------------------------------------------------------------------------------- /tests/oracles/tce.js: -------------------------------------------------------------------------------- 1 | 0 2 | -------------------------------------------------------------------------------- /tests/oracles/tree.js: -------------------------------------------------------------------------------- 1 | 18 2 | -------------------------------------------------------------------------------- /tests/oracles/builtin-errors.js: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/oracles/concat.js: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/oracles/guards.js: -------------------------------------------------------------------------------- 1 | 1 2 | -------------------------------------------------------------------------------- /tests/oracles/if-false.js: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/oracles/int-type.js: -------------------------------------------------------------------------------- 1 | 11 2 | -------------------------------------------------------------------------------- /tests/oracles/ioref.js: -------------------------------------------------------------------------------- 1 | 1337 2 | -------------------------------------------------------------------------------- /tests/oracles/lambdas.js: -------------------------------------------------------------------------------- 1 | 90 2 | -------------------------------------------------------------------------------- /tests/oracles/random.js: -------------------------------------------------------------------------------- 1 | OK! 2 | -------------------------------------------------------------------------------- /tests/oracles/repeat.js: -------------------------------------------------------------------------------- 1 | 50 2 | -------------------------------------------------------------------------------- /tests/oracles/zipwith.js: -------------------------------------------------------------------------------- 1 | 12 2 | -------------------------------------------------------------------------------- /tests/oracles/case.js: -------------------------------------------------------------------------------- 1 | AD positive 2 | -------------------------------------------------------------------------------- /tests/oracles/guard-false.js: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /tests/oracles/homegrown-list.js: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /tests/oracles/import-type.js: -------------------------------------------------------------------------------- 1 | 1 2 | -------------------------------------------------------------------------------- /tests/oracles/jsfun-return-args.js: -------------------------------------------------------------------------------- 1 | est -------------------------------------------------------------------------------- /tests/oracles/lazy-binding.js: -------------------------------------------------------------------------------- 1 | OK! 2 | -------------------------------------------------------------------------------- /tests/oracles/local-function.js: -------------------------------------------------------------------------------- 1 | 12 2 | -------------------------------------------------------------------------------- /tests/oracles/mapm.js: -------------------------------------------------------------------------------- 1 | 1,4,9,16,25 2 | -------------------------------------------------------------------------------- /tests/oracles/return-list.js: -------------------------------------------------------------------------------- 1 | 1,2,3 2 | -------------------------------------------------------------------------------- /tests/oracles/boolean-in-pattern.js: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /tests/oracles/call-io-from-js.js: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/oracles/call-to-js.js: -------------------------------------------------------------------------------- 1 | 27 2 | 0 3 | -------------------------------------------------------------------------------- /tests/oracles/cant-force-io-exec.js: -------------------------------------------------------------------------------- 1 | OK 2 | -------------------------------------------------------------------------------- /tests/oracles/case-within-expr.js: -------------------------------------------------------------------------------- 1 | 1003 2 | -------------------------------------------------------------------------------- /tests/oracles/eval-in-cons-match.js: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /tests/oracles/global-thunk.js: -------------------------------------------------------------------------------- 1 | 3628800 2 | -------------------------------------------------------------------------------- /tests/oracles/import-from-prelude.js: -------------------------------------------------------------------------------- 1 | 25 2 | -------------------------------------------------------------------------------- /tests/oracles/integer-division.js: -------------------------------------------------------------------------------- 1 | 1 2 | -------------------------------------------------------------------------------- /tests/oracles/multiarg-function.js: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/oracles/multiarg-js-call.js: -------------------------------------------------------------------------------- 1 | 6 2 | -------------------------------------------------------------------------------- /tests/oracles/multiarg-lambdas.js: -------------------------------------------------------------------------------- 1 | 24 2 | -------------------------------------------------------------------------------- /tests/oracles/nested-do-blocks.js: -------------------------------------------------------------------------------- 1 | 20 2 | -------------------------------------------------------------------------------- /tests/oracles/nullary-constructor.js: -------------------------------------------------------------------------------- 1 | 0 2 | -------------------------------------------------------------------------------- /tests/oracles/partial-application.js: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/oracles/properly-eval-io.js: -------------------------------------------------------------------------------- 1 | 7 2 | -------------------------------------------------------------------------------- /tests/oracles/basic-io.js: -------------------------------------------------------------------------------- 1 | a string! 2 | 3 | -------------------------------------------------------------------------------- /tests/oracles/call-js-and-back-again.js: -------------------------------------------------------------------------------- 1 | 100 2 | -------------------------------------------------------------------------------- /tests/oracles/import-from-two-places.js: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/oracles/list-literal-matching.js: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /tests/oracles/non-nullary-constructor.js: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /tests/oracles/shadowing-const-bindings.js: -------------------------------------------------------------------------------- 1 | 1 2 | -------------------------------------------------------------------------------- /tests/oracles/statements-are-thunked.js: -------------------------------------------------------------------------------- 1 | OK 2 | -------------------------------------------------------------------------------- /tests/oracles/unary-do-block.js: -------------------------------------------------------------------------------- 1 | a string! 2 | -------------------------------------------------------------------------------- /tests/oracles/always-perform-io.js: -------------------------------------------------------------------------------- 1 | hej 2 | hej 3 | -------------------------------------------------------------------------------- /tests/oracles/assign-function-to-function.js: -------------------------------------------------------------------------------- 1 | 11 2 | -------------------------------------------------------------------------------- /tests/oracles/complex-compare.js: -------------------------------------------------------------------------------- 1 | okokokokokokokok 2 | -------------------------------------------------------------------------------- /tests/oracles/correctly-unify-list-literals.js: -------------------------------------------------------------------------------- 1 | 0 2 | -------------------------------------------------------------------------------- /tests/oracles/eval-in-constructor-match.js: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /tests/oracles/lists-dont-eval-unnecessarily.js: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /tests/oracles/thunk-globals-when-argpassing.js: -------------------------------------------------------------------------------- 1 | 11 2 | -------------------------------------------------------------------------------- /tests/oracles/unit-type-function.js: -------------------------------------------------------------------------------- 1 | a string! 2 | -------------------------------------------------------------------------------- /tests/should-fail/modulo.ls: -------------------------------------------------------------------------------- 1 | main = 10.0 % 9.0; 2 | -------------------------------------------------------------------------------- /tests/should-work/return-list.ls: -------------------------------------------------------------------------------- 1 | main = [1,2,3]; 2 | -------------------------------------------------------------------------------- /tests/oracles/imported-higher-order-function.js: -------------------------------------------------------------------------------- 1 | OK! 2 | -------------------------------------------------------------------------------- /tests/oracles/partial-application-in-generic.js: -------------------------------------------------------------------------------- 1 | 30 2 | -------------------------------------------------------------------------------- /tests/oracles/return-as-higher-order-function.js: -------------------------------------------------------------------------------- 1 | OK! 2 | -------------------------------------------------------------------------------- /tests/oracles/sequence.js: -------------------------------------------------------------------------------- 1 | this 2 | is 3 | a 4 | sequence 5 | -------------------------------------------------------------------------------- /tests/should-fail/integer-slash-division.ls: -------------------------------------------------------------------------------- 1 | main = 10/9; 2 | -------------------------------------------------------------------------------- /tests/should-fail/type-name-clash.ls: -------------------------------------------------------------------------------- 1 | data Bool = Foo | Bar; 2 | -------------------------------------------------------------------------------- /tests/should-work/integer-division.ls: -------------------------------------------------------------------------------- 1 | main = div 20 11; 2 | -------------------------------------------------------------------------------- /tests/should-fail/double-div-division.ls: -------------------------------------------------------------------------------- 1 | main = div 10.0 3.0; 2 | -------------------------------------------------------------------------------- /tests/should-fail/unknown-constructor.ls: -------------------------------------------------------------------------------- 1 | f (Foo x) = x; 2 | 3 | -------------------------------------------------------------------------------- /tests/oracles/binary-do-block.js: -------------------------------------------------------------------------------- 1 | a string! 2 | another string! 3 | 4 | -------------------------------------------------------------------------------- /tests/oracles/js-call-and-back-with-complex-datatypes.js: -------------------------------------------------------------------------------- 1 | 1,4,9,16,25 2 | -------------------------------------------------------------------------------- /tests/should-fail/constructor-name-clash.ls: -------------------------------------------------------------------------------- 1 | data Foo = True | False; 2 | -------------------------------------------------------------------------------- /tests/should-work/multiarg-lambdas.ls: -------------------------------------------------------------------------------- 1 | main = (\a b c -> a+b+c) 7 8 9; 2 | -------------------------------------------------------------------------------- /tests/should-fail/function-comparison.ls: -------------------------------------------------------------------------------- 1 | f x = 10; 2 | 3 | main = f == f; 4 | -------------------------------------------------------------------------------- /tests/should-fail/higher-order-tv-in-adt.ls: -------------------------------------------------------------------------------- 1 | data Foo a = Foo (a Int); 2 | 3 | -------------------------------------------------------------------------------- /tests/should-work/call-io-from-js.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | main = return 10; 4 | -------------------------------------------------------------------------------- /docs/TODO: -------------------------------------------------------------------------------- 1 | * Local functions are suboptimal; they could be optimized a little. 2 | -------------------------------------------------------------------------------- /tests/should-fail/export-nonexistent-function.ls: -------------------------------------------------------------------------------- 1 | export foo; 2 | 3 | bar = 10; 4 | -------------------------------------------------------------------------------- /tests/should-fail/wrong-type-of-import.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | main = map + 10; 4 | -------------------------------------------------------------------------------- /tests/should-fail/typedecl-no-binding.ls: -------------------------------------------------------------------------------- 1 | bar :: Int -> Int; 2 | 3 | foo x = x + x; 4 | -------------------------------------------------------------------------------- /tests/should-fail/using-non-exported-constructor.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | unIO (IO a) = a; 4 | -------------------------------------------------------------------------------- /tests/should-work/lazy-binding.ls: -------------------------------------------------------------------------------- 1 | main = (case x of _ -> "OK!";) {x = error "OH NOES!";}; 2 | -------------------------------------------------------------------------------- /tests/should-work/multiarg-function.ls: -------------------------------------------------------------------------------- 1 | f a b c d = a+b+c+d; 2 | 3 | main = f 1 2 3 4; 4 | -------------------------------------------------------------------------------- /tests/should-fail/higher-order-tv.ls: -------------------------------------------------------------------------------- 1 | foo :: (a b -> a c) -> a b -> a c; 2 | foo f x = f x; 3 | -------------------------------------------------------------------------------- /tests/should-fail/type-redeclaration.ls: -------------------------------------------------------------------------------- 1 | f :: Bool -> Bool; 2 | f :: Int -> Int; 3 | f x = x; 4 | -------------------------------------------------------------------------------- /tests/should-work/guard-false.ls: -------------------------------------------------------------------------------- 1 | f x | x = 0; 2 | | !x = 42; 3 | 4 | main = f False; 5 | -------------------------------------------------------------------------------- /tests/should-work/list-literal-matching.ls: -------------------------------------------------------------------------------- 1 | f [_] = 9; 2 | f _ = 42; 3 | 4 | main = f [3,4]; 5 | -------------------------------------------------------------------------------- /tests/should-work/multiarg-js-call.ls: -------------------------------------------------------------------------------- 1 | main = _jsfun "function(a,b,c) {return a+b+c;}" 3 1 2 3; 2 | -------------------------------------------------------------------------------- /tests/should-work/assign-function-to-function.ls: -------------------------------------------------------------------------------- 1 | f = g; 2 | 3 | g x = x+1; 4 | 5 | main = f 10; 6 | -------------------------------------------------------------------------------- /tests/should-work/nullary-constructor.ls: -------------------------------------------------------------------------------- 1 | f (True) = 1; 2 | f (False) = 0; 3 | 4 | main = f False; 5 | -------------------------------------------------------------------------------- /tests/should-fail/arrow-at-end-of-do.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | main = do { 4 | x <- return 10; 5 | }; 6 | -------------------------------------------------------------------------------- /tests/should-work/global-thunk.ls: -------------------------------------------------------------------------------- 1 | f 1 = 1; 2 | f n = n*f (n-1); 3 | 4 | t = f 10; 5 | 6 | main = t; 7 | -------------------------------------------------------------------------------- /tests/should-work/mapm.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | f x = return (x*x); 4 | 5 | main = mapM f [1,2,3,4,5]; 6 | -------------------------------------------------------------------------------- /tests/should-work/partial-application.ls: -------------------------------------------------------------------------------- 1 | f a b c d = a+b+c+d; 2 | 3 | g = f 1 2; 4 | 5 | main = g 3 4; 6 | -------------------------------------------------------------------------------- /tests/should-fail/unknown-type.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | main :: SomeUndefinedType; 4 | main = error "blah"; 5 | -------------------------------------------------------------------------------- /tests/should-work/builtin-errors.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | f (Just x) = "lol internet"; 4 | 5 | main = f Nothing; 6 | -------------------------------------------------------------------------------- /tests/should-work/call-js-and-back-again.ls: -------------------------------------------------------------------------------- 1 | main = _jsfun "function(f) {return f(10);}" 1 (_export 1 (\x -> x*x)); 2 | -------------------------------------------------------------------------------- /tests/should-work/concat.ls: -------------------------------------------------------------------------------- 1 | sum (x:xs) = x + sum xs; 2 | sum _ = 0; 3 | 4 | main = sum ([1,2] ++ [3,4]); 5 | -------------------------------------------------------------------------------- /tests/should-work/if-false.ls: -------------------------------------------------------------------------------- 1 | f = error "halp"; 2 | 3 | g x y = if x then y else 10; 4 | 5 | main = g False f; 6 | -------------------------------------------------------------------------------- /tests/should-work/tce.ls: -------------------------------------------------------------------------------- 1 | smashStack 0 = 0; 2 | smashStack n = smashStack (n-1); 3 | 4 | main = smashStack 10000; 5 | -------------------------------------------------------------------------------- /tests/should-work/thunk-globals-when-argpassing.ls: -------------------------------------------------------------------------------- 1 | foo f x = f x; 2 | 3 | g x = x+1; 4 | 5 | main = foo g 10; 6 | -------------------------------------------------------------------------------- /tests/should-work/correctly-unify-list-literals.ls: -------------------------------------------------------------------------------- 1 | f :: [Int]; 2 | f = [0,1,2]; 3 | 4 | main = case f of (x:xs) -> x;; 5 | -------------------------------------------------------------------------------- /tests/should-work/imported-higher-order-function.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | f g x = g x; 4 | 5 | main = f return "OK!"; 6 | -------------------------------------------------------------------------------- /tests/should-work/return-as-higher-order-function.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | f g x = g x; 4 | 5 | main = f return "OK!"; 6 | -------------------------------------------------------------------------------- /tests/should-fail/occurs-check.ls: -------------------------------------------------------------------------------- 1 | map :: (a -> b) -> [a] -> [b]; 2 | map f (x:xs) = f x : map f xs; 3 | map f [x] = x; 4 | -------------------------------------------------------------------------------- /tests/should-work/import-from-two-places.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | import dom; 3 | 4 | f (Just x) = x; 5 | 6 | main = f (Just 10); 7 | -------------------------------------------------------------------------------- /tests/should-work/eval-in-cons-match.ls: -------------------------------------------------------------------------------- 1 | f (x:y:_) = 42; 2 | f _ = error "Cons matching fails!"; 3 | 4 | main = f [1,2,3,4,5]; 5 | -------------------------------------------------------------------------------- /tests/should-work/int-type.ls: -------------------------------------------------------------------------------- 1 | data Foo = Foo Int; 2 | 3 | bar :: Foo -> Int; 4 | bar (Foo n) = n+1; 5 | 6 | main = bar (Foo 10); 7 | -------------------------------------------------------------------------------- /tests/should-work/lists-dont-eval-unnecessarily.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | f ([_]) = 9; 4 | f _ = 42; 5 | 6 | main = f [undefined]; 7 | -------------------------------------------------------------------------------- /examples/gradient/Makefile: -------------------------------------------------------------------------------- 1 | gradient.js: gradient.ls 2 | ../../lsc -ogradient gradient.ls -L../../lib 3 | 4 | clean: 5 | rm gradient.js 6 | -------------------------------------------------------------------------------- /examples/scroller/Makefile: -------------------------------------------------------------------------------- 1 | scroller.js: scroller.ls 2 | ../../lsc -oscroller scroller.ls -L../../lib 3 | 4 | clean: 5 | rm scroller.js 6 | -------------------------------------------------------------------------------- /tests/should-work/call-to-js.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | main :: IO Int; 4 | main = do { 5 | _jsfun "print" 1 27; 6 | return 0; 7 | }; 8 | -------------------------------------------------------------------------------- /tests/should-work/guards.ls: -------------------------------------------------------------------------------- 1 | even :: Int -> Bool; 2 | even x 3 | | x % 2 == 0 = True; 4 | | x % 2 == 1 = False; 5 | 6 | main = even 8; 7 | -------------------------------------------------------------------------------- /tests/should-work/repeat.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | sum (x:xs) = x + sum xs; 4 | sum _ = 0; 5 | 6 | main = sum (take 10 (repeat 5)); 7 | -------------------------------------------------------------------------------- /tests/should-work/partial-application-in-generic.ls: -------------------------------------------------------------------------------- 1 | f :: (a -> b) -> a -> b; 2 | f g x = g x; 3 | 4 | g a b = a+b; 5 | 6 | main = (f g 10) 20; 7 | -------------------------------------------------------------------------------- /examples/tetris/Makefile: -------------------------------------------------------------------------------- 1 | tetris.js: tetris.ls colors.ls shapes.ls 2 | ../../lsc -otetris tetris.ls -L../../lib 3 | 4 | clean: 5 | rm tetris.js 6 | -------------------------------------------------------------------------------- /tests/should-work/import-type.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | isLeft (Right _) = False; 4 | isLeft _ = True; 5 | 6 | main = isLeft (Left "tut"); 7 | -------------------------------------------------------------------------------- /tests/should-work/non-nullary-constructor.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | f (Just x) = x; 4 | f _ = error "Not Just!"; 5 | 6 | main = f (Just 42); 7 | -------------------------------------------------------------------------------- /tests/should-work/zipwith.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | sum (x:xs) = x + sum xs; 4 | sum _ = 0; 5 | 6 | main = sum (zipWith (\a b -> a+b) [1,2,3] [3,2,1]); 7 | -------------------------------------------------------------------------------- /tests/should-work/homegrown-list.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | data List a = Cons a, (List a) | Nil; 4 | 5 | f (Cons x xs) = x; 6 | 7 | main = f (Cons 9 undefined); 8 | -------------------------------------------------------------------------------- /tests/should-work/import-from-prelude.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | down 0 = [0]; 4 | down n = n : down (n-1); 5 | 6 | main = head (drop 5 (map (\x -> x*x) (down 10))); 7 | -------------------------------------------------------------------------------- /tests/should-work/statements-are-thunked.ls: -------------------------------------------------------------------------------- 1 | f x y = "OK"; 2 | 3 | main = f (case error "case fails" of 0 -> "wat";) (if error "if fails" then "wat" else "wat"); 4 | -------------------------------------------------------------------------------- /tests/should-fail/use-the-import-of-an-import.ls: -------------------------------------------------------------------------------- 1 | -- dom imports std; let's try to use std functions through dom! 2 | import dom; 3 | 4 | main = map (\x -> x) [1,2,3]; 5 | -------------------------------------------------------------------------------- /tests/should-work/case-within-expr.ls: -------------------------------------------------------------------------------- 1 | f x = 3 + (case x of 2 | n | n > 5 -> 1000; 3 | | True -> 0;) 4 | ; 5 | 6 | main = f 10; 7 | -------------------------------------------------------------------------------- /tests/should-fail/use-type-imported-by-import.ls: -------------------------------------------------------------------------------- 1 | -- dom imports std - let's try to use the Maybe type. 2 | import dom; 3 | 4 | main :: Maybe Int; 5 | main = error "blah"; 6 | -------------------------------------------------------------------------------- /tests/should-work/js-call-and-back-with-complex-datatypes.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | main = _jsfun "function(f, x) {return f(x);}" 2 (_export 1 (map (\x -> x*x))) [1,2,3,4,5]; 4 | -------------------------------------------------------------------------------- /tests/should-work/unit-type-function.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | printString :: String -> IO (); 4 | printString s = _jsfun "print" 1 s; 5 | 6 | main = printString "a string!"; 7 | -------------------------------------------------------------------------------- /tests/should-work/local-function.ls: -------------------------------------------------------------------------------- 1 | main = foo 3 3; 2 | 3 | foo a b = a' + b' { 4 | a' = x+2; 5 | b' = x-2; 6 | x = bar a b; 7 | }; 8 | 9 | bar a b = a+b; 10 | -------------------------------------------------------------------------------- /tests/should-work/shadowing-const-bindings.ls: -------------------------------------------------------------------------------- 1 | -- This should actually work, since bindings shadowing each other is perfectly 2 | -- legal. 3 | f = True; 4 | f = False; 5 | 6 | main = f; 7 | -------------------------------------------------------------------------------- /tests/should-work/nested-do-blocks.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | main = do { 4 | do { 5 | x <- return 5; 6 | y <- return 5; 7 | return (10 + x + y); 8 | }; 9 | }; 10 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | make -C scroller 3 | make -C gradient 4 | make -C tetris 5 | 6 | clean: 7 | make -C scroller clean 8 | make -C gradient clean 9 | make -C tetris clean 10 | -------------------------------------------------------------------------------- /tests/should-work/boolean-in-pattern.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | f (True) = 3; 4 | f (False) = 0; 5 | 6 | g (Just (True)) = 0; 7 | g (Just (False)) = 3; 8 | 9 | main = f True * g (Just False); 10 | -------------------------------------------------------------------------------- /tests/should-work/basic-io.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | print :: String -> IO (); 4 | print x = do { 5 | _jsfun "(function(x) {print(x);})" 1 x; 6 | return (); 7 | }; 8 | 9 | main = print "a string!"; 10 | -------------------------------------------------------------------------------- /tests/should-work/unary-do-block.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | print x = do { 4 | _jsfun "(function(x) {print(x);})" 1 x; 5 | return (); 6 | }; 7 | 8 | main = do { 9 | print "a string!"; 10 | }; 11 | -------------------------------------------------------------------------------- /tests/should-work/always-perform-io.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | print :: String -> IO (); 4 | print x = do { 5 | _jsfun "(function(x) {print(x);})" 1 x; 6 | return (); 7 | }; 8 | 9 | f = print "hej"; 10 | 11 | main = do { f; f; }; 12 | -------------------------------------------------------------------------------- /tests/should-work/ioref.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | doSomethingTo x = do { 4 | x' <- readIORef x; 5 | writeIORef x (x'+1332); 6 | }; 7 | 8 | main = do { 9 | x <- newIORef 5; 10 | doSomethingTo x; 11 | readIORef x; 12 | }; 13 | -------------------------------------------------------------------------------- /tests/should-work/eval-in-constructor-match.ls: -------------------------------------------------------------------------------- 1 | data List a = Cons a, (List a) | Nil; 2 | 3 | f (Cons x (Cons y (Cons z _))) = 42; 4 | f _ = error "Data constructor matching fails!"; 5 | 6 | main = f (Cons 0 (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))); 7 | -------------------------------------------------------------------------------- /src/LambdaScript/Makefile: -------------------------------------------------------------------------------- 1 | .parser: Par.y 2 | happy --info=happy.info -gca Par.y 3 | touch .parser 4 | 5 | .lexer: Lex.x 6 | alex -g Lex.x 7 | touch .lexer 8 | 9 | clean: 10 | rm Abs.* Doc.* ErrM.* Lex.* Par.* Print.* Skel.* Test.* happy.info 11 | rm .lexer .parser 12 | -------------------------------------------------------------------------------- /tests/should-work/binary-do-block.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | print :: String -> IO (); 4 | print x = do { 5 | _jsfun "(function(x) {print(x);})" 1 x; 6 | return (); 7 | }; 8 | 9 | main = do { 10 | print "a string!"; 11 | print "another string!"; 12 | }; 13 | -------------------------------------------------------------------------------- /tests/should-work/sequence.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | print x = do { 4 | _jsfun "(function(x) {print(x);})" 1 x; 5 | return (); 6 | }; 7 | 8 | main = sequence_ [ 9 | print "this", 10 | print "is", 11 | print "a", 12 | print "sequence" 13 | ]; 14 | -------------------------------------------------------------------------------- /tests/should-work/jsfun-return-args.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | test :: IO String; 4 | test = _jsfun "(function() {return 'test';})" 0; 5 | 6 | main = do { 7 | t <- test; 8 | case t of 9 | (x:xs) -> return xs; 10 | _ -> return "FAIL!"; 11 | ; 12 | }; -------------------------------------------------------------------------------- /examples/tetris/colors.ls: -------------------------------------------------------------------------------- 1 | export black, red, blue, green, pink, purple, yellow; 2 | import canvas; 3 | 4 | black = RGB 0 0 0; 5 | red = RGB 255 0 0; 6 | green = RGB 0 255 0; 7 | blue = RGB 0 0 255; 8 | pink = RGB 255 0 255; 9 | purple = RGB 127 0 255; 10 | yellow = RGB 0 255 255; 11 | -------------------------------------------------------------------------------- /examples/gradient/gradient.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | import canvas; 3 | 4 | paint 255 _ = return (); 5 | paint n can = do { 6 | fillColor can (RGB n 0 n); 7 | fillRect can (Pt n n) (Pt (512-2*n) (512-2*n)); 8 | paint (n+1) can; 9 | }; 10 | 11 | paintGradient = withCanvasDo "canvas" (paint 0); 12 | -------------------------------------------------------------------------------- /src/LambdaScript/CodeGen/Errors.hs: -------------------------------------------------------------------------------- 1 | module LambdaScript.CodeGen.Errors where 2 | import LambdaScript.CodeGen.Ops 3 | 4 | lsError :: String -> Stmt 5 | lsError msg = Return 0 6 | $ Call 0 (FunExp (FunIdent "error")) [Thunk $ Const $ strConst msg] 7 | 8 | lambdaPatternMismatch = 9 | lsError "Pattern mismatch in lambda!" -------------------------------------------------------------------------------- /tests/should-work/random.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | main = do { 4 | x <- random; y <- random; z <- random; 5 | if (x > 1.0) || (x < 0.0) || 6 | (y > 1.0) || (y < 0.0) || 7 | (z > 1.0) || (z < 0.0) || 8 | (x == y) || (x == z) 9 | then return "fail" 10 | else return "OK!"; 11 | }; 12 | -------------------------------------------------------------------------------- /tests/should-work/case.ls: -------------------------------------------------------------------------------- 1 | data SomeType 2 | = A 3 | | B 4 | | C 5 | | D Int 6 | ; 7 | 8 | showSomeType t = 9 | case t of 10 | (A) -> "A"; 11 | (B) -> "B"; 12 | (C) -> "C"; 13 | (D n) -> if n < 0 then "D negative" else "D positive"; 14 | ; 15 | 16 | main = showSomeType A ++ showSomeType (D 10); 17 | -------------------------------------------------------------------------------- /examples/scroller/scroller.ls: -------------------------------------------------------------------------------- 1 | -- Scrolls the text inside an HTML element to the left. 2 | export scroll; 3 | import io; 4 | import std; 5 | import dom; 6 | 7 | update t e = do { 8 | updateAttr e "innerHTML" (\txt -> tail txt ++ [head txt]); 9 | setTimeout (update t e) t; 10 | }; 11 | 12 | scroll id t = withElement id (update t); 13 | -------------------------------------------------------------------------------- /tests/should-work/lambdas.ls: -------------------------------------------------------------------------------- 1 | map :: (a -> b) -> [a] -> [b]; 2 | map f (x:xs) = f x : map f xs; 3 | 4 | get 0 (x:xs) = x; 5 | get n (x:xs) = get (n-1) xs; 6 | get _ _ = error "Index too big!"; 7 | 8 | main = get 3 nums + get 4 nums { 9 | nums = map (\f -> f 10) multipliers; 10 | multipliers = map (\x -> \y -> x*y) [1,2,3,4,5]; 11 | }; 12 | -------------------------------------------------------------------------------- /examples/scroller/scroller.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |
7 |

8 |
INTERNET, LOL INTERNET!
9 |

10 |
11 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /examples/gradient/gradient.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Lookie, it's a gradient! 4 | 5 | 10 | 11 | 12 |
13 | 14 |
15 | 16 | 17 | -------------------------------------------------------------------------------- /examples/tetris/tetris.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | ho 2 maek tertis in 2427 sampel steps! 4 | 5 | 10 | 11 | 12 |
13 | 14 |
Lines: 0
15 |
16 | 17 | 18 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/ZapArrays.hs: -------------------------------------------------------------------------------- 1 | -- | Doing [x, y][1] is stupid, so we replace it with simply y. 2 | module LambdaScript.Opt.ZapArrays (zapArrays) where 3 | import LambdaScript.Opt.Core 4 | import LambdaScript.CodeGen.Ops 5 | 6 | zapArrays :: Opt 7 | zapArrays = Opt { 8 | optStm = id, 9 | optExp = zap 10 | } 11 | 12 | zap :: Exp -> Exp 13 | zap (Index (Array exs) (Const (NumConst ix))) = 14 | exs !! truncate ix 15 | zap x = 16 | x 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | jlc: 2 | make -C src 3 | 4 | test: 5 | @echo "Running tests with TCE..." 6 | @./runtests.sh 7 | @echo "Running tests without TCE, expect any TCE-dependent test cases to fail!" 8 | @LSCFLAGS=--no-tce ./runtests.sh 9 | 10 | failed: 11 | ./runtests.sh --failed 12 | 13 | example: 14 | make -C examples 15 | 16 | doc: 17 | make -C src doc 18 | 19 | clean: 20 | make -C src clean 21 | make -C examples clean 22 | rm failed-bad failed-good 23 | -------------------------------------------------------------------------------- /tests/should-work/properly-eval-io.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | init = do {_jsfun "(function() {herpderp = 0; return 0;})" 0; return ();}; 4 | plusEtt = _jsfun "(function() {herpderp++; return herpderp;})" 0; 5 | plus n = _jsfun "(function(x) {herpderp+=x; return herpderp;})" 1 n; 6 | 7 | plusTva = plus 2; 8 | 9 | main = do { 10 | init; 11 | x <- plusEtt; 12 | y <- plusEtt; 13 | z <- plusEtt; 14 | plusEtt; 15 | plusTva; 16 | plusEtt; 17 | }; 18 | -------------------------------------------------------------------------------- /tests/should-work/list.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | reverse :: [a] -> [a]; 4 | reverse = reverse' [] { 5 | reverse' acc (x:xs) = reverse' (x:acc) xs; 6 | reverse' acc _ = acc; 7 | }; 8 | 9 | concat :: [[a]] -> [a]; 10 | concat (x:xs) = x ++ concat xs; 11 | concat _ = []; 12 | 13 | sum (x:xs) = x + sum xs; 14 | sum _ = 0; 15 | 16 | take 0 _ = []; 17 | take n (x:xs) = x : take (n-1) xs; 18 | take _ _ = []; 19 | 20 | main = sum (take 3 (concat [[6, 7, 8], reverse [1, 2, 3, undefined]])); 21 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/InlineReturn.hs: -------------------------------------------------------------------------------- 1 | -- | Replace all calls to io.return(thunk x) with thunk x. 2 | module LambdaScript.Opt.InlineReturn (inlineReturn) where 3 | import LambdaScript.CodeGen.Ops 4 | import LambdaScript.Opt.Core 5 | import LambdaScript.Types 6 | 7 | inlineReturn :: Opt 8 | inlineReturn = Opt { 9 | optStm = id, 10 | optExp = inline 11 | } 12 | 13 | inline :: Exp -> Exp 14 | inline (Call n (Ident (Import _ "io" "return")) [arg]) = 15 | Call n (FunExp $ Construct ((tv "a") ~> io (tv "a")) (-1)) [arg] 16 | inline x = 17 | x -------------------------------------------------------------------------------- /tests/should-work/cant-force-io-exec.ls: -------------------------------------------------------------------------------- 1 | import io; 2 | 3 | print1 x = do { 4 | s <- _jsfun "(function(x) {print(x); return 0;})" 1 x; 5 | return (); 6 | }; 7 | 8 | print2 x = do { 9 | _jsfun "(function(x) {print(x); return 0;})" 1 x; 10 | return (); 11 | }; 12 | 13 | printHej = print1 "printHej _"; 14 | printHejIO = print1 "printHej IO _"; 15 | 16 | main = do { 17 | case printHej of _ -> return ();; 18 | case print1 "print1 _" of _ -> return ();; 19 | case print2 "print2 _" of _ -> return ();; 20 | return "OK"; 21 | }; 22 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/NoZeroCompares.hs: -------------------------------------------------------------------------------- 1 | -- | Doing foo == 0 is silly; better to replace it with !foo. 2 | module LambdaScript.Opt.NoZeroCompares (noZeroCompares) where 3 | import LambdaScript.CodeGen.Ops 4 | import LambdaScript.Opt.Core 5 | 6 | noZeroCompares :: Opt 7 | noZeroCompares = Opt { 8 | optStm = id, 9 | optExp = noZero 10 | } 11 | 12 | noZero :: Exp -> Exp 13 | noZero (Oper Eq (Const (NumConst 0)) e) = Neg e 14 | noZero (Oper Eq e (Const (NumConst 0))) = Neg e 15 | noZero (Oper Ne (Const (NumConst 0)) e) = e 16 | noZero (Oper Ne e (Const (NumConst 0))) = e 17 | noZero x = x 18 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/RemoveDeadCode.hs: -------------------------------------------------------------------------------- 1 | -- | Remove any code that's unreachable because it comes after an unconditional 2 | -- break. 3 | module LambdaScript.Opt.RemoveDeadCode (removeDeadCode) where 4 | import LambdaScript.Opt.Core 5 | import LambdaScript.CodeGen.Ops 6 | 7 | removeDeadCode :: Opt 8 | removeDeadCode = Opt { 9 | optStm = removeDead, 10 | optExp = id 11 | } 12 | 13 | removeDead :: Stmt -> Stmt 14 | removeDead b@(Forever (Block ss)) = 15 | case span (not . isBreak) ss of 16 | (before, (break:_)) -> Forever $ Block $ before ++ [break] 17 | _ -> b 18 | where 19 | isBreak Break = True 20 | isBreak _ = False 21 | removeDead x = x 22 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/FoldCalls.hs: -------------------------------------------------------------------------------- 1 | -- | Turn all f(a)(b) calls into f(a,b). 2 | -- Note that this optimization depends on the Uncurry and 3 | -- ClosuresFromFoldedCalls optimizations to generate correct code. 4 | module LambdaScript.Opt.FoldCalls (foldCalls) where 5 | import LambdaScript.Opt.Core 6 | import LambdaScript.CodeGen.Ops 7 | 8 | foldCalls :: Opt 9 | foldCalls = Opt { 10 | optStm = id, 11 | optExp = foldCall 12 | } 13 | 14 | -- | Fold a f(a)(b)(c) call into f(a,b,c). 15 | -- Also update the function's arity, so a complementary optimization can turn 16 | -- all function call expressions with arity >0 into closures. 17 | foldCall :: Exp -> Exp 18 | foldCall (Call n (Call _ f args') args) = 19 | Call n f as 20 | where as = args' ++ args 21 | foldCall exp = 22 | exp 23 | -------------------------------------------------------------------------------- /tests/should-work/complex-compare.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | -- Equality operator 4 | f = if "test" == "test" then "ok" else "fail"; 5 | 6 | -- Non-list structures 7 | g = if (Just "test") == (Just "test") then "ok" else "fail"; 8 | 9 | -- Make sure equality doesn't hold when it shouldn't 10 | h = if "test" == "derp" then "fail" else "ok"; 11 | 12 | -- Inequality 13 | i = if "test" != "derp" then "ok" else "fail"; 14 | 15 | -- a > b for data types with different constructors 16 | j = if (Just (0-2)) > Nothing then "ok" else "fail"; 17 | 18 | -- a > b for lists of different length 19 | k = if [3] > [1,2,3] then "ok" else "fail"; 20 | l = if [1,2,3] < [1,2,3,0] then "ok" else "fail"; 21 | 22 | -- Tuples 23 | m = if (1,2,3) < (3,2,1) then "ok" else "fail"; 24 | 25 | main = f ++ g ++ h ++ i ++ j ++ k ++ l ++ m; 26 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/ReduceBlocks.hs: -------------------------------------------------------------------------------- 1 | -- | Whenever we encounter a block containing another block not coupled with 2 | -- another statement (such as an if or a loop) we can safely just merge the 3 | -- blocks since they're guaranteed to not have any overlapping var names. 4 | module LambdaScript.Opt.ReduceBlocks (reduceBlocks) where 5 | import LambdaScript.Opt.Core 6 | import LambdaScript.CodeGen.Ops 7 | 8 | reduceBlocks :: Opt 9 | reduceBlocks = Opt { 10 | optStm = reduce, 11 | optExp = id 12 | } 13 | 14 | isBlock :: Stmt -> Bool 15 | isBlock (Block _) = True 16 | isBlock _ = False 17 | 18 | reduce :: Stmt -> Stmt 19 | reduce ex@(Block ss) = 20 | case span (not . isBlock) ss of 21 | (pre, Block b : post) -> reduce $ Block $ pre ++ b ++ post 22 | _ -> ex 23 | reduce x = x -------------------------------------------------------------------------------- /src/LambdaScript/CodeGen/GenTypes.hs: -------------------------------------------------------------------------------- 1 | -- | Compiles user-defined types into numeric representations. 2 | module LambdaScript.CodeGen.GenTypes where 3 | import LambdaScript.Abs 4 | import LambdaScript.CodeGen.Ops 5 | import qualified Data.Map as M 6 | import Data.List (foldl') 7 | 8 | -- | Generate the constructor -> ID mapping for a typedef. 9 | typeMap :: NewType -> M.Map String ConstrID 10 | typeMap (NewType _ _ cs) = 11 | M.fromList $ zipWith fixIO (map (\(Constructor (TIdent id) _) -> id) cs) [0..] 12 | where 13 | fixIO "IO" n = ("IO", -1) 14 | fixIO id n = (id, n) 15 | 16 | -- | Generate the constructor -> ID mapping for all typedefs. 17 | allTypesMap :: Program -> M.Map String ConstrID 18 | allTypesMap (Program defs) = 19 | foldl' addConstrs M.empty defs 20 | where 21 | addConstrs m (TypeDef nt) = m `M.union` typeMap nt 22 | addConstrs m _ = m 23 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/NoObviousIfs.hs: -------------------------------------------------------------------------------- 1 | -- | Remove all if-statements where the branch condition is trivially 1 or 0. 2 | module LambdaScript.Opt.NoObviousIfs (noObviousIfs) where 3 | import LambdaScript.Opt.Core 4 | import LambdaScript.CodeGen.Ops 5 | 6 | noObviousIfs :: Opt 7 | noObviousIfs = Opt { 8 | optStm = removeIfs, 9 | optExp = id 10 | } 11 | 12 | isOne :: Exp -> Bool 13 | isOne (Const (BoolConst True)) = True 14 | isOne (Const (NumConst n)) | n /= 0 = True 15 | isOne _ = False 16 | 17 | isZero :: Exp -> Bool 18 | isZero (Const (BoolConst False)) = True 19 | isZero (Const (NumConst 0)) = True 20 | isZero _ = False 21 | 22 | removeIfs :: Stmt -> Stmt 23 | removeIfs (If cond thenS melseS) 24 | | isOne cond = thenS 25 | | isZero cond = case melseS of 26 | Just elseS -> elseS 27 | _ -> NoStmt 28 | removeIfs x = x -------------------------------------------------------------------------------- /src/LambdaScript/Opt/InlineJSFun.hs: -------------------------------------------------------------------------------- 1 | -- | Replace all calls to _jsfun a call to an inlined version 2 | -- that takes its argument as a raw JS string, takes no arity and can NOT be 3 | -- partially applied. (Not that partially applying _jsfun before was 4 | -- particularly safe, but this makes it explicit.) 5 | module LambdaScript.Opt.InlineJSFun (inlineJSFun) where 6 | import LambdaScript.CodeGen.Ops 7 | import LambdaScript.Opt.Core 8 | 9 | inlineJSFun :: Opt 10 | inlineJSFun = Opt { 11 | optStm = id, 12 | optExp = inline 13 | } 14 | 15 | inline :: Exp -> Exp 16 | inline (Call _ (Call _ (Ident (Builtin "_jsfun")) [Thunk (Const (StrConst fun))]) _) = 17 | Call 0 (Ident (Builtin "$jsfun")) [(Const $ InlineStrConst fun)] 18 | inline (Call _ (Call _ (Ident (Builtin "_rawjsfun")) [Thunk (Const (StrConst fun))]) _) = 19 | Call 0 (Ident (Builtin "_rawjsfun")) [(Const $ InlineStrConst fun)] 20 | inline (Call _ (Call _ (Ident (Builtin "$jsfun")) args) next) = 21 | Call 0 (Ident (Builtin "$jsfun")) (args ++ next) 22 | inline x = 23 | x -------------------------------------------------------------------------------- /src/LambdaScript/Builtins.hs: -------------------------------------------------------------------------------- 1 | -- | Definitions for all built-in types and functions. 2 | module LambdaScript.Builtins where 3 | import LambdaScript.Abs 4 | import LambdaScript.Types 5 | 6 | assumptions :: [Assump] 7 | assumptions = map (\(id, t) -> id :>: quantify theVars t) defs 8 | 9 | functions :: Def 10 | functions = 11 | BGroup $ BindGroup $ flip map defs $ \(name, t) -> 12 | ConstDef (Ident name) (ETyped (EConstr $ TIdent "()") t) 13 | 14 | theVars = map VIdent ["a", "b"] 15 | 16 | defs :: [(ID, Type)] 17 | defs = [ 18 | ("()", tUnit), 19 | ("error", tString ~> tv "a"), 20 | ("_jsfun", tString ~> tInt ~> tv "a"), 21 | ("_rawjsfun", tString ~> tInt ~> tv "a"), 22 | ("_export", tInt ~> tv "a" ~> mkADT (TIdent "JSFun") []), 23 | ("$bind", io (tv "a") ~> (tv "a" ~> io (tv "b")) ~> io (tv "b")), 24 | ("div", tInt ~> tInt ~> tInt) 25 | ] 26 | 27 | types :: [NewType] 28 | types = [ 29 | NewType (TIdent "Bool") [] [ 30 | Constructor (TIdent "False") [], 31 | Constructor (TIdent "True") [] 32 | ] 33 | ] -------------------------------------------------------------------------------- /examples/tetris/shapes.ls: -------------------------------------------------------------------------------- 1 | export line, cube, tShape, zShape, zShapeFlip, lShape, lShapeFlip; 2 | import std; 3 | 4 | line = [[(0, 0), (0, 1), (0, 2), (0, 3)], 5 | [(0, 1), (1, 1), (2, 1), (3, 1)]]; 6 | 7 | cube = [[(0, 0), (0, 1), (1, 0), (1, 1)]]; 8 | 9 | tShape = [[(1, 0), (0, 1), (1, 1), (2, 1)], 10 | [(0, 0), (0, 1), (0, 2), (1, 1)], 11 | [(0, 0), (1, 0), (2, 0), (1, 1)], 12 | [(0, 1), (1, 0), (1, 1), (1, 2)]]; 13 | 14 | zShape = [[(0, 0), (1, 0), (1, 1), (2, 1)], 15 | [(1, 0), (0, 1), (1, 1), (0, 2)]]; 16 | 17 | zShapeFlip = [[(1, 0), (2, 0), (0, 1), (1, 1)], 18 | [(0, 0), (0, 1), (1, 1), (1, 2)]]; 19 | 20 | lShape = [[(1, 0), (1, 1), (1, 2), (0, 0)], 21 | [(0, 1), (1, 1), (2, 1), (2, 0)], 22 | [(0, 0), (0, 1), (0, 2), (1, 2)], 23 | [(0, 1), (1, 1), (2, 1), (0, 2)]]; 24 | 25 | lShapeFlip = [[(0, 0), (0, 1), (0, 2), (1, 0)], 26 | [(0, 0), (1, 0), (2, 0), (2, 1)], 27 | [(0, 2), (1, 0), (1, 1), (1, 2)], 28 | [(0, 0), (0, 1), (1, 1), (2, 1)]]; 29 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/ClosuresFromFoldedCalls.hs: -------------------------------------------------------------------------------- 1 | -- | Take a look at all Call expressions and turn those with arity >0 into 2 | -- closures. This optimization must be run after FoldCalls, as it depends 3 | -- on \a -> \b -> ... expressions being folded up into \a b -> ..., with 4 | -- the arity giving the number of arguments missing for a complete 5 | -- function application. 6 | -- Apart from FoldCalls, this optimization also requires Uncurry to be active 7 | -- in order to produce correct code. 8 | module LambdaScript.Opt.ClosuresFromFoldedCalls (closuresFromFolded) where 9 | import LambdaScript.Opt.Core 10 | import LambdaScript.CodeGen.Ops 11 | 12 | closuresFromFolded :: Opt 13 | closuresFromFolded = Opt { 14 | optStm = id, 15 | optExp = closures 16 | } 17 | 18 | -- | Fold a f(a)(b)(c) call into f(a,b,c). 19 | -- Also update the function's arity, so a complementary optimization can turn 20 | -- all function call expressions with arity >0 into closures. 21 | closures :: Exp -> Exp 22 | closures (Call n f args) | n > 0 = 23 | FunExp $ Lambda vars $ Block [Return 0 $ Call n f (args ++ map Ident vars)] 24 | where vars = take n newVars 25 | closures exp = 26 | exp 27 | -------------------------------------------------------------------------------- /src/LambdaScript/CodeGen/Module.hs: -------------------------------------------------------------------------------- 1 | -- | Data structures for representing modules. 2 | module LambdaScript.CodeGen.Module where 3 | import LambdaScript.CodeGen.Ops 4 | import LambdaScript.CodeGen.ShowJS 5 | import LambdaScript.Abs (Type (..)) 6 | import Data.List (intercalate) 7 | 8 | -- | Data type representing a single, exported function. 9 | data Function = Function { 10 | funName :: String, 11 | args :: [Var], 12 | stmts :: [Stmt], 13 | funType :: Type 14 | } 15 | 16 | instance ShowJS Function where 17 | showJS c f = 18 | "$._" ++ funName f ++ " = function(" ++ arglist ++ ")" ++ 19 | showJS c (Block $ stmts f) ++ ";\n" ++ 20 | "$._" ++ funName f ++ ".x = $._" ++ funName f ++ ";" 21 | where 22 | arglist = intercalate "," (map (showJS c) (args f)) 23 | 24 | -- | Data type representing a single module. 25 | data Module = Module { 26 | modName :: String, 27 | exports :: [String], 28 | funcs :: [Function] 29 | } 30 | 31 | instance ShowJS Module where 32 | showJS c (Module name exports funcs) = 33 | "function _" ++ name ++ "(){\nvar $ = this;\n" ++ 34 | concat (map (showJS c) funcs) ++ 35 | concat (map export exports) ++ 36 | "}\n" ++ name ++ " = new _" ++ name ++ "();\n" 37 | where 38 | export f = 39 | "$['" ++ f ++ "'] = _exp($._" ++ f ++ ");\n" 40 | -------------------------------------------------------------------------------- /tests/should-work/tree.ls: -------------------------------------------------------------------------------- 1 | import std; 2 | 3 | -- a binary tree using Ints as its key 4 | data Tree a 5 | = Nil 6 | | Tree Int, a, Tree a, Tree a 7 | ; 8 | 9 | -- an empty tree 10 | empty :: Tree a; 11 | empty = Nil; 12 | 13 | 14 | -- search for a key in a tree 15 | find :: Int -> Tree v -> Maybe v; 16 | find x (Nil) = Nothing ; 17 | find x (Tree k v l r) 18 | | x > k = find x r; 19 | | x < k = find x l; 20 | | otherwise = Just v; 21 | 22 | 23 | -- inserts a value into the tree 24 | insert :: (Int, v) -> Tree v -> Tree v; 25 | insert (k', v') (Tree k v l r) 26 | | k' > k = Tree k v l (insert (k', v') r); 27 | | k' < k = Tree k v (insert (k', v') l) r; 28 | | otherwise = Tree k v' l r; 29 | insert (k', v') (Nil) 30 | = Tree k' v' Nil Nil; 31 | 32 | t = insert (10, 10) (insert (5, 5) (insert (15, 15) (insert (25, 25) (insert (3, 3) empty)))); 33 | 34 | main = 35 | case find 15 t of 36 | (Just n) -> case find 3 t of 37 | (Just n') -> case find 26 t of 38 | (Just _) -> error "Nonexistent element 26 found!"; 39 | (Nothing) -> n+n'; 40 | ; 41 | _ -> error "Element 3 not found!"; 42 | ; 43 | _ -> error "Element 15 not found!"; 44 | ; 45 | -------------------------------------------------------------------------------- /src/LambdaScript/TCM.hs: -------------------------------------------------------------------------------- 1 | module LambdaScript.TCM where 2 | import LambdaScript.Types 3 | import LambdaScript.Abs (Type (..), VIdent (..)) 4 | 5 | newtype TCM a = TCM {runT :: Int -> Subst -> (a, Int, Subst)} 6 | 7 | type Infer e t = [Assump] -> e -> TCM (t, e) 8 | 9 | instance Monad TCM where 10 | return x = TCM $ \n s -> (x, n, s) 11 | m >>= f = TCM $ \n s -> case runT m n s of 12 | (a, n', s') -> runT (f a) n' s' 13 | 14 | -- | Create a new type variable. 15 | newTVar :: TCM Type 16 | newTVar = TCM $ \n s -> (TVar $ VIdent (enumId n), n+1, s) 17 | 18 | -- | Return the current substitution 19 | getSubst :: TCM Subst 20 | getSubst = TCM $ \n s -> (s, n, s) 21 | 22 | -- | Extend the current substitution 23 | extSubst :: Subst -> TCM () 24 | extSubst s' = TCM $ \n s -> ((), n, s' `compose` s) 25 | 26 | -- | Instantiate a type scheme; this entails binding a new type variable to 27 | -- each generic, quantified variable of the type. 28 | instantiate :: Scheme -> TCM Type 29 | instantiate (Forall n t) = 30 | mapM (\_ -> newTVar) (replicate n ()) >>= \ts -> return $ inst ts t 31 | 32 | -- | Unify two types, extending the global substitution with the resulting 33 | -- substitution. 34 | unify :: Type -> Type -> TCM () 35 | unify a b = do 36 | s <- getSubst 37 | extSubst =<< mgu (apply s a) (apply s b) 38 | 39 | -- | Run a type checking computation. 40 | runTCM :: TCM a -> (a, Subst) 41 | runTCM (TCM f) = 42 | case f 0 nullSubst of 43 | (x, n, s) -> (x, s) 44 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | HSFILES=LambdaScript/TypeChecker.hs LambdaScript/TCM.hs Main.hs LambdaScript/Depends.hs LambdaScript/Desugar.hs LambdaScript/Types.hs LambdaScript/CodeGen/Monad.hs LambdaScript/CodeGen/Ops.hs LambdaScript/CodeGen/Module.hs LambdaScript/CodeGen/Errors.hs LambdaScript/CodeGen/Generate.hs LambdaScript/Builtins.hs LambdaScript/CodeGen/ShowJS.hs LambdaScript/Opt/Core.hs LambdaScript/Opt/BooleanSimplifier.hs LambdaScript/Opt/Optimize.hs LambdaScript/Opt/NoZeroCompares.hs LambdaScript/Opt/NoObviousIfs.hs LambdaScript/Opt/ReduceBlocks.hs LambdaScript/Opt/NoUselessAssigns.hs LambdaScript/Opt/ZapArrays.hs LambdaScript/Annotate.hs LambdaScript/Opt/Uncurry.hs LambdaScript/Opt/FoldCalls.hs LambdaScript/Opt/ClosuresFromFoldedCalls.hs LambdaScript/Opt/UnThunkFunc.hs LambdaScript/Make.hs Args.hs LambdaScript/CodeGen/GenTypes.hs LambdaScript/Opt/InlineReturn.hs LambdaScript/Opt/InlineJSFun.hs LambdaScript/Opt/RemoveDeadCode.hs LambdaScript/Opt/TCE.hs 2 | 3 | all: .compiler 4 | 5 | .compiler: .bnfc $(HSFILES) 6 | ghc --make $(HSFLAGS) -o ../lsc Main.hs 7 | touch .compiler 8 | 9 | .bnfc: LambdaScript.cf 10 | bnfc -haskell -d LambdaScript LambdaScript.cf 11 | make -C LambdaScript .parser 12 | make -C LambdaScript .lexer 13 | touch .bnfc 14 | 15 | doc: 16 | mkdir -p ../docs/haddock 17 | haddock --ignore-all-exports --odir=../docs/haddock -h Main.hs 18 | 19 | 20 | clean: 21 | find . -name '*.hi' -exec rm \{\} \; 22 | find . -name '*.o' -exec rm \{\} \; 23 | rm .compiler .bnfc 24 | make -C LambdaScript clean 25 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/BooleanSimplifier.hs: -------------------------------------------------------------------------------- 1 | -- | Simplify boolean expressions. 2 | module LambdaScript.Opt.BooleanSimplifier (booleanSimplify) where 3 | import LambdaScript.CodeGen.Ops 4 | import LambdaScript.CodeGen.ShowJS -- for error messages 5 | import LambdaScript.Opt.Core 6 | 7 | isTrue :: Exp -> Bool 8 | isTrue (Const (BoolConst True)) = True 9 | isTrue _ = False 10 | 11 | isFalse :: Exp -> Bool 12 | isFalse (Const (BoolConst False)) = True 13 | isFalse _ = False 14 | 15 | true :: Exp 16 | true = Const (BoolConst True) 17 | 18 | false :: Exp 19 | false = Const (BoolConst False) 20 | 21 | booleanSimplify :: Opt 22 | booleanSimplify = Opt { 23 | optStm = id, 24 | optExp = simplify 25 | } 26 | 27 | -- | Recursively simplify an expression. 28 | simplify :: Exp -> Exp 29 | simplify (Oper And a b) 30 | | isTrue a && isTrue b = true 31 | | isTrue a = b 32 | | isTrue b = a 33 | | otherwise = Oper And a b 34 | simplify (Oper Or a b) 35 | | isFalse a && isFalse b = false 36 | | isFalse a = b 37 | | isFalse b = a 38 | | otherwise = Oper Or a b 39 | simplify (Oper Eq a b) 40 | | isTrue a && isTrue b = true 41 | | isFalse a && isFalse b = true 42 | | isTrue a = b 43 | | isTrue b = a 44 | | isFalse a = Neg b 45 | | isFalse b = Neg a 46 | simplify (Neg a) 47 | | isTrue a = false 48 | | isFalse a = true 49 | | otherwise = Neg a 50 | simplify x = 51 | x -------------------------------------------------------------------------------- /src/LambdaScript/Config.hs: -------------------------------------------------------------------------------- 1 | -- | Stores and manipulates configuration data for lsc. 2 | module LambdaScript.Config (Cfg (..), defCfg) where 3 | 4 | data Cfg = Cfg { 5 | forceModName :: String, -- ^ If the module name of the base module should 6 | -- be forcefully set to something other than the 7 | -- module's file name sans extension, set it to 8 | -- this value. Empty string means don't force. 9 | -- Default: "" 10 | libDir :: String, -- ^ The directory where libraries and runtime 11 | -- are kept. 12 | -- Default: "./lib" 13 | extraLibDirs::[String], -- ^ Additional directories to search for library 14 | -- files when compiling. 15 | -- Default: [] 16 | output :: String, -- ^ The file to write the comiled bundle to, sans 17 | -- file extension which will always be .js. 18 | -- Default: "a.out" 19 | input :: String, -- ^ The file to compile. 20 | -- Default: "" 21 | tailcalls :: Bool -- ^ Whether to optimize tail calls or not. 22 | -- Default: True 23 | } deriving Show 24 | 25 | -- | The default configuration. 26 | defCfg :: Cfg 27 | defCfg = Cfg { 28 | forceModName = "", 29 | libDir = "./lib", 30 | extraLibDirs = [], 31 | output = "a.out", 32 | input = "", 33 | tailcalls = True 34 | } -------------------------------------------------------------------------------- /lib/std.ls: -------------------------------------------------------------------------------- 1 | export map, head, tail, take, drop, fst, snd, reverse, filter, otherwise, undefined, length, zipWith, repeat, Maybe(..), Either(..), span; 2 | 3 | data Maybe a = Nothing | Just a; 4 | 5 | data Either a b = Left a | Right b; 6 | 7 | otherwise :: Bool; 8 | otherwise = True; 9 | 10 | undefined :: a; 11 | undefined = error "undefined"; 12 | 13 | fst :: (a, b) -> a; 14 | fst (a, _) = a; 15 | 16 | snd :: (a, b) -> b; 17 | snd (_, b) = b; 18 | 19 | head :: [a] -> a; 20 | head (x:_) = x; 21 | 22 | tail :: [a] -> [a]; 23 | tail (_:xs) = xs; 24 | 25 | take :: Int -> [a] -> [a]; 26 | take 0 _ = []; 27 | take n (x:xs) = x:take (n-1) xs; 28 | take _ _ = []; 29 | 30 | drop :: Int -> [a] -> [a]; 31 | drop 0 xs = xs; 32 | drop n (_:xs) = drop (n-1) xs; 33 | drop _ _ = []; 34 | 35 | span :: Int -> [a] -> ([a], [a]); 36 | span 0 xs = ([], xs); 37 | span n (x:xs) = case span (n-1) xs of 38 | (xs', ys) -> (x:xs', ys);; 39 | span _ _ = ([], []); 40 | 41 | reverse :: [a] -> [a]; 42 | reverse = reverse' [] { 43 | reverse' acc (x:xs) = reverse' (x:acc) xs; 44 | reverse' acc _ = acc; 45 | }; 46 | 47 | length :: [a] -> Int; 48 | length (x:xs) = 1 + length xs; 49 | length _ = 0; 50 | 51 | map :: (a -> b) -> [a] -> [b]; 52 | map f (x:xs) = f x : map f xs; 53 | map _ _ = []; 54 | 55 | filter :: (a -> Bool) -> [a] -> [a]; 56 | filter pred (x:xs) | pred x = x : filter pred xs; 57 | | otherwise = filter pred xs; 58 | filter _ _ = []; 59 | 60 | zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]; 61 | zipWith f (a:as) (b:bs) = f a b : zipWith f as bs; 62 | zipWith _ _ _ = []; 63 | 64 | repeat :: a -> [a]; 65 | repeat x = x : repeat x; 66 | -------------------------------------------------------------------------------- /lib/io.ls: -------------------------------------------------------------------------------- 1 | export return, alert, setTimeout, mapM, random, sequence_, newIORef, readIORef, writeIORef, onKeyUp, clearKeyUp, IO, JSFun, IORef; 2 | 3 | -- Opaque data type representing a javascript funvtion. 4 | data JSFun = JSFun; 5 | 6 | -- Opaque data type representing an IO reference. 7 | data IORef a = IORef; 8 | 9 | -- IO data constructor. 10 | data IO a = IO a; 11 | 12 | -- Monadic return. For highly monomorphic values of monad. 13 | return :: a -> IO a; 14 | return = IO; 15 | 16 | -- Javascript alert. 17 | alert :: a -> IO (); 18 | alert s = do { 19 | _jsfun "alert" 1 s; 20 | return (); 21 | }; 22 | 23 | -- Javascript window.setTimeout. 24 | setTimeout :: IO () -> Int -> IO (); 25 | setTimeout f n = do { 26 | _jsfun "window.setTimeout" 2 (_export 0 f) n; 27 | return (); 28 | }; 29 | 30 | mapM :: (a -> IO b) -> [a] -> IO [b]; 31 | mapM f (x:xs) = do { 32 | x' <- f x; 33 | xs' <- mapM f xs; 34 | return (x':xs'); 35 | }; 36 | mapM _ _ = return []; 37 | 38 | -- Returns a random double between 0 and 1. 39 | random :: IO Double; 40 | random = _jsfun "Math.random" 0; 41 | 42 | sequence_ :: [IO ()] -> IO (); 43 | sequence_ (x:xs) = do {x; sequence_ xs;}; 44 | sequence_ _ = return (); 45 | 46 | newIORef :: a -> IO (IORef a); 47 | newIORef x = _rawjsfun "$newIORef" 1 x; 48 | 49 | readIORef :: IORef a -> IO a; 50 | readIORef ref = _rawjsfun "$readIORef" 1 ref; 51 | 52 | writeIORef :: IORef a -> a -> IO (); 53 | writeIORef ref x = do { 54 | _rawjsfun "$writeIORef" 2 ref x; 55 | return (); 56 | }; 57 | 58 | onKeyUp :: (Int -> IO ()) -> IO (); 59 | onKeyUp f = do { 60 | _jsfun "$onKeyUp" 1 (_export 1 f); 61 | return (); 62 | }; 63 | 64 | clearKeyUp :: IO (); 65 | clearKeyUp = do { 66 | _jsfun "(function() {document.onkeyup = null; return 0;})" 0; 67 | return (); 68 | }; 69 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/Optimize.hs: -------------------------------------------------------------------------------- 1 | -- | Apply optimizations. 2 | module LambdaScript.Opt.Optimize (applyOpts) where 3 | import Data.List (foldl') 4 | import LambdaScript.CodeGen.Module 5 | import LambdaScript.Opt.Core 6 | import LambdaScript.Opt.BooleanSimplifier 7 | import LambdaScript.Opt.NoZeroCompares 8 | import LambdaScript.Opt.NoObviousIfs 9 | import LambdaScript.Opt.ZapArrays 10 | import LambdaScript.Opt.ReduceBlocks 11 | import LambdaScript.Opt.NoUselessAssigns 12 | -- import LambdaScript.Opt.Uncurry as U 13 | -- import LambdaScript.Opt.FoldCalls 14 | -- import LambdaScript.Opt.ClosuresFromFoldedCalls 15 | import LambdaScript.Opt.UnThunkFunc 16 | import LambdaScript.Opt.InlineReturn 17 | import LambdaScript.Opt.InlineJSFun 18 | import LambdaScript.Opt.RemoveDeadCode 19 | import LambdaScript.Opt.TCE 20 | 21 | -- | The list of optimizations to apply to the list of functions. Optimizations 22 | -- are applied from left to right. 23 | opts :: [Opt] 24 | opts = [ 25 | noZeroCompares, 26 | booleanSimplify, 27 | noObviousIfs, 28 | zapArrays, 29 | reduceBlocks, 30 | noUselessAssigns, 31 | {- Disable these three until the issue with generics returning functions 32 | is resolved. 33 | U.uncurry, 34 | foldCalls, 35 | closuresFromFolded,-} 36 | unEvalGlobals, 37 | inlineReturn, 38 | inlineJSFun, 39 | removeDeadCode 40 | ] 41 | 42 | -- | Apply optimizations to the functions. 43 | -- Something worth noting about tail call elimination, is that 44 | -- foo = bar 10; is NOT a tail call but rather a constant assignment. 45 | applyOpts :: Bool -- ^ Eliminate tail calls? 46 | -> [Function] -- ^ Functions to optimize 47 | -> [Function] 48 | applyOpts tce fs = 49 | map ((if tce then eliminateTailCalls else id) . unThunkFunc) 50 | $ foldl' (\fs o -> optimize o fs) fs opts 51 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import System.Environment (getArgs) 3 | import LambdaScript.Make (make) 4 | import Args 5 | import LambdaScript.Config 6 | 7 | handlers :: [Handler (Either () Cfg)] 8 | handlers = [ 9 | startsWith "-m" ==> setModName, 10 | startsWith "-o" ==> setOutput, 11 | startsWith "-L" ==> setLibDir, 12 | startsWith "-l" ==> setExtraLibDirs, 13 | (== "--no-tce") ==> noTailCalls, 14 | ((/= '-') . head) ==> setFileName, 15 | (== "--help") ==> showHelp 16 | ] 17 | 18 | noTailCalls _ _ (Right cfg) = 19 | Ok $ Right $ cfg {tailcalls = False} 20 | showHelp _ _ _ = 21 | Ok $ Left () 22 | setFileName name _ (Right cfg) = 23 | Ok $ Right $ cfg {input = name} 24 | setModName = 25 | withParams 2 $ \(mod:_) (Right a) -> 26 | Ok $ Right $ a {forceModName = mod} 27 | setOutput = 28 | withParams 2 $ \(out:_) (Right a) -> 29 | Ok $ Right $ a {output = out} 30 | setLibDir = 31 | withParams 2 $ \(dir:_) (Right a) -> 32 | Ok $ Right $ a {libDir = dir} 33 | setExtraLibDirs = 34 | withParams 2 $ \dirs (Right a) -> 35 | Continue $ Right $ a {extraLibDirs = extraLibDirs a ++ dirs} 36 | 37 | main :: IO () 38 | main = do 39 | args <- getArgs 40 | case match (Right defCfg) args handlers of 41 | Right cfg -> make cfg 42 | Left _ -> do 43 | putStrLn $ 44 | "Usage: lsc [options] file\n\n" ++ 45 | "List of options\n" ++ 46 | "--no-tce Disable tail call elimination\n" ++ 47 | "-m Force the name of the module to \n" ++ 48 | "-o Write the compiled bundle to .js\n" ++ 49 | "-L Set the main library directory to . " ++ 50 | " must contain a compatible runtime.js\n" ++ 51 | "-l\n" ++ 52 | " Add the directories dir1, dir2, ... to the library " ++ 53 | " path." 54 | -------------------------------------------------------------------------------- /lib/canvas.ls: -------------------------------------------------------------------------------- 1 | export withCanvasDo, getCanvas, fillColor, fillRect, Canvas, Color(..), Point(..); 2 | import io; 3 | import dom; 4 | import std; 5 | 6 | -- Abstract data type representing a canvas object. 7 | data Canvas = Canvas DOMElement; 8 | 9 | -- Represent colors! 10 | data Color = RGB Int, Int, Int; 11 | 12 | -- Represent points! 13 | data Point = Pt Int,Int; 14 | 15 | -- Fetches a canvas based on its ID property. 16 | getCanvas :: String -> IO (Maybe Canvas); 17 | getCanvas id = do { 18 | x <- getElementById id; 19 | case x of 20 | (Just x') -> do { 21 | n <- getAttr x' "tagName"; 22 | if n == "CANVAS" 23 | then do { 24 | ctx <- _jsfun "(function(x) {return x.getContext('2d');})" 1 x'; 25 | valid <- domElemValid ctx; 26 | if valid then return (Just (Canvas ctx)) else return Nothing; 27 | } 28 | else return Nothing; 29 | }; 30 | 31 | _ -> return Nothing; 32 | ; 33 | }; 34 | 35 | -- Set the fill color for the canvas' context. 36 | fillColor :: Canvas -> Color -> IO (); 37 | fillColor (Canvas can) (RGB r g b) = do { 38 | _jsfun "(function (c,r,g,b) {c.fillStyle = 'rgb('+r+','+g+','+b+')'; return 0;})" 4 can r g b; 39 | return (); 40 | }; 41 | 42 | -- Fill a rectangle using the current fill color. 43 | fillRect :: Canvas -> Point -> Point -> IO (); 44 | fillRect (Canvas can) (Pt x1 y1) (Pt x2 y2) = do { 45 | _jsfun "(function (c,x1,y1,x2,y2) {c.fillRect(x1,y1,x2,y2); return 0;})" 5 can x1 y1 x2 y2; 46 | return (); 47 | }; 48 | 49 | -- Attempt to acquire the canvas with the given name; if that fails, throw an 50 | -- error. If it succeeds, run the given action. 51 | withCanvasDo :: String -> (Canvas -> IO a) -> IO a; 52 | withCanvasDo can f = do { 53 | can' <- getCanvas can; 54 | case can' of 55 | (Just c) -> f c; 56 | _ -> error ("Failed to acquire canvas " ++ can ++ "!"); 57 | ; 58 | }; 59 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/NoUselessAssigns.hs: -------------------------------------------------------------------------------- 1 | -- | Where an assignment like var1 = var2 is made and it's not inside an if or 2 | -- loop, delete the assignment and instead replace every occurrence of var1 3 | -- with var2 in the rest of the function. 4 | module LambdaScript.Opt.NoUselessAssigns (noUselessAssigns) where 5 | import LambdaScript.Opt.Core 6 | import LambdaScript.CodeGen.Ops 7 | import Data.List (foldl') 8 | import Data.Maybe (catMaybes, listToMaybe) 9 | 10 | noUselessAssigns :: Opt 11 | noUselessAssigns = Opt { 12 | optStm = id, 13 | optExp = removeAss 14 | } 15 | 16 | findAs :: Stmt -> Maybe (Var, Var) 17 | findAs (Block stmts) = listToMaybe . catMaybes $ map findAs stmts 18 | findAs (Assign v (Ident v')) = Just (v, v') 19 | findAs (SelfThunk _ stmts) = listToMaybe . catMaybes $ map findAs stmts 20 | findAs (If _ th elm) = case (findAs th, elm) of 21 | (Nothing, Just el) -> findAs el 22 | (th', _) -> th' 23 | findAs (Forever s) = findAs s 24 | findAs (Return _ exp) = findAsEx exp 25 | findAs (ExpStmt ex) = findAsEx ex 26 | findAs _ = Nothing 27 | 28 | findAsEx :: Exp -> Maybe (Var, Var) 29 | findAsEx (FunExp (Lambda _ s)) = findAs s 30 | findAsEx (StmtEx s e) = case findAs (Block s) of 31 | Nothing -> findAsEx e 32 | x -> x 33 | findAsEx _ = Nothing 34 | 35 | removeAss :: Exp -> Exp 36 | removeAss ex@(FunExp (Lambda vs b)) = 37 | case findAs b of 38 | Just (v, v') -> 39 | removeAss $ FunExp (Lambda vs $ killAssign v v' $ optimize (subst v v') b) 40 | _ -> 41 | ex 42 | removeAss x = 43 | x 44 | 45 | -- Apply the substitution as an optimization, since we can then take advantage 46 | -- of the common traversing infrastructure. 47 | subst :: Var -> Var -> Opt 48 | subst v v' = Opt { 49 | optStm = killAssign v v', 50 | optExp = substVar v v' 51 | } 52 | 53 | killAssign :: Var -> Var -> Stmt -> Stmt 54 | killAssign v v' (Assign x (Ident x')) 55 | | x == v && x' == v' = 56 | NoStmt 57 | killAssign _ _ x = 58 | x 59 | 60 | 61 | substVar :: Var -> Var -> Exp -> Exp 62 | substVar v new (Ident v') | (v == v') = 63 | Ident new 64 | substVar _ _ x = 65 | x 66 | -------------------------------------------------------------------------------- /src/Args.hs: -------------------------------------------------------------------------------- 1 | -- | Functions for handling command line arguments in a somewhat orderly 2 | -- fashion. 3 | module Args (Handled (..), Handler, match, (==>), startsWith, withParams) where 4 | import Data.List (foldl') 5 | 6 | type Handler a = String -> [String] -> a -> Handled a 7 | 8 | -- | Match arguments against predicates, applying a transformation to a config 9 | -- whenever the predicate matches. 10 | match :: a -> [String] -> [Handler a] -> a 11 | match cfg args handlers = 12 | fst $ foldl' (\(a, (_:args)) arg -> 13 | (handle handlers a arg args, args)) 14 | (cfg, args) args 15 | 16 | data Handled a = Ok a | Continue a | NotMine 17 | 18 | -- | Iterate from left to right over a list of handlers. The first handler that 19 | -- handles the argument returns Ok which breaks out of the 20 | -- loop. Any handler that doesn't handle the argument just returns NotMine, 21 | -- to let the search for a new handler continue. 22 | handle :: [Handler a] -- ^ List of handlers to try on the argument. 23 | -> a -- ^ Initial value to be updated on successful handling. 24 | -> String -- ^ The argument to be handled 25 | -> [String] -- ^ All arguments following the current argument. 26 | -> a 27 | handle (f:fs) a arg args = 28 | case f arg args a of 29 | Ok a' -> a' 30 | Continue a' -> a' `seq` handle fs a' arg args 31 | _ -> handle fs a arg args 32 | handle _ a _ _ = 33 | a 34 | 35 | -- | Pair predicates with transformations. 36 | (==>) :: (String -> Bool) -> Handler a -> Handler a 37 | (==>) pred act = \s ss a -> if pred s then act s ss a else NotMine 38 | 39 | -- | Matches whenever the string to match starts with the given prefix. 40 | startsWith :: String -> String -> Bool 41 | startsWith s = (== s) . take (length s) 42 | 43 | -- | Split a list on each occurrence of a delimiter. 44 | splitBy :: Eq a => a -> [a] -> [[a]] 45 | splitBy delim = splitBy' [] 46 | where 47 | splitBy' a (x:xs) 48 | | x == delim = 49 | reverse a : splitBy' [] xs 50 | | otherwise = 51 | splitBy' (x:a) xs 52 | splitBy' a _ = 53 | [reverse a] 54 | 55 | -- | "Parses" the parameters of an argument for a handler. 56 | -- The parameters are assumed to be specified like -xfoo,bar. 57 | withParams :: Int -> ([String] -> a -> Handled a) -> Handler a 58 | withParams len h s ss a = 59 | h (splitBy ',' $ drop len s) a 60 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/Uncurry.hs: -------------------------------------------------------------------------------- 1 | -- | Turn all \a -> \b -> ... functions into \a b -> ... 2 | -- Note that this optimization depends on the FoldCalls and 3 | -- ClosuresFromFoldedCalls optimizations to generate correct code. 4 | module LambdaScript.Opt.Uncurry (LambdaScript.Opt.Uncurry.uncurry) where 5 | import LambdaScript.Opt.Core 6 | import LambdaScript.CodeGen.Ops 7 | 8 | uncurry :: Opt 9 | uncurry = Opt { 10 | optStm = id, 11 | optExp = uncurry' 12 | } 13 | 14 | delLast :: [a] -> [a] 15 | delLast (x:xs@(_:_)) = x:delLast xs 16 | delLast _ = [] 17 | 18 | -- | Inlines any functions at the end of this function. 19 | -- TODO: 20 | -- Since constructors are handled using a runtime helper function that's 21 | -- able to take its arguments either like C(1,2,3) or C(1)(2)(3) we don't 22 | -- need to consider the constructor case for correctness, but we definitely 23 | -- should for performance. 24 | uncurry' :: Exp -> Exp 25 | uncurry' ex@(FunExp (Lambda vs (Block ss))) = 26 | case last ss of 27 | Return n (FunExp (Lambda vs' (Block ss'))) -> 28 | FunExp (Lambda (vs ++ vs') (Block (delLast ss ++ ss'))) 29 | Return n (FunExp (FunIdent id)) -> 30 | inlineFunIdent n (Ident $ Global 1 id) 31 | Return n v@(Ident _) -> 32 | inlineFunIdent n v 33 | -- Only idents are ever thunks, so it can't be anything but an ident. 34 | Return n v@(Eval (Ident _)) -> 35 | inlineFunIdent n v 36 | _ -> 37 | ex 38 | where 39 | -- | Inline a function identifier. If the function has arity 0 we just return 40 | -- it. Otherwise, we choose n new vars (since we use a different naming 41 | -- convention there will be no name clashes, and since we only just 42 | -- introduced them they aren't used in any inner lambdas and so there will 43 | -- be no problems with name capture) to add to the parent function's argument 44 | -- list, and return the result of calling the returned function with those 45 | -- arguments. Since the arguments come straight from the parent's argument 46 | -- list, they're already thunked so we don't need to thunk them again. 47 | inlineFunIdent :: Int -> Exp -> Exp 48 | inlineFunIdent n var = 49 | let vs' = take n newVars 50 | ss' = if n == 0 51 | then [Return n var] 52 | else [Return 0 $ Call n var (map Ident vs')] 53 | in FunExp $ Lambda (vs ++ vs') (Block (delLast ss ++ ss')) 54 | uncurry' x = x 55 | -------------------------------------------------------------------------------- /docs/jsfun-howto.txt: -------------------------------------------------------------------------------- 1 | ** How to write JS-interfacing functions using _jsfun ** 2 | 3 | 4 | _jsfun is basically an interface to raw JS; it takes two mandatory arguments, 5 | a string representing an arbitrary JS expression, and an integer representing 6 | the arity of the expression. After that, the arguments to the expression are 7 | given. 8 | 9 | If we want to create an LS equivalent to alert(), we'd write: 10 | alert :: String -> IO (); 11 | alert text = do { 12 | _jsfun "alert" 1 text; 13 | return (); 14 | }; 15 | 16 | While _jsfun has type String -> Int -> a to facilitate varargs usage, it 17 | should ALWAYS be called as though its return type were IO a! 18 | 19 | If we wanted a prompt() equivalent: 20 | prompt :: String -> IO String; 21 | prompt question = _jsfun "prompt" 1 question; 22 | 23 | What if we want JS to be able to call us back? Use _export; it takes an 24 | integer as its first parameter and a function as its second. The integer gives 25 | the arity of the function. For example we can create an interface to 26 | window.setTimeout like this: 27 | setTimeout :: IO () -> Int -> IO (); 28 | setTimeout f n = do { 29 | _jsfun "window.setTimeout" 2 (_export 0 f) n; 30 | return (); 31 | }; 32 | 33 | 34 | 35 | 36 | ** Limitations of _jsfun ** 37 | 38 | _jsfun isn't meant to be thrown around and used all over the place, but rather 39 | as a controlled means of bringing JS and DOM interaction to LS. As such, its 40 | use comes with several restrictions that does not apply to normal LS 41 | functions. 42 | 43 | _jsfun can NOT be partially applied. If you want to do that then you have to 44 | create your own call-specific wrapper: 45 | someCall x y z = _jsfun "someCall" 3 x y z; 46 | _jsfun isn't meant thrown around, but as an extremely controlled way of 47 | bringing I/O to LS. Thus it doesn't really make sense to take any pains to 48 | ensure _jsfun can do the same functional acrobatics as other functions. 49 | 50 | _jsfun will also evaluate all of its arguments when invoked, since the JS 51 | function you're calling doesn't know about thunks. Thus, the following call 52 | will always throw an error even though the argument is never actually used: 53 | _jsfun "someFunctionThatDoesntUseItsArgument" 1 undefined; 54 | 55 | At present, JS functions returned by _jsfun can not be called by LS programs. 56 | 57 | Finally, since the type of _jsfun is pretty much a huge hole in the type 58 | system, it's critical that you explicitly specify the correct types of your 59 | _jsfun-using functions. 60 | -------------------------------------------------------------------------------- /src/LambdaScript/Opt/UnThunkFunc.hs: -------------------------------------------------------------------------------- 1 | -- | Ensures that all globals are non-thunks. 2 | -- Codegen expects this and relies on it to generate correct code, so it's 3 | -- sort of important. 4 | module LambdaScript.Opt.UnThunkFunc (unEvalGlobals, unThunkFunc) where 5 | import LambdaScript.CodeGen.Ops 6 | import LambdaScript.CodeGen.Module 7 | import LambdaScript.Opt.Core 8 | import LambdaScript.Abs (Type(..), TIdent(..)) 9 | 10 | unEvalGlobals :: Opt 11 | unEvalGlobals = Opt { 12 | optStm = id, 13 | optExp = unEvalGlobal 14 | } 15 | 16 | unEvalGlobal :: Exp -> Exp 17 | unEvalGlobal (Call n (Eval f@(Ident (Global arity _))) args) | arity > 0 = 18 | Call n f (map thunkGlobal args) 19 | unEvalGlobal (Call n (Eval f@(Ident (Import arity _ a))) args) | arity > 0 = 20 | Call n f (map thunkGlobal args) 21 | unEvalGlobal (Call n (Eval f@(Ident (Builtin a))) args) = 22 | Call n f (map thunkGlobal args) 23 | unEvalGlobal (Call n f args) = 24 | Call n f (map thunkGlobal args) 25 | unEvalGlobal x = 26 | x 27 | 28 | thunkGlobal g@(Ident (Global n _)) | n > 0 = Thunk g 29 | thunkGlobal g@(Ident (Import n _ _)) | n > 0 = Thunk g 30 | thunkGlobal x = x 31 | 32 | -- | Having global functions as thunks isn't really beneficial in any way. 33 | -- Since the body of every function only consists of a lambda function, 34 | -- just shuffle the args around to get rid of one redirection. 35 | -- If it's a nullary function however, thunking it is still beneficial. 36 | unThunkFunc :: Function -> Function 37 | unThunkFunc (Function n _ [Return arity (FunExp (Lambda as (Block b)))] t) = 38 | Function n as b t 39 | -- Take the liberty of using a named temp variable "a" to transfer the 40 | -- argument; no code runs between its creation and last use, so name capture 41 | -- is impossible. 42 | unThunkFunc (Function n [] [Return arity ex] t) | arity > 0 = 43 | Function n [NamedTemp "a"] [ 44 | Return (arity-1) (Call arity (unEval ex) [Ident $ NamedTemp "a"]) 45 | ] t 46 | where 47 | unEval (Eval ex) = ex 48 | unEval ex = ex 49 | unThunkFunc fun@(Function n _ b t) = 50 | case t of 51 | TApp (TCon (TIdent "IO")) _ -> 52 | fun 53 | _ -> 54 | Function n [] [(SelfThunk n assignified)] t 55 | where 56 | replaceLast [_] x' = x' 57 | replaceLast (x:xs) x' = x : replaceLast xs x' 58 | replaceLast _ x' = x' 59 | 60 | assignified = 61 | case last b of 62 | Return _ ex -> 63 | replaceLast b [Assign (Global 0 $ n ++ ".e") $ Const $ NumConst 1, 64 | Assign (Global 0 $ n ++ ".x") ex] 65 | _ -> 66 | error $ "Last statement in lambda not return!\n" ++ show b 67 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | ** NOTE 2 | 3 | Lambdascript is, as you've probably figured out by looking at commit 4 | statistics, no longer active. It's been superceeded by Haste 5 | (https://haste-lang.org) - a compiler that does actual Haskell. 6 | 7 | 8 | ** About 9 | 10 | Lambdascript is a prototype language for strongly typed, lazy, purely 11 | functional client side web scripting. It provides a basic subset of 12 | Haskell's functionality, compiled into Javascript. 13 | 14 | Due to its clumsy parser and fugly syntax, the plan is to scrap the thing 15 | after it's more or less done (hence, prototype) and rewrite the project using 16 | saner tools (BNFC is somewhat suboptimal for anything that's supposed to 17 | actually be of any use) to enable some essential features (read: polymorphism) 18 | and nicer syntax. 19 | 20 | 21 | ** Building & dependencies 22 | 23 | To build the Lambdascript compiler (lsc,) simply run 'make' in the project's 24 | root directory; to run the test suite, 'make test' and to build the 25 | documentation 'make doc'. 26 | 27 | In order to compile LS, you need GHC, BNFC Happy and Alex; the Haskell 28 | compiler, parser generator generator, parser generator and lexer generator 29 | respectively. 30 | 31 | GHC, Happy and Alex are all included in the Haskell platform, available from 32 | http://hackage.haskell.org/platform/ and BNFC can be found at 33 | http://hackage.haskell.org/package/BNFC. 34 | 35 | In order to run the test suite, you need spidermonkey installed. That's also 36 | handily available from your package manager if you're on Debian with 37 | derivatives, and you might also want to install Haddock (which is also 38 | included in the Haskell platform) so you can build the documentation. 39 | 40 | On Debian with derivatives, you can install everything you need by issuing: 41 | # apt-get install haskell-platform bnfc spidermonkey-bin 42 | 43 | 44 | ** Compiling & running programs 45 | 46 | To compile a Lambdascript program into Javascript, run the compiler (lsc) in 47 | the root directory of the project with the input file as its only argument: 48 | $ ./lsc some/lambdascript/input/file.ls 49 | The output file, a.out.js if nothing else is specified, will be created in 50 | your working directory. 51 | 52 | If you want to run lsc from another directory, you need to specify the path 53 | where runtime.js can be found using the -L switch: 54 | $ ./some/dir/lsc myfile.ls -Lsome/dir/lib 55 | 56 | To run your newly compiled program, include it in an HTML document using the 57 |