├── test ├── specs │ ├── execute │ │ ├── fix#33 │ │ │ ├── a.keli │ │ │ ├── b.keli │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── fix#41 │ │ │ ├── a.keli │ │ │ ├── b.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── SKIP:generic-object-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── bifunc-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── comment-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── array-literal-2 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── ffi-javascript-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── func-chaining-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── func-chaining-2 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── identity-func-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── trifunc-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── access-tag-carry-2 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── array-literal-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── else-tag-matcher-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── ffi-javascript-2 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── lambda-shorthand-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── access-tag-carry-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── docstring-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── generic-tagged-union-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── generic-tagged-union-6 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── generic-tagged-union-8 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── module-import-3 │ │ │ ├── output │ │ │ ├── A.keli │ │ │ ├── entry.keli │ │ │ └── K │ │ │ │ └── B.keli │ │ ├── record-getter-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── SKIP:generic-tagged-union-10 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── carryless-tag-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── complete-tag-matcher-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── func-without-return-type-annot-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── generic-tagged-union-9 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── record-type-alias-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── tagged-union-as-type-annot-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @circular-import-2 │ │ │ ├── a.keli │ │ │ ├── b.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── @duplicated-const-id-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── carryful-tag-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── generic-tagged-union-2 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── generic-tagged-union-5 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── insensitive-decl-order-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── object-literal-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── record-creation-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── recursive-func-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @circular-import-1 │ │ │ ├── a.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── generic-tagged-union-7 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── module-import-2 │ │ │ ├── output │ │ │ ├── src │ │ │ │ ├── File1.keli │ │ │ │ └── File2.keli │ │ │ └── entry.keli │ │ ├── multiple-dispatch-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── multiple-dispatch-2 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── record-lambda-setter-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── recursive-tagged-union-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── record-as-type-annot-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @importing-unexisting-file-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── module-import-4 │ │ │ ├── A.keli │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── module-import-1 │ │ │ ├── output │ │ │ ├── src │ │ │ │ ├── File1.keli │ │ │ │ └── File2.keli │ │ │ └── entry.keli │ │ ├── multiline-string-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── tostring-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── record-as-type-annot-2 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @duplicated-func-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── generic-tagged-union-4 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── record-value-setter-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @record-missing-prop-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── mutual-recursion-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── generic-tagged-union-3 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @incorrect-carry-type-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── @incorrect-lambda-param-type-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── @record-prop-type-mismatch-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── SKIP:@type-mismatch-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @tag-matcher-using-unknown-tag-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @tag-invalid-carry-type-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @generic-tagged-union-type-mismatch-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @tag-matcher-missing-branch-1 │ │ │ ├── output │ │ │ └── entry.keli │ │ ├── @tag-matcher-duplicate-tags-1 │ │ │ ├── entry.keli │ │ │ └── output │ │ └── @tag-matcher-hetero-branch-1 │ │ │ ├── entry.keli │ │ │ └── output │ ├── suggest │ │ ├── suggest-case-expr-1 │ │ │ ├── where │ │ │ ├── sample.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── suggest-imported-symbol-1 │ │ │ ├── where │ │ │ ├── sample.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── suggest-object-alias-1 │ │ │ ├── where │ │ │ ├── sample.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── suggest-tagged-union-1 │ │ │ ├── where │ │ │ ├── sample.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── suggest-for-function-chaining-2 │ │ │ ├── where │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── suggest-for-lambda-shorthand-1 │ │ │ ├── where │ │ │ ├── sample.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ ├── suggest-for-lambda-shorthand-2 │ │ │ ├── where │ │ │ ├── sample.keli │ │ │ ├── entry.keli │ │ │ └── output │ │ └── suggest-for-function-chaining-1 │ │ │ ├── where │ │ │ ├── entry.keli │ │ │ └── output │ └── completion-item │ │ ├── @case-1 │ │ ├── @case-3 │ │ ├── @lambda-shorthand │ │ ├── @case-4 │ │ └── @case-2 ├── skipped-spec │ ├── tagged-union │ │ ├── generic-3 │ │ ├── else-tag-2 │ │ └── generic-constrained-1 │ └── interface │ │ └── case-1 ├── README.md └── Spec.hs ├── Setup.hs ├── .gitignore ├── src ├── Lib.hs ├── Error │ └── Preprocess.hs ├── Infer.hs ├── Module.hs ├── Sample.hs ├── Interpreter.hs ├── Lexer.hs ├── Ast │ ├── Raw.hs │ └── Verified.hs ├── Env.hs ├── Repl.hs ├── Util.hs ├── PreludeJSCode.hs ├── Cli.hs ├── StaticError.hs ├── Compiler.hs ├── Package.hs ├── Transpiler.hs ├── Parser.hs ├── CompletionItems.hs └── Analyzer.hs ├── ChangeLog.md ├── app └── Main.hs ├── Glossary.md ├── package.yaml ├── README.md ├── stack.yaml ├── kelilib └── prelude.js ├── test_output.txt └── LICENSE /test/specs/execute/fix#33/a.keli: -------------------------------------------------------------------------------- 1 | x = 5 -------------------------------------------------------------------------------- /test/specs/execute/fix#33/b.keli: -------------------------------------------------------------------------------- 1 | x = 5 -------------------------------------------------------------------------------- /test/specs/execute/fix#41/a.keli: -------------------------------------------------------------------------------- 1 | x = 5 -------------------------------------------------------------------------------- /test/specs/execute/SKIP:generic-object-1/output: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/specs/execute/bifunc-1/output: -------------------------------------------------------------------------------- 1 | Line 2 = 123 -------------------------------------------------------------------------------- /test/specs/execute/comment-1/output: -------------------------------------------------------------------------------- 1 | Line 3 = 123 -------------------------------------------------------------------------------- /test/specs/execute/fix#33/output: -------------------------------------------------------------------------------- 1 | Line 4 = 123 -------------------------------------------------------------------------------- /test/specs/execute/array-literal-2/entry.keli: -------------------------------------------------------------------------------- 1 | = [] -------------------------------------------------------------------------------- /test/specs/execute/array-literal-2/output: -------------------------------------------------------------------------------- 1 | Line 1 = [] -------------------------------------------------------------------------------- /test/specs/execute/ffi-javascript-1/output: -------------------------------------------------------------------------------- 1 | Line 3 = 3 -------------------------------------------------------------------------------- /test/specs/execute/func-chaining-1/output: -------------------------------------------------------------------------------- 1 | Line 3 = 6 -------------------------------------------------------------------------------- /test/specs/execute/func-chaining-2/output: -------------------------------------------------------------------------------- 1 | Line 3 = 6 -------------------------------------------------------------------------------- /test/specs/execute/identity-func-1/output: -------------------------------------------------------------------------------- 1 | Line 6 = 99 -------------------------------------------------------------------------------- /test/specs/execute/trifunc-1/output: -------------------------------------------------------------------------------- 1 | Line 6 = "hello" -------------------------------------------------------------------------------- /test/specs/suggest/suggest-case-expr-1/where: -------------------------------------------------------------------------------- 1 | 4 2 | 15 -------------------------------------------------------------------------------- /test/specs/execute/access-tag-carry-2/output: -------------------------------------------------------------------------------- 1 | Line 8 = 99 -------------------------------------------------------------------------------- /test/specs/execute/array-literal-1/entry.keli: -------------------------------------------------------------------------------- 1 | = [1,2,3] -------------------------------------------------------------------------------- /test/specs/execute/array-literal-1/output: -------------------------------------------------------------------------------- 1 | Line 1 = [1,2,3] -------------------------------------------------------------------------------- /test/specs/execute/else-tag-matcher-1/output: -------------------------------------------------------------------------------- 1 | Line 6 = 1 -------------------------------------------------------------------------------- /test/specs/execute/ffi-javascript-2/output: -------------------------------------------------------------------------------- 1 | Line 10 = 123 -------------------------------------------------------------------------------- /test/specs/execute/lambda-shorthand-1/output: -------------------------------------------------------------------------------- 1 | Line 6 = 10 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-imported-symbol-1/where: -------------------------------------------------------------------------------- 1 | 2 2 | 5 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-object-alias-1/where: -------------------------------------------------------------------------------- 1 | 2 2 | 2 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-tagged-union-1/where: -------------------------------------------------------------------------------- 1 | 3 2 | 7 -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/specs/execute/access-tag-carry-1/output: -------------------------------------------------------------------------------- 1 | Line 10 = 7 2 | -------------------------------------------------------------------------------- /test/specs/execute/docstring-1/output: -------------------------------------------------------------------------------- 1 | 2 | Line 13 = List.Nil -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-1/output: -------------------------------------------------------------------------------- 1 | Line 17 = 2 -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-6/output: -------------------------------------------------------------------------------- 1 | Line 5 = 123 -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-8/output: -------------------------------------------------------------------------------- 1 | Line 14 = 0 -------------------------------------------------------------------------------- /test/specs/execute/module-import-3/output: -------------------------------------------------------------------------------- 1 | Line 3 = Answer.No -------------------------------------------------------------------------------- /test/specs/execute/record-getter-1/output: -------------------------------------------------------------------------------- 1 | 2 | Line 1 = "dog" -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-function-chaining-2/where: -------------------------------------------------------------------------------- 1 | 3 2 | 5 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-1/where: -------------------------------------------------------------------------------- 1 | 5 2 | 22 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-2/where: -------------------------------------------------------------------------------- 1 | 5 2 | 27 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | keli-compiler.cabal 3 | *~ 4 | youtube -------------------------------------------------------------------------------- /test/specs/execute/SKIP:generic-tagged-union-10/output: -------------------------------------------------------------------------------- 1 | Line 14 = 0 -------------------------------------------------------------------------------- /test/specs/execute/carryless-tag-1/output: -------------------------------------------------------------------------------- 1 | 2 | Line 3 = Boolean.True -------------------------------------------------------------------------------- /test/specs/execute/complete-tag-matcher-1/output: -------------------------------------------------------------------------------- 1 | 2 | 3 | Line 7 = 2 -------------------------------------------------------------------------------- /test/specs/execute/func-without-return-type-annot-1/output: -------------------------------------------------------------------------------- 1 | Line 3 = 3 -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-9/output: -------------------------------------------------------------------------------- 1 | Line 9 = $.count(1) -------------------------------------------------------------------------------- /test/specs/execute/record-type-alias-1/output: -------------------------------------------------------------------------------- 1 | Line 2 = $.taste(3) -------------------------------------------------------------------------------- /test/specs/execute/tagged-union-as-type-annot-1/output: -------------------------------------------------------------------------------- 1 | Line 7 = "yo" -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-function-chaining-1/where: -------------------------------------------------------------------------------- 1 | 2 2 | 12 -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lib where 3 | -------------------------------------------------------------------------------- /test/specs/execute/@circular-import-2/a.keli: -------------------------------------------------------------------------------- 1 | = module.import("./b.keli") -------------------------------------------------------------------------------- /test/specs/execute/@duplicated-const-id-1/entry.keli: -------------------------------------------------------------------------------- 1 | x=5 2 | x=5 3 | 4 | -------------------------------------------------------------------------------- /test/specs/execute/carryful-tag-1/output: -------------------------------------------------------------------------------- 1 | 2 | Line 5 = IntList.Cons(123) -------------------------------------------------------------------------------- /test/specs/execute/fix#41/b.keli: -------------------------------------------------------------------------------- 1 | = module.import("a.keli") 2 | y = x 3 | -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-2/output: -------------------------------------------------------------------------------- 1 | 2 | 3 | Line 23 = 4 -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-5/output: -------------------------------------------------------------------------------- 1 | Line 23 = Box.With(1) -------------------------------------------------------------------------------- /test/specs/execute/insensitive-decl-order-1/output: -------------------------------------------------------------------------------- 1 | 2 | 3 | Line 6 = 123 -------------------------------------------------------------------------------- /test/specs/execute/object-literal-1/output: -------------------------------------------------------------------------------- 1 | Line 3 = $.age(99) name("Haha") -------------------------------------------------------------------------------- /test/specs/execute/record-creation-1/output: -------------------------------------------------------------------------------- 1 | Line 1 = $.name("dog") age(5) -------------------------------------------------------------------------------- /test/specs/execute/record-getter-1/entry.keli: -------------------------------------------------------------------------------- 1 | = $.name("dog").name 2 | -------------------------------------------------------------------------------- /test/specs/execute/recursive-func-1/output: -------------------------------------------------------------------------------- 1 | Line 16 = 6 2 | Line 17 = 720 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-case-expr-1/sample.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-object-alias-1/sample.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-tagged-union-1/sample.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for keli-compiler 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /test/specs/execute/@circular-import-1/a.keli: -------------------------------------------------------------------------------- 1 | = module.import("./entry.keli") -------------------------------------------------------------------------------- /test/specs/execute/@circular-import-1/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("./a.keli") -------------------------------------------------------------------------------- /test/specs/execute/@circular-import-2/b.keli: -------------------------------------------------------------------------------- 1 | = module.import("./entry.keli") -------------------------------------------------------------------------------- /test/specs/execute/@circular-import-2/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("./a.keli") -------------------------------------------------------------------------------- /test/specs/execute/fix#41/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("b.keli") 2 | 3 | = x -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-7/output: -------------------------------------------------------------------------------- 1 | Line 15 = Box.Ok($.value(5)) -------------------------------------------------------------------------------- /test/specs/execute/module-import-2/output: -------------------------------------------------------------------------------- 1 | Line 6 = -123 2 | Line 8 = -123.1 -------------------------------------------------------------------------------- /test/specs/execute/multiple-dispatch-1/output: -------------------------------------------------------------------------------- 1 | Line 3 = 999 2 | Line 4 = "yoyo" -------------------------------------------------------------------------------- /test/specs/execute/multiple-dispatch-2/output: -------------------------------------------------------------------------------- 1 | Line 4 = 0 2 | Line 5 = 9 3 | -------------------------------------------------------------------------------- /test/specs/execute/record-lambda-setter-1/output: -------------------------------------------------------------------------------- 1 | Line 5 = $.name("dog") age(19) -------------------------------------------------------------------------------- /test/specs/execute/recursive-tagged-union-1/output: -------------------------------------------------------------------------------- 1 | Line 32 = 3 2 | Line 33 = 6 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-imported-symbol-1/sample.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 -------------------------------------------------------------------------------- /test/specs/execute/bifunc-1/entry.keli: -------------------------------------------------------------------------------- 1 | (x Int).+(y Int)|Int=123 2 | =1.+(3) 3 | -------------------------------------------------------------------------------- /test/specs/execute/record-as-type-annot-1/output: -------------------------------------------------------------------------------- 1 | Line 5 = $.name("pineapple") 2 | -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-1/sample.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-2/sample.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 -------------------------------------------------------------------------------- /src/Error/Preprocess.hs: -------------------------------------------------------------------------------- 1 | module Error.Preprocess where 2 | 3 | data PreprocessError = Hi -------------------------------------------------------------------------------- /test/specs/execute/@importing-unexisting-file-1/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("hello.keli") -------------------------------------------------------------------------------- /test/specs/execute/module-import-3/A.keli: -------------------------------------------------------------------------------- 1 | Answer = choice 2 | .Yes .No 3 | = 12 -------------------------------------------------------------------------------- /test/specs/execute/module-import-4/A.keli: -------------------------------------------------------------------------------- 1 | {A Type} 2 | (this A).haha = "generic haha" -------------------------------------------------------------------------------- /test/specs/execute/record-creation-1/entry.keli: -------------------------------------------------------------------------------- 1 | = $.name("dog") age(5) 2 | 3 | 4 | -------------------------------------------------------------------------------- /src/Infer.hs: -------------------------------------------------------------------------------- 1 | module Infer where 2 | -- start by inferring small generic tagged union first -------------------------------------------------------------------------------- /test/specs/completion-item/@case-1: -------------------------------------------------------------------------------- 1 | = "hello"; 2 | 3 | ==== 4 | 5 | KErrorIncompleteFuncCall -------------------------------------------------------------------------------- /test/specs/execute/record-type-alias-1/entry.keli: -------------------------------------------------------------------------------- 1 | Fruit= $.taste(Int) 2 | =Fruit.taste(3) 3 | -------------------------------------------------------------------------------- /test/specs/execute/module-import-1/output: -------------------------------------------------------------------------------- 1 | Line 3 = 123 2 | Line 5 = 3.14 3 | Line 7 = Shape.Square -------------------------------------------------------------------------------- /test/specs/execute/module-import-4/output: -------------------------------------------------------------------------------- 1 | Line 10 = "generic haha" 2 | Line 12 = "haha for answer" -------------------------------------------------------------------------------- /test/specs/execute/multiline-string-1/entry.keli: -------------------------------------------------------------------------------- 1 | = 2 | """ 3 | hello 4 | world 5 | """ 6 | = 123 -------------------------------------------------------------------------------- /test/specs/execute/multiline-string-1/output: -------------------------------------------------------------------------------- 1 | Line 2 = " 2 | hello 3 | world 4 | " 5 | Line 6 = 123 -------------------------------------------------------------------------------- /test/specs/execute/tostring-1/output: -------------------------------------------------------------------------------- 1 | Line 13 = "It is a nil" 2 | Line 14 = "It is not empty dude" -------------------------------------------------------------------------------- /test/specs/suggest/suggest-object-alias-1/entry.keli: -------------------------------------------------------------------------------- 1 | People = $.name(String) age(Int) 2 | 3 | = P -------------------------------------------------------------------------------- /test/specs/execute/carryless-tag-1/entry.keli: -------------------------------------------------------------------------------- 1 | Boolean = choice.True 2 | x = Boolean.True 3 | =x 4 | -------------------------------------------------------------------------------- /test/specs/execute/record-as-type-annot-2/output: -------------------------------------------------------------------------------- 1 | Line 13 = $.accepted(List.Nil) notAccepted(List.Nil) -------------------------------------------------------------------------------- /test/specs/suggest/suggest-imported-symbol-1/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("./sample.keli") 2 | 3 | = 123. -------------------------------------------------------------------------------- /test/specs/execute/fix#33/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("a.keli") 2 | = module.import("b.keli") 3 | 4 | = 123 -------------------------------------------------------------------------------- /test/specs/execute/module-import-1/src/File1.keli: -------------------------------------------------------------------------------- 1 | (this Int).negate = ffi.javascript("(-k$this)").as(Int) -------------------------------------------------------------------------------- /test/specs/execute/module-import-2/src/File1.keli: -------------------------------------------------------------------------------- 1 | (this Int).negate = ffi.javascript("(-k$this)").as(Int) -------------------------------------------------------------------------------- /test/specs/execute/module-import-2/src/File2.keli: -------------------------------------------------------------------------------- 1 | (this Float).negate = ffi.javascript("(-k$this)").as(Float) -------------------------------------------------------------------------------- /test/specs/execute/@duplicated-func-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).equals(that Int) = 0 2 | (x Int).equals(y Int) = 0 -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-4/output: -------------------------------------------------------------------------------- 1 | Line 27 = Result.Fail("Not a zero") 2 | Line 28 = Result.Ok(0) -------------------------------------------------------------------------------- /test/specs/execute/record-value-setter-1/output: -------------------------------------------------------------------------------- 1 | Line 2 = $.name("cat") age(9) 2 | Line 4 = $.name("cat") age(10) -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-function-chaining-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).+(that Int) = 0 2 | 3 | = 123.+(123). -------------------------------------------------------------------------------- /test/specs/execute/@record-missing-prop-1/entry.keli: -------------------------------------------------------------------------------- 1 | people= $.name(String) age(Int) 2 | 3 | x = people.name("Hello") -------------------------------------------------------------------------------- /test/specs/execute/func-without-return-type-annot-1/entry.keli: -------------------------------------------------------------------------------- 1 | (x Int).plus(y Int) = 3 2 | 3 | =3 .plus(3) 4 | 5 | -------------------------------------------------------------------------------- /test/specs/execute/object-literal-1/entry.keli: -------------------------------------------------------------------------------- 1 | People = $.name(String) age(Int) 2 | 3 | = People.age(99) name("Haha") -------------------------------------------------------------------------------- /test/specs/execute/fix#41/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/fix#41/entry.keli:3:3 2 | 3 | Unknown indentifier: x -------------------------------------------------------------------------------- /test/specs/execute/mutual-recursion-1/output: -------------------------------------------------------------------------------- 1 | Line 21 = Boolean.True 2 | Line 22 = Boolean.True 3 | Line 23 = Boolean.False -------------------------------------------------------------------------------- /test/specs/execute/record-value-setter-1/entry.keli: -------------------------------------------------------------------------------- 1 | x= $.name("dog") age(9).name("cat") 2 | =x 3 | y=x.age(10) 4 | =y 5 | -------------------------------------------------------------------------------- /test/specs/execute/SKIP:generic-object-1/entry.keli: -------------------------------------------------------------------------------- 1 | Tuple._(A Type):(B Type) = $._(A):(B) 2 | 3 | = Tuple._("Hello"):(99) 4 | -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-3/output: -------------------------------------------------------------------------------- 1 | Line 16 = List.Cons($.current(6) next(List.Cons($.current(7) next(List.New)))) -------------------------------------------------------------------------------- /test/specs/execute/@incorrect-carry-type-1/entry.keli: -------------------------------------------------------------------------------- 1 | Color = choice 2 | .Red 3 | .Green(Int) 4 | 5 | x=Color.Green("123") -------------------------------------------------------------------------------- /test/specs/execute/@incorrect-lambda-param-type-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).take(f Function.in(Int) out(Int)) = 2 | f.apply("hello") -------------------------------------------------------------------------------- /test/specs/execute/@record-prop-type-mismatch-1/entry.keli: -------------------------------------------------------------------------------- 1 | people= $.name(String) age(Int) 2 | 3 | x = people.name(123) age(9) 4 | -------------------------------------------------------------------------------- /test/specs/execute/carryful-tag-1/entry.keli: -------------------------------------------------------------------------------- 1 | IntList= choice 2 | .Nothing 3 | .Cons(Int) 4 | 5 | = IntList.Cons(123) 6 | -------------------------------------------------------------------------------- /test/specs/execute/comment-1/entry.keli: -------------------------------------------------------------------------------- 1 | // this is a comment hello 2 | 3 | = 123 // another comment 4 | 5 | // another comment 6 | -------------------------------------------------------------------------------- /test/specs/execute/module-import-3/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("./A.keli") 2 | = module.import("./K/B.keli") 3 | = Answer.Yes.negate -------------------------------------------------------------------------------- /test/specs/execute/multiple-dispatch-1/entry.keli: -------------------------------------------------------------------------------- 1 | (x String).bom|String="yoyo" 2 | (x Int).bom|Int=999 3 | =1 .bom 4 | ="1".bom 5 | -------------------------------------------------------------------------------- /test/specs/suggest/suggest-tagged-union-1/entry.keli: -------------------------------------------------------------------------------- 1 | Shape = choice 2 | .Rectangle($.height(Float) width(Float)) 3 | 4 | = Shape. -------------------------------------------------------------------------------- /test/specs/execute/@duplicated-func-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@duplicated-func-1/entry.keli:2:9 2 | 3 | Duplicated function. -------------------------------------------------------------------------------- /test/specs/execute/ffi-javascript-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).+(that Int) | Int = ffi.javascript("k$this + k$that").as(Int) 2 | 3 | = 1 .+(2) 4 | -------------------------------------------------------------------------------- /test/specs/execute/func-chaining-2/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).+(that Int) | Int = (ffi.javascript("k$this + k$that")).as(Int) 2 | 3 | = 1.+(2).+(3) -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-function-chaining-2/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).doSomething(o $.plus(Int) minus(Int)) = 2 | 999 3 | 4 | = 123. -------------------------------------------------------------------------------- /test/specs/execute/identity-func-1/entry.keli: -------------------------------------------------------------------------------- 1 | {a Type} (x a).id | a = x 2 | 3 | (x Int).returnSame | Int = x 4 | 5 | z=99 6 | =z.id.returnSame 7 | -------------------------------------------------------------------------------- /test/specs/execute/module-import-1/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("./src/File2.keli") 2 | 3 | = 123.doubleNegate 4 | 5 | = pi 6 | 7 | = Shape.Square -------------------------------------------------------------------------------- /test/specs/execute/multiple-dispatch-2/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 2 | (this Int).zero(that Int) = 9 3 | 4 | = 1.zero 5 | = 1.zero(1) 6 | 7 | -------------------------------------------------------------------------------- /test/specs/execute/@duplicated-const-id-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@duplicated-const-id-1/entry.keli:2:1 2 | 3 | Duplicated identifier. -------------------------------------------------------------------------------- /test/specs/execute/@record-missing-prop-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@record-missing-prop-1/entry.keli:3:12 2 | 3 | Missing properties: age -------------------------------------------------------------------------------- /test/specs/execute/func-chaining-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).plus(that Int) | Int = (ffi.javascript("k$this + k$that")).as(Int) 2 | 3 | = 1 .plus(2).plus(3) -------------------------------------------------------------------------------- /test/skipped-spec/tagged-union/generic-3: -------------------------------------------------------------------------------- 1 | Tuple.fst(A Type) snd(B Type) = object.first (A) second (B) 2 | = Tuple.fst(1) snd("hello") 3 | 4 | ==== 5 | 6 | hi -------------------------------------------------------------------------------- /test/specs/suggest/suggest-case-expr-1/entry.keli: -------------------------------------------------------------------------------- 1 | Shape = choice 2 | .Rectangle($.height(Float) width(Float)) 3 | .NoShape 4 | 5 | = Shape.NoShape. -------------------------------------------------------------------------------- /test/specs/completion-item/@case-3: -------------------------------------------------------------------------------- 1 | Shape = tags. 2 | #(circle.radius(Int)) 3 | 4 | 5 | = Shape.circle.radius(4); 6 | ==== 7 | 8 | KErrorIncompleteFuncCall -------------------------------------------------------------------------------- /test/specs/execute/@incorrect-carry-type-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@incorrect-carry-type-1/entry.keli:5:15 2 | 3 | Expected `Int` but got `String` -------------------------------------------------------------------------------- /test/specs/execute/SKIP:@type-mismatch-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@type-mismatch-1/entry.keli:11:25 2 | 3 | Expected `List.of(T$0)` but got `A` -------------------------------------------------------------------------------- /test/specs/execute/record-as-type-annot-1/entry.keli: -------------------------------------------------------------------------------- 1 | Fruit = $.name(String) 2 | 3 | (this String).asFruit | Fruit = Fruit.name(this) 4 | 5 | ="pineapple".asFruit -------------------------------------------------------------------------------- /test/specs/execute/trifunc-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this String).replace(old String) with (new String)|String="hello" 2 | 3 | z="hi".replace("i") with("h") 4 | 5 | g=123 6 | =z -------------------------------------------------------------------------------- /test/specs/execute/@record-prop-type-mismatch-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@record-prop-type-mismatch-1/entry.keli:3:17 2 | 3 | Expected `String` but got `Int` -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-using-unknown-tag-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@tag-matcher-using-unknown-tag-1/entry.keli:10:9 2 | 3 | Unknown tag: `Lol` 4 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -- for exhasutive pattern checking 2 | module Main where 3 | 4 | import Cli 5 | 6 | main :: IO () 7 | main = cli 8 | -------------------------------------------------------------------------------- /test/specs/execute/@incorrect-lambda-param-type-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@incorrect-lambda-param-type-1/entry.keli:2:13 2 | 3 | Expected `Int` but got `String` -------------------------------------------------------------------------------- /test/specs/execute/record-lambda-setter-1/entry.keli: -------------------------------------------------------------------------------- 1 | (x Int).+(y Int) = ffi.javascript("k$x + k$y").as(Int) 2 | x= $.name("dog") age(9) 3 | y= x.age(a | a.+(10)) 4 | 5 | =y 6 | -------------------------------------------------------------------------------- /test/specs/execute/tagged-union-as-type-annot-1/entry.keli: -------------------------------------------------------------------------------- 1 | Shape = choice 2 | .Circle 3 | .Square 4 | 5 | (this Shape).hello = "yo" 6 | 7 | = Shape.Circle.hello 8 | 9 | -------------------------------------------------------------------------------- /test/specs/execute/@tag-invalid-carry-type-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@tag-invalid-carry-type-1/entry.keli:8:14 2 | 3 | Expected `List.of(Int)` but got `List.of(String)` -------------------------------------------------------------------------------- /test/specs/execute/insensitive-decl-order-1/entry.keli: -------------------------------------------------------------------------------- 1 | // should work even `hey` is defined after `hello` 2 | 3 | (this Int).hello = this.hey 4 | (this Int).hey = 123 5 | 6 | = 0.hello -------------------------------------------------------------------------------- /test/specs/execute/module-import-1/src/File2.keli: -------------------------------------------------------------------------------- 1 | = module.import("./File1.keli") 2 | 3 | (this Int).doubleNegate = this.negate.negate 4 | 5 | Shape = choice.Circle.Square 6 | pi = 3.14 -------------------------------------------------------------------------------- /test/specs/execute/@generic-tagged-union-type-mismatch-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@generic-tagged-union-type-mismatch-1/entry.keli:14:22 2 | 3 | Expected `Int` but got `String` -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-missing-branch-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@tag-matcher-missing-branch-1/entry.keli:7:2 2 | 3 | Missing cases: 4 | .No(n) 5 | .Maybe(m) -------------------------------------------------------------------------------- /test/specs/execute/else-tag-matcher-1/entry.keli: -------------------------------------------------------------------------------- 1 | Answer = choice 2 | .Yes 3 | .No 4 | 5 | a= Answer.No 6 | =a. 7 | if(.Yes): 8 | (2) 9 | 10 | else 11 | (1) -------------------------------------------------------------------------------- /test/specs/execute/module-import-2/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("./src/File2.keli") 2 | = module.import("./src/File1.keli") 3 | 4 | // testing multiple dispatch 5 | 6 | = 123.negate 7 | 8 | = 123.1.negate 9 | -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 2 | 3 | (this String).transformBy(f Function.in(Int) out(Int)) | Int = 4 | f.apply(this) 5 | 6 | = "hello".transformBy(.) 7 | -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-duplicate-tags-1/entry.keli: -------------------------------------------------------------------------------- 1 | Answer = choice 2 | .Yes 3 | .No 4 | 5 | a= Answer.Yes 6 | =a. 7 | if(.Yes): (2) 8 | if(.No): (1) 9 | if(.No): (1) 10 | -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-hetero-branch-1/entry.keli: -------------------------------------------------------------------------------- 1 | Answer = choice 2 | .Yes 3 | .No 4 | 5 | a= Answer.Yes 6 | =a. 7 | if(.Yes): 8 | (2) 9 | if(.No): 10 | ("hello") -------------------------------------------------------------------------------- /test/specs/execute/module-import-3/K/B.keli: -------------------------------------------------------------------------------- 1 | = module.import("../A.keli") 2 | 3 | (this Answer).negate = 4 | this. 5 | if(.Yes): 6 | (Answer.No) 7 | if(.No): 8 | (Answer.Yes) -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-2/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).zero = 0 2 | 3 | (this String).transformBy(f Function.in(Int) out(Int)) | Int = 4 | f.apply(this) 5 | 6 | = "hello".transformBy(.zero.) 7 | -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-missing-branch-1/entry.keli: -------------------------------------------------------------------------------- 1 | Answer = choice 2 | .Yes 3 | .No(String) 4 | .Maybe(String) 5 | 6 | a= Answer.Yes 7 | =a. 8 | if(.Yes): 9 | (2) 10 | -------------------------------------------------------------------------------- /test/specs/execute/@importing-unexisting-file-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@importing-unexisting-file-1/entry.keli:1:17 2 | 3 | Cannot import this file. Maybe it does not exist, or you don't have the right to access it. -------------------------------------------------------------------------------- /test/specs/execute/complete-tag-matcher-1/entry.keli: -------------------------------------------------------------------------------- 1 | Shape = choice 2 | .Circle($.radius(Float)) 3 | .Nothing 4 | 5 | a = Shape.Circle($.radius(2.0)) 6 | 7 | = a. 8 | if(.Circle(c)): (2) 9 | if(.Nothing): (1) 10 | -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-6/entry.keli: -------------------------------------------------------------------------------- 1 | Box.of(A Type) = choice 2 | .Ok($.value(A)) 3 | .Nothing 4 | 5 | = Box.Ok($.value(123)). 6 | if(.Ok(o)): 7 | (o.value) 8 | 9 | if(.Nothing): 10 | (4) -------------------------------------------------------------------------------- /test/specs/execute/lambda-shorthand-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).+(that Int) = ffi.javascript("k$this + k$that").as(Int) 2 | 3 | (this Int).transformBy(f Function.in(Int) out(Int)) | Int = 4 | f.apply(this) 5 | 6 | = 1.transformBy(.+(2).+(3).+(4)) 7 | -------------------------------------------------------------------------------- /test/specs/execute/@tag-invalid-carry-type-1/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .New 3 | .Cons($.current(A) next(List.of(A))) 4 | 5 | 6 | z = List.Cons($. 7 | current(1) 8 | next(List.Cons($.current("123") next(List.New)))) -------------------------------------------------------------------------------- /test/skipped-spec/tagged-union/else-tag-2: -------------------------------------------------------------------------------- 1 | Answer = tags. 2 | #(yes) 3 | #(no) 4 | 5 | a= Answer.yes 6 | =a. 7 | if(yes): 8 | (Answer.yes) 9 | 10 | else(other): 11 | (other) 12 | 13 | ==== 14 | 15 | KErrorDuplicatedTags -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-using-unknown-tag-1/entry.keli: -------------------------------------------------------------------------------- 1 | Answer = choice 2 | .Yes 3 | .No 4 | 5 | a= Answer.Yes 6 | =a. 7 | if(.Yes): 8 | (2) 9 | 10 | if(.Lol): 11 | (3) 12 | 13 | else 14 | (4) 15 | -------------------------------------------------------------------------------- /test/specs/execute/module-import-4/entry.keli: -------------------------------------------------------------------------------- 1 | = module.import("./A.keli") 2 | 3 | Answer.of(A Type) = choice 4 | .Yes 5 | .No 6 | 7 | {A Type} 8 | (this Answer.of(A)).haha = "haha for answer" 9 | 10 | = 123.haha 11 | 12 | = Answer.Yes.haha 13 | -------------------------------------------------------------------------------- /test/specs/suggest/suggest-tagged-union-1/output: -------------------------------------------------------------------------------- 1 | [CompletionItem { 2 | kind = 13, 3 | label = "Rectangle", 4 | detail = "", 5 | insertText = "Rectangle($.height(${1:Float}) width(${2:Float}))", 6 | insertTextFormat = 2, 7 | documentation = ""}] -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-duplicate-tags-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@tag-matcher-duplicate-tags-1/entry.keli:8:9 2 | 3 | Duplicated tags. 4 | 5 | 6 | ERROR at ./test/specs/execute/@tag-matcher-duplicate-tags-1/entry.keli:9:9 7 | 8 | Duplicated tags. -------------------------------------------------------------------------------- /test/specs/execute/SKIP:generic-tagged-union-10/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .Nil 3 | .Cons($.value(A) next(List.of(A))) 4 | 5 | {A Type} 6 | (this A).shouldBe(that A) = "hello" 7 | 8 | emptyList = List.Nil 9 | 10 | = emptyList.shouldBe(emptyList) -------------------------------------------------------------------------------- /test/specs/suggest/suggest-object-alias-1/output: -------------------------------------------------------------------------------- 1 | [CompletionItem { 2 | kind = 7, 3 | label = "People", 4 | detail = "Object constructor", 5 | insertText = "People.name(${1:String}) age(${2:Int})", 6 | insertTextFormat = 2, 7 | documentation = ""}] -------------------------------------------------------------------------------- /test/specs/execute/@tag-matcher-hetero-branch-1/output: -------------------------------------------------------------------------------- 1 | ERROR at ./test/specs/execute/@tag-matcher-hetero-branch-1/entry.keli:10:10 2 | 3 | The expected type of each branch is `Int` (based on the type of first branch at Line 8) 4 | But this branch has type of `String` 5 | -------------------------------------------------------------------------------- /test/specs/execute/ffi-javascript-2/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .Nil 3 | .Cons($.current(A) next(List.of(A))) 4 | 5 | {A Type} 6 | (this Array.of(A)).toList 7 | | List.of(A) 8 | = ffi.javascript("123").as(List.of(A)) 9 | 10 | = [1,2].toList -------------------------------------------------------------------------------- /test/specs/suggest/suggest-imported-symbol-1/output: -------------------------------------------------------------------------------- 1 | [ 2 | CompletionItem { 3 | kind = 3, 4 | label = "zero", 5 | detail = "(this Int).zero | Int", 6 | insertText = "zero", 7 | insertTextFormat = 2, 8 | documentation = ""} 9 | ] -------------------------------------------------------------------------------- /test/specs/completion-item/@lambda-shorthand: -------------------------------------------------------------------------------- 1 | (this Int).+(that Int) = ffi.javascript("$this + $that").as(Int) 2 | 3 | (this Int).transformBy(f Function.in(Int) out(Int)) | Int = 4 | f.apply(this) 5 | 6 | = 1.transformBy(;) 7 | 8 | ==== 9 | 10 | KErrorIncompleteFuncCall -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-1/output: -------------------------------------------------------------------------------- 1 | [ 2 | CompletionItem { 3 | kind = 3, 4 | label = "zero", 5 | detail = "(this Int).zero | Int", 6 | insertText = "zero", 7 | insertTextFormat = 2, 8 | documentation = ""} 9 | ] -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-lambda-shorthand-2/output: -------------------------------------------------------------------------------- 1 | [ 2 | CompletionItem { 3 | kind = 3, 4 | label = "zero", 5 | detail = "(this Int).zero | Int", 6 | insertText = "zero", 7 | insertTextFormat = 2, 8 | documentation = ""} 9 | ] -------------------------------------------------------------------------------- /test/specs/completion-item/@case-4: -------------------------------------------------------------------------------- 1 | Dict.key(K Type) value(V Type) = tags. 2 | #(nodes. 3 | key(K) 4 | value(V) 5 | left(Dict.key(K) value(V)) 6 | right(Dict.key(K) value(V))) 7 | #(leaf) 8 | 9 | 10 | = 123; 11 | ==== 12 | 13 | KErrorIncompleteFuncCall -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-function-chaining-1/output: -------------------------------------------------------------------------------- 1 | [ 2 | CompletionItem { 3 | kind = 3, 4 | label = "+()", 5 | detail = "(this Int).+(that Int) | Int", 6 | insertText = "+(${1:that})", 7 | insertTextFormat = 2, 8 | documentation = ""} 9 | ] -------------------------------------------------------------------------------- /test/specs/suggest/suggest-for-function-chaining-2/output: -------------------------------------------------------------------------------- 1 | [CompletionItem { 2 | kind = 3, 3 | label = "doSomething()", 4 | detail = "(this Int).doSomething(o $.plus(Int) minus(Int)) | Int", 5 | insertText = "doSomething(${1:o})", 6 | insertTextFormat = 2, 7 | documentation = ""}] 8 | -------------------------------------------------------------------------------- /test/specs/execute/SKIP:@type-mismatch-1/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .Nil 3 | .Cons($.value(A) next(List.of(A))) 4 | 5 | 6 | {A Type} 7 | (this List.of(A)).append(element A) | List.of(A) = List.Nil 8 | 9 | {A Type} 10 | (this $.x(List.of(A))).yo = 11 | this.x(.append(0)) 12 | -------------------------------------------------------------------------------- /test/specs/suggest/suggest-case-expr-1/output: -------------------------------------------------------------------------------- 1 | [CompletionItem { 2 | kind = 12, 3 | label = "if(...)", 4 | detail = "tag matcher", 5 | insertText = "\n\tif(.Rectangle(r)) then\n\t\t(${1:undefined})\n\n\tif(.NoShape) then\n\t\t(${2:undefined})", 6 | insertTextFormat = 2, 7 | documentation = ""}] -------------------------------------------------------------------------------- /test/specs/completion-item/@case-2: -------------------------------------------------------------------------------- 1 | (x Int).sqrt = ffi.javascript("Math.sqrt($x)").as(Int) 2 | 3 | (x Int).+(y Int) = ffi.javascript("$x + $y").as(Int) 4 | 5 | (x Int).withBase(base Int) log(value Int) = 123 6 | 7 | z = 123 8 | 9 | = z.sqrt.+(2).withBase(10) log(5); 10 | 11 | ==== 12 | 13 | KErrorIncompleteFuncCall -------------------------------------------------------------------------------- /test/specs/execute/access-tag-carry-2/entry.keli: -------------------------------------------------------------------------------- 1 | Human = choice 2 | .Boy 3 | .Baby($.cuteness(Int)) 4 | .Worker($.salary(Int)) 5 | 6 | julia=Human.Baby($.cuteness(99)) 7 | 8 | =julia. 9 | if(.Boy): 10 | (0) 11 | 12 | if(.Baby(b)): 13 | (b.cuteness) 14 | 15 | if(.Worker(w)): 16 | (w.salary) 17 | 18 | -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-9/entry.keli: -------------------------------------------------------------------------------- 1 | State.of(A Type) = choice.New($.state(A) runState(Function.in(A) out(A))) 2 | 3 | MyState = $.count(Int) 4 | 5 | (this MyState).increment = this 6 | 7 | x = State.New($.state(MyState.count(0)) runState(.increment)) 8 | 9 | = x. 10 | if(.New(n)): 11 | (n.runState.apply(MyState.count(1))) -------------------------------------------------------------------------------- /test/specs/execute/record-as-type-annot-2/entry.keli: -------------------------------------------------------------------------------- 1 | Boolean = choice 2 | .True 3 | .False 4 | 5 | List.of(A Type) = choice 6 | .Nil 7 | .Cons($.current(A) next(List.of(A))) 8 | 9 | {A Type} 10 | (this Int).hey | $.accepted(List.of(A)) notAccepted(List.of(A)) 11 | = $.accepted(List.Nil) notAccepted(List.Nil) 12 | 13 | = 5.hey -------------------------------------------------------------------------------- /test/skipped-spec/interface/case-1: -------------------------------------------------------------------------------- 1 | Equatable = interface 2 | 3 | Boolean = (tag.true).or(tag.false) 4 | 5 | (this Boolean).not = this.true? (Boolean.false) false? (Boolean.true) 6 | 7 | {A Equatable} 8 | (this A).equals(that A) | Boolean = tobedefined 9 | 10 | {A Equatable} 11 | (this A).notEquals(that A) = this.equals(that).not 12 | 13 | ==== 14 | 15 | hi -------------------------------------------------------------------------------- /Glossary.md: -------------------------------------------------------------------------------- 1 | # Glossary 2 | 3 | |Abbreviation|Meaning| 4 | |--|--| 5 | |ast|abstract syntax tree| 6 | |const|constant| 7 | |decl|declaration| 8 | |expr|expression| 9 | |func|function| 10 | |id|identifier| 11 | |int|integer| 12 | |ir|intermediate representation| 13 | |param|parameter| 14 | |env|environment a.k.a symbol table| 15 | |kvs|key-value pairs| 16 | |Annot|annotation -------------------------------------------------------------------------------- /test/specs/execute/tostring-1/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .Nil 3 | .Cons($.current(A) next(List.of(A))) 4 | 5 | {A Type} 6 | (this List.of(A)).toString = 7 | this. 8 | if(.Nil): 9 | ("It is a nil") 10 | if(.Cons): 11 | ("It is not empty dude") 12 | 13 | = List.Nil 14 | = List.Cons($.current(1) next(List.Nil)) -------------------------------------------------------------------------------- /test/specs/execute/@circular-import-1/output: -------------------------------------------------------------------------------- 1 | ERROR at /home/hou32hou/Repos/keli/compiler/test/specs/execute/@circular-import-1/a.keli:1:17 2 | 3 | Circular imports are detected around the following files: 4 | 5 | /home/hou32hou/Repos/keli/compiler/test/specs/execute/@circular-import-1/a.keli 6 | /home/hou32hou/Repos/keli/compiler/test/specs/execute/@circular-import-1/entry.keli 7 | -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-7/entry.keli: -------------------------------------------------------------------------------- 1 | Box.of(A Type) = choice 2 | .Ok($.value(A)) 3 | .Nothing 4 | 5 | {A Type} {B Type} 6 | (this Box.of(A)).then(f Function.in(A) out(B)) 7 | | Box.of(B) 8 | = this. 9 | if(.Ok(o)): 10 | (Box.Ok($.value(f.apply(o.value)))) 11 | 12 | if(.Nothing): 13 | (Box.Nothing) 14 | 15 | = Box.Ok($.value(5)).then(x | x) -------------------------------------------------------------------------------- /test/specs/execute/docstring-1/entry.keli: -------------------------------------------------------------------------------- 1 | List = choice 2 | .Nil 3 | .Cons 4 | 5 | "Slices list from startIndex until including endIndex" 6 | (this List) "The list to be sliced." 7 | . 8 | from(startIndex Int) "Zero-based index." 9 | to(endIndex Int) "Zero-based index. Inclusive." 10 | | List "Returns a new list" 11 | = List.Nil 12 | 13 | = List.Nil.from(0) to(10) 14 | -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-8/entry.keli: -------------------------------------------------------------------------------- 1 | Box.of(A Type) = choice 2 | .Ok($.value(A)) 3 | .Nothing 4 | 5 | List.of(A Type) = choice 6 | .Nil 7 | .Cons($.value(A) next(List.of(A))) 8 | 9 | {A Type} 10 | (this List.of(A)).at(index Int) 11 | | Box.of(A) 12 | = Box.Nothing 13 | 14 | = List.Cons($.value(1) next(List.Nil)).at(2). 15 | if(.Ok(o)): 16 | (o.value) 17 | 18 | if(.Nothing): 19 | (0) -------------------------------------------------------------------------------- /test/specs/execute/access-tag-carry-1/entry.keli: -------------------------------------------------------------------------------- 1 | (this Int).+(that Int) | Int = ffi.javascript("k$this + k$that").as(Int) 2 | 3 | Color = choice 4 | .Red 5 | .Green(Int) 6 | 7 | x = Color.Green(2) 8 | y = Color.Green(5) 9 | 10 | =x. 11 | if(.Red): 12 | (10) 13 | 14 | if(.Green(v1)): 15 | (y. 16 | if(.Red): 17 | (99) 18 | if(.Green(v2)): 19 | (v1.+(v2))) 20 | 21 | -------------------------------------------------------------------------------- /test/specs/execute/@generic-tagged-union-type-mismatch-1/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .New 3 | .Cons($.current(A) next(List.of(A))) 4 | 5 | {A Type} 6 | (this List.of(A)).add(element A) | List.of(A) 7 | = this. 8 | if(.New): 9 | (List.Cons($.current(element) next(List.New))) 10 | 11 | if(.Cons(c)): 12 | (List.Cons($.current(c.current) next(c.next.add(element)))) 13 | 14 | =List.New.add(1).add("4") 15 | -------------------------------------------------------------------------------- /test/specs/execute/@circular-import-2/output: -------------------------------------------------------------------------------- 1 | ERROR at /home/hou32hou/Repos/keli/compiler/test/specs/execute/@circular-import-2/b.keli:1:17 2 | 3 | Circular imports are detected around the following files: 4 | 5 | /home/hou32hou/Repos/keli/compiler/test/specs/execute/@circular-import-2/b.keli 6 | /home/hou32hou/Repos/keli/compiler/test/specs/execute/@circular-import-2/a.keli 7 | /home/hou32hou/Repos/keli/compiler/test/specs/execute/@circular-import-2/entry.keli 8 | -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-1/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .New 3 | .Cons($.current(A) next(List.of(A))) 4 | 5 | (this Int).+(that Int) = ffi.javascript("k$this + k$that").as(Int) 6 | 7 | {A Type} 8 | (this List.of(A)).length | Int = 9 | this. 10 | if(.New): 11 | (0) 12 | if(.Cons(c)): 13 | (1.+(c.next.length)) 14 | 15 | z = List.Cons($.current(1) next(List.Cons($.current(3) next(List.New)))) 16 | 17 | = z.length -------------------------------------------------------------------------------- /test/skipped-spec/tagged-union/generic-constrained-1: -------------------------------------------------------------------------------- 1 | comparable = constraint 2 | 3 | {a:(Type.thatis comparable)} 4 | this:a .moreThan that:a | bool = tobedefined 5 | 6 | {a:(Type.thatis comparable)} 7 | this:a .equals that:a | bool = tobedefined 8 | 9 | {a:(Type.thatis comparable)} 10 | this:a .lessThan that:a | bool = this.moreThan(that).not.and(this.equals(that).not) 11 | 12 | 13 | a:(Type.thatis comparable).btree | Type 14 | = (tag.# leaf) 15 | .or(tag.# node carry (object.current a left (a.btree) right (a.btree))) 16 | 17 | ==== -------------------------------------------------------------------------------- /test/specs/execute/recursive-func-1/entry.keli: -------------------------------------------------------------------------------- 1 | Boolean = choice 2 | .True 3 | .False 4 | 5 | (x Int).minus (y Int) | Int = ffi.javascript("k$x - k$y").as(Int) 6 | (x Int).times (y Int) | Int = ffi.javascript("k$x * k$y").as(Int) 7 | (x Int).equals (y Int) | Boolean = ffi.javascript("k$x === k$y ? k$Boolean.True : k$Boolean.False").as(Boolean) 8 | 9 | (x Int).factorial | Int = 10 | x.equals(0). 11 | if(.True): 12 | (1) 13 | if(.False): 14 | (x.times((x.minus(1)).factorial)) 15 | 16 | = 3.factorial 17 | = 6.factorial -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-3/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .New 3 | .Cons($.current(A) next(List.of(A))) 4 | 5 | (this Int).+(that Int) = ffi.javascript("k$this + k$that").as(Int) 6 | 7 | {A Type} {B Type} 8 | (this List.of(A)).map(f Function.in(A) out(B)) | List.of(B) = 9 | this. 10 | if(.New): 11 | (List.New) 12 | if(.Cons(c)): 13 | (List.Cons($.current(f.apply(c.current)) next(c.next.map(f)))) 14 | 15 | 16 | = List.Cons($.current(1) next(List.Cons($.current(2) next(List.New)))) 17 | .map(.+(2)) 18 | .map(.+(3)) -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-5/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .Nil 3 | .Cons($.value(A) next(List.of(A))) 4 | 5 | Box.of(A Type) = choice 6 | .With(A) 7 | .Empty 8 | 9 | "Get the last element of a list" 10 | {A Type} 11 | (this List.of(A)).last 12 | | Box.of(A) 13 | = this. 14 | if(.Nil): 15 | (Box.Empty) 16 | if(.Cons(c)): 17 | (c.next. 18 | if(.Nil): 19 | (Box.With(c.value)) 20 | else 21 | (Box.Empty)) 22 | 23 | = List.Cons($.value(1) next(List.Nil)).last -------------------------------------------------------------------------------- /test/specs/execute/mutual-recursion-1/entry.keli: -------------------------------------------------------------------------------- 1 | Boolean = choice 2 | .True 3 | .False 4 | 5 | (x Int).==(y Int) = ffi.javascript("k$x === k$y ? k$Boolean.True : k$Boolean.False").as(Boolean) 6 | (x Int).-(y Int) = ffi.javascript("k$x - k$y").as(Int) 7 | (this Int).isEven | Boolean = 8 | this.==(0). 9 | if(.True): 10 | (Boolean.True) 11 | if(.False): 12 | (this.-(1).isOdd) 13 | 14 | (this Int).isOdd | Boolean = 15 | this.==(0). 16 | if(.True): 17 | (Boolean.False) 18 | if(.False): 19 | (this.-(1).isEven) 20 | 21 | = 20.isEven 22 | = 9.isOdd 23 | = 8.isOdd 24 | -------------------------------------------------------------------------------- /src/Module.hs: -------------------------------------------------------------------------------- 1 | module Module where 2 | 3 | import qualified Ast.Verified as V 4 | import Env 5 | 6 | type ModuleName = String 7 | 8 | data Module 9 | = Module { 10 | moduleName :: ModuleName, 11 | moduleFilepath :: String, 12 | moduleImported :: [Module], 13 | moduleEnv :: Env, 14 | moduleDecls :: [V.Decl] 15 | } deriving (Show) 16 | 17 | 18 | data Context 19 | = Context { 20 | contextNextInt :: Int, 21 | contextEnv :: Env, 22 | contextImportedEnvs :: [(ModuleName,Env)] 23 | } deriving (Show) 24 | 25 | emptyContext :: Context 26 | emptyContext = Context 0 emptyEnv [] -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-2/entry.keli: -------------------------------------------------------------------------------- 1 | List.of(A Type) = choice 2 | .New 3 | .Cons($.current(A) next(List.of(A))) 4 | 5 | (this Int).+(that Int) = ffi.javascript("k$this + k$that").as(Int) 6 | 7 | {A Type} 8 | (this List.of(A)).length | Int = 9 | this. 10 | if(.New): 11 | (0) 12 | if(.Cons(c)): 13 | (1.+(c.next.length)) 14 | 15 | {A Type} 16 | (xs List.of(A)).add(x A) | List.of(A) = 17 | xs. 18 | if(.New): 19 | (List.Cons($.current(x) next(List.New))) 20 | if(.Cons(c)): 21 | (List.Cons(c.next(.add(x)))) 22 | 23 | =List.New.add(1).add(2).add(3).add(4).length -------------------------------------------------------------------------------- /test/specs/execute/generic-tagged-union-4/entry.keli: -------------------------------------------------------------------------------- 1 | Result.ok(A Type) fail(B Type) = choice 2 | .Ok(A) 3 | .Fail(B) 4 | 5 | {A Type} {B Type} {C Type} 6 | (this Result.ok(A) fail(B)).then(f Function.in(A) out(C)) 7 | | Result.ok(C) fail(B) 8 | = this. 9 | if(.Ok(o)): 10 | (Result.Ok(f.apply(o))) 11 | if(.Fail(e)): 12 | (Result.Fail(e)) 13 | 14 | Boolean = choice 15 | .True 16 | .False 17 | 18 | (x Int).==(y Int) = ffi.javascript("k$x === k$y ? k$Boolean.True : k$Boolean.False").as(Boolean) 19 | 20 | (this Int).isZero | Result.ok(Int) fail(String) = 21 | this.==(0). 22 | if(.True): 23 | (Result.Ok(0)) 24 | if(.False): 25 | (Result.Fail("Not a zero")) 26 | 27 | = 123.isZero 28 | = 0.isZero 29 | -------------------------------------------------------------------------------- /test/specs/execute/recursive-tagged-union-1/entry.keli: -------------------------------------------------------------------------------- 1 | (x Int).plus(y Int) | Int = ffi.javascript("k$x + k$y").as(Int) 2 | 3 | IntList = choice 4 | .Nil 5 | .Cons($.current(Int) next(IntList)) 6 | 7 | myList=IntList.Cons($. 8 | current (1) 9 | next (IntList.Cons($. 10 | current (2) 11 | next (IntList.Cons($. 12 | current (3) 13 | next (IntList.Nil)))))) 14 | 15 | 16 | (this IntList).length | Int = 17 | this. 18 | if(.Nil): 19 | (0) 20 | 21 | if(.Cons(c)): 22 | (1.plus(c.next.length)) 23 | 24 | (this IntList).sum | Int = 25 | this. 26 | if(.Nil): 27 | (0) 28 | 29 | if(.Cons(c)): 30 | (c.current.plus(c.next.sum)) 31 | 32 | =myList.length 33 | =myList.sum -------------------------------------------------------------------------------- /src/Sample.hs: -------------------------------------------------------------------------------- 1 | module Sample where 2 | 3 | import Text.ParserCombinators.Parsec hiding (token) 4 | import Text.ParserCombinators.Parsec.Expr 5 | import Text.ParserCombinators.Parsec.Error 6 | import Lexer 7 | 8 | expr = buildExpressionParser table term 9 | "expression" 10 | 11 | term = parens expr 12 | <|> natural 13 | "simple expression" 14 | 15 | table = [ [prefix "-" negate, prefix "+" id ] 16 | , [postfix "+" (+1)] 17 | , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ] 18 | , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ] 19 | ] 20 | 21 | binary name fun assoc = Infix (do{ reservedOp name; return fun }) assoc 22 | prefix name fun = Prefix (do{ reservedOp name; return fun }) 23 | postfix name fun = Postfix (do{ reservedOp name; return fun }) 24 | 25 | parseSample str = parse expr "test" str -------------------------------------------------------------------------------- /src/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Interpreter where 2 | 3 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 4 | import Data.List 5 | import System.Process 6 | 7 | import Compiler 8 | import Transpiler 9 | import Diagnostics 10 | import PreludeJSCode 11 | import qualified Data.HashMap.Strict as HashMap 12 | 13 | keliInterpret :: Bool -> String -> IO (Either String String) -- Left means Error, Right means Output 14 | keliInterpret showLineNumber sourceFileName = do 15 | contents <- readFile sourceFileName 16 | (errors, currentModule, _, _) <- keliCompile sourceFileName contents (HashMap.empty) [] 17 | if length errors > 0 then 18 | let diagnostics = concatMap toDiagnostic errors in 19 | return (Left (intercalate "\n\n\n" (map renderDiagnostic diagnostics))) 20 | else do 21 | let code = transpileModule True showLineNumber currentModule 22 | output <- keliExecute (preludeJSCode ++ code) 23 | return (Right output) 24 | 25 | renderDiagnostic :: Diagnostic -> String 26 | renderDiagnostic d = 27 | let position = start (range d) in 28 | "ERROR at " 29 | ++ filename d 30 | ++ ":" ++ show (line position + 1) 31 | ++ ":" ++ show (character position + 1) 32 | ++ "\n\n" ++ tabify (message d) 33 | 34 | tabify :: String -> String 35 | tabify str = intercalate "\n" (map (\s -> " " ++ s) (lines str)) 36 | 37 | keliExecute :: String -> IO String 38 | keliExecute code = readProcess "node" ["-e", code] [] -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: keli-compiler 2 | version: 0.1.0.0 3 | github: "githubuser/keli-compiler" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2018 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - text 25 | - parsec 26 | - unordered-containers 27 | - ordered-containers 28 | - containers 29 | - hspec 30 | - pretty-simple 31 | - process 32 | - directory 33 | - strings 34 | - MissingH 35 | - optparse-applicative 36 | - aeson 37 | - bytestring 38 | - filepath 39 | - aeson-pretty 40 | - raw-strings-qq 41 | 42 | 43 | library: 44 | source-dirs: src 45 | 46 | executables: 47 | keli: 48 | main: Main.hs 49 | source-dirs: app 50 | ghc-options: 51 | - -threaded 52 | - -rtsopts 53 | - -with-rtsopts=-N 54 | - -Wall 55 | dependencies: 56 | - keli-compiler 57 | 58 | tests: 59 | keli-compiler-test: 60 | main: Spec.hs 61 | source-dirs: test 62 | ghc-options: 63 | - -threaded 64 | - -rtsopts 65 | - -with-rtsopts=-N 66 | dependencies: 67 | - keli-compiler 68 | - hspec 69 | -------------------------------------------------------------------------------- /test/README.md: -------------------------------------------------------------------------------- 1 | # How to add new test? 2 | 3 | New test can be added by adding new directories and files in the `test/specs` folder. 4 | 5 | Within `test/specs`, there are two directories, namely `compile` and `suggest`. 6 | 7 | - `execute` is for testing executing a Keli source file 8 | - `suggest` is for testing Intellisense (code completion) 9 | 10 | ## For `execute` 11 | Each directory name in `execute` represent the test description, while each file within each directory is a test case. 12 | 13 | Within each test description directory, the following 2 files must be present: 14 | 15 | - `entry.keli` , which is the source file where the test runner will execute as the entry point 16 | - `output`, which is the STDOUT after performing the action on the entry file 17 | 18 | ### Naming convention 19 | Use the `kebab-case` convention. 20 | For testing invalid case, prefix the description with `@`. 21 | 22 | ## For `suggest` 23 | Similarly, each directory name in `suggest` also represent the test description. 24 | 25 | Within each test description directory, the following 2 files must be present: 26 | 27 | - `entry.keli` , which is the source file where the test runner will search for suggestion 28 | 29 | - `output`, which is a Haskell data literal of type `[CompletionItem]`, after performing the action on the entry file 30 | 31 | - `where`, which specify the lineNumber and columnNumber, first line is lineNumber, second line is columnNumber, columnNumber is actually the position of the dot operator 32 | - note that lineNumber and columnNumber are zero-based index 33 | - so, lineNumber 2 actually means line 3, columnNumber 0 means column 1 in text editor 34 | 35 | 36 | # How to run specific test case? 37 | 38 | Prefix the filename with `ONLY:`. Note that you can do this to more than one file at the same time. 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Keli Compiler 2 | 3 | ## Namings 4 | Refer Glossary.md 5 | 6 | ## How to run the binary? 7 | 8 | ``` 9 | stack build 10 | stack exec -- keli [keli-args] 11 | ``` 12 | 13 | ## How to install the binary into user path? 14 | ``` 15 | stack build --copy-bins 16 | ``` 17 | 18 | ## How to setup this project? 19 | 20 | ``` 21 | stack build 22 | ``` 23 | 24 | ## How to run test? 25 | 26 | To treat warning as errors, use `-Werror`: 27 | ``` 28 | stack test --ghc-options="-Wall -Werror" --file-watch 29 | ``` 30 | 31 | 32 | ## How to run ghci? 33 | 34 | The following command is to prevent stack overflow due to unknown infinite loop. 35 | 36 | Refer https://stackoverflow.com/questions/35342591/haskell-limit-ghci-memory 37 | 38 | ```sh 39 | stack ghci --package pretty-simple --ghci-options="+RTS -M256m -K256m -RTS -interactive-print=Text.Pretty.Simple.pPrint -Wall" 40 | ``` 41 | 42 | ## Versioning 43 | 44 | We will be using SemVer + CalVer, as the following format: 45 | 46 | ```md 47 | MAJOR.YY.MM.DD 48 | ``` 49 | 50 | ## Some extra documentation about Data.Map.Ordered 51 | 52 | ```hs 53 | -- assocs means valuesOf 54 | -- For example, 55 | -- assocs x 56 | -- means, get the list of key-value pair from x (which is arranged according to insertion order) 57 | -- |> means insert 58 | -- For example, 59 | -- x |> (key, value) 60 | -- means, insert (key,value) into x 61 | -- For more please refer http://hackage.haskell.org/package/ordered-containers-0.1.1/docs/Data-Map-Ordered.html 62 | ``` 63 | 64 | ## References 65 | 66 | ### Algorithm W implemented in Haskell 67 | http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.65.7733&rep=rep1&type=pdf 68 | 69 | ## Type inferfence for beginners (by Dhruv Rajvanshi) 70 | https://medium.com/@dhruvrajvanshi/type-inference-for-beginners-part-1-3e0a5be98a4b 71 | https://medium.com/@dhruvrajvanshi/type-inference-for-beginners-part-2-f39c33ca9513 -------------------------------------------------------------------------------- /src/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer where 2 | 3 | import Text.ParserCombinators.Parsec 4 | import Text.ParserCombinators.Parsec.Language 5 | import qualified Text.ParserCombinators.Parsec.Token as Token 6 | 7 | languageDef :: LanguageDef st 8 | languageDef = 9 | emptyDef { Token.commentStart = "/*" 10 | , Token.commentEnd = "*/" 11 | , Token.commentLine = "//" 12 | , Token.opStart = oneOf "~!@#$%^&*-=+:?/<>\\" 13 | , Token.opLetter = oneOf "~!@#$%^&*-=+:?/<>\\" 14 | , Token.identStart = letter <|> char '_' <|> char '#' <|> char '$' 15 | , Token.identLetter = alphaNum <|> char '_' <|> char '?' <|> char ':' 16 | , Token.reservedOpNames = [ 17 | "=" 18 | , "|" 19 | ] 20 | } 21 | 22 | lexer = Token.makeTokenParser languageDef 23 | 24 | -- Refer http://hackage.haskell.org/package/parsec-3.1.13.0/docs/Text-ParserCombinators-Parsec-Token.html 25 | identifier = Token.identifier lexer -- parses an identifier 26 | reserved = Token.reserved lexer -- parses a reserved name 27 | reservedOp = Token.reservedOp lexer -- parses an operator 28 | parens = Token.parens lexer -- parses surrounding parenthesis: 29 | -- parens p 30 | -- takes care of the parenthesis and 31 | -- uses p to parse what's inside them 32 | integer = Token.integer lexer -- parses an integer 33 | float = Token.float lexer 34 | natural = Token.natural lexer 35 | semi = Token.semi lexer -- parses a semicolon 36 | whiteSpace = Token.whiteSpace lexer -- parses whitespace 37 | symbol = Token.symbol lexer -- custom symbol 38 | dot = Token.dot lexer 39 | operator = Token.operator lexer 40 | singlelineString = Token.stringLiteral lexer 41 | 42 | -------------------------------------------------------------------------------- /src/Ast/Raw.hs: -------------------------------------------------------------------------------- 1 | module Ast.Raw where 2 | 3 | import Prelude hiding (id) 4 | import Text.Parsec.Pos 5 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 6 | 7 | type StringToken = (SourcePos, String) 8 | type NumberToken = (SourcePos, (Either Integer Double)) 9 | 10 | data Decl 11 | = ConstDecl Const 12 | | FuncDecl Func 13 | | IdlessDecl 14 | SourcePos -- the position of the `=` symbol 15 | Expr 16 | | GenericTypeDecl 17 | StringToken -- name 18 | [StringToken] -- trailing ids 19 | [FuncDeclParam] -- type params 20 | Expr -- type body 21 | deriving (Show, Eq) 22 | 23 | data Const = Const { 24 | constDeclId :: StringToken, 25 | constDeclValue :: Expr 26 | } deriving (Show, Eq) 27 | 28 | type FuncDeclParam = (StringToken, Expr) 29 | type FuncDeclConstraint = (StringToken, Expr) 30 | 31 | data Func = Func { 32 | funcDeclDocString :: Maybe String, 33 | funcDeclGenericParams :: [FuncDeclConstraint], 34 | funcDeclParams :: [FuncDeclParam], 35 | funcDeclIds :: [StringToken], 36 | funcDeclReturnType :: Maybe Expr, 37 | funcDeclBody :: Expr 38 | } deriving (Show, Eq) 39 | 40 | 41 | data Expr 42 | = NumberExpr NumberToken 43 | | StringExpr StringToken 44 | | Id StringToken 45 | | FuncCall { 46 | funcCallParams :: [Expr], 47 | funcCallIds :: [StringToken] 48 | } 49 | | Lambda { 50 | lambdaParam :: StringToken, 51 | lambdaBody :: Expr, 52 | isShorthand :: Bool 53 | } 54 | | IncompleteFuncCall -- for implementing Intellisense 55 | Expr 56 | SourcePos -- position of the dot operator 57 | 58 | | Array 59 | [Expr] -- elements 60 | SourcePos -- position of the `[` symbol 61 | 62 | | TaggedUnion 63 | StringToken -- the `choice` keyword, for error reporting purpose 64 | [([StringToken], [Expr])] -- func call tails 65 | 66 | deriving (Show,Eq) 67 | 68 | -------------------------------------------------------------------------------- /src/Env.hs: -------------------------------------------------------------------------------- 1 | module Env where 2 | 3 | import Text.Parsec.Pos 4 | import Prelude hiding (id) 5 | import Data.Map.Ordered 6 | 7 | import qualified Ast.Verified as V 8 | 9 | data KeliSymbol 10 | = KeliSymFunc 11 | [V.FuncSignature] 12 | 13 | | KeliSymGlobalConst 14 | V.StringToken -- this field is used for enhancing DuplicatedIdentifiers error message 15 | V.Type 16 | 17 | | KeliSymLocalConst 18 | V.StringToken -- this field is used for enhancing DuplicatedIdentifiers error message 19 | V.Type 20 | 21 | | KeliSymType 22 | V.Type 23 | 24 | | KeliSymTaggedUnion 25 | V.TaggedUnion 26 | deriving(Show) 27 | 28 | 29 | type Env = OMap String KeliSymbol 30 | 31 | emptyEnv :: Env 32 | emptyEnv = empty 33 | 34 | builtinPos :: String -> V.StringToken 35 | builtinPos str = (newPos "" 0 0, str) 36 | 37 | initialEnv :: Env 38 | initialEnv = 39 | empty 40 | |> ("Int" , KeliSymType V.TypeInt) 41 | |> ("Float" , KeliSymType V.TypeFloat) 42 | |> ("String", KeliSymType V.TypeString) 43 | |> ("Type" , KeliSymType V.TypeType) 44 | |> ("Function", 45 | KeliSymTaggedUnion 46 | (newFunctionType 47 | (V.BoundedTypeVar (builtinPos "A") Nothing) 48 | (V.BoundedTypeVar (builtinPos "B") Nothing))) 49 | |> ("Array", 50 | KeliSymTaggedUnion 51 | (newArrayType 52 | (V.BoundedTypeVar (builtinPos "A") Nothing))) 53 | 54 | newFunctionType :: V.Type -> V.Type -> V.TaggedUnion 55 | newFunctionType inputType outputType = 56 | V.TaggedUnion 57 | (builtinPos "Function") 58 | [builtinPos "in", builtinPos "out"] 59 | [] 60 | [inputType, outputType] 61 | 62 | newArrayType :: V.Type -> V.TaggedUnion 63 | newArrayType elementType = 64 | V.TaggedUnion 65 | (builtinPos "Array") 66 | [builtinPos "of"] 67 | [] 68 | [elementType] 69 | -------------------------------------------------------------------------------- /src/Repl.hs: -------------------------------------------------------------------------------- 1 | module Repl where 2 | 3 | import System.IO 4 | import Control.Monad 5 | import Parser 6 | import Analyzer 7 | import Env 8 | import Interpreter 9 | import StaticError 10 | import Transpiler 11 | import qualified Ast.Raw as Raw 12 | import qualified Ast.Verified as V 13 | 14 | keliRead :: IO String 15 | keliRead 16 | = putStr "keli > " 17 | >> hFlush stdout 18 | >> getLine 19 | 20 | keliEval :: (Env, String) -> String -> Either [KeliError] (IO String, (Env, String)) 21 | keliEval (prevEnv, prevBytecode) input 22 | = undefined 23 | -- keliParse "" input >>= 24 | -- analyzeDecls'' prevEnv >>= \(newEnv, decls) -> 25 | -- let newBytecodeToBeExecuted = transpileModule [] decls in 26 | 27 | -- let onlyDeclarationDecls = filter (\s -> case s of V.IdlessDecl {} -> False; _ -> True) decls in 28 | -- let newByteCodeToBePassFoward = transpileModule [] onlyDeclarationDecls in 29 | -- Right (keliExecute (prevBytecode ++ newBytecodeToBeExecuted), (newEnv, newByteCodeToBePassFoward)) 30 | 31 | -- where 32 | -- analyzeDecls'' 33 | -- :: Env -- previous env 34 | -- -> [Raw.Decl] -- parsed input 35 | -- -> Either [KeliError] (Env, [V.Decl]) -- (accumulatedErrors, newEnv, newDecls) 36 | -- analyzeDecls'' env decls = 37 | -- let (errors, env', decls') = analyzeDecls [] env decls in 38 | -- if length errors > 0 then 39 | -- Left errors 40 | -- else 41 | -- Right (env', decls') 42 | 43 | 44 | keliPrint :: String -> IO () 45 | keliPrint = putStrLn 46 | 47 | keliRepl' :: Env -> String -> IO () 48 | keliRepl' prevEnv prevBytecode = do 49 | input <- keliRead 50 | unless (input == ":quit") 51 | (case keliEval (prevEnv, prevBytecode) input of 52 | Right (evaluatedOutput, (newEnv,newBytecode)) -> 53 | evaluatedOutput >>= keliPrint >> keliRepl' newEnv (prevBytecode ++ newBytecode) 54 | Left err -> 55 | keliPrint (show err) >> keliRepl' prevEnv prevBytecode) 56 | 57 | 58 | 59 | 60 | 61 | keliRepl :: IO () 62 | keliRepl = keliRepl' emptyEnv "" -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.0 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | extra-deps: [ 41 | "ordered-containers-0.1.1@sha256:74d1550a2e4443c69dece6b33931a1c1c83fe69086e88f36f0c36d435f8d77d5", 42 | "strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c" 43 | ] 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.9" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /kelilib/prelude.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | // For displaying a particular data 3 | function KELI$show(o) { 4 | // if o is an array 5 | if (Array.isArray(o)) { 6 | return "[" + o.map(KELI$show) + "]" 7 | } 8 | 9 | if (typeof o === "object") { 10 | let result = ""; 11 | // if is a tag 12 | if (o.hasOwnProperty("__tag")) { 13 | result += `${o.__union}.${o.__tag}`; 14 | // if is a carryful tag 15 | if (o.hasOwnProperty("__carry")) { 16 | result += `(${KELI$show(o.__carry)})`; 17 | } 18 | } else { // if is a object 19 | result += "$."; 20 | const keys = Object.keys(o); 21 | for (let i = 0; i < keys.length; i++) { 22 | result += `${keys[i]}(${KELI$show(o[keys[i]])})` 23 | if (i < keys.length - 1) { 24 | result += " "; 25 | } 26 | } 27 | } 28 | return result; 29 | } else if (typeof o === "string") { 30 | return `"${o}"`; 31 | } else { 32 | return o; 33 | } 34 | 35 | } 36 | 37 | // For comparing if 2 values are equals 38 | // Modified from https://github.com/epoberezkin/fast-deep-equal/blob/master/index.js 39 | const isArray = Array.isArray; 40 | const keyList = Object.keys; 41 | const hasProp = Object.prototype.hasOwnProperty; 42 | 43 | function KELI$equal(a, b) { 44 | if (a === b) return true; 45 | 46 | if (a && b && typeof a == 'object' && typeof b == 'object') { 47 | let arrA = isArray(a) 48 | , arrB = isArray(b) 49 | , i 50 | , length 51 | , key; 52 | 53 | if (arrA && arrB) { 54 | length = a.length; 55 | if (length != b.length) return false; 56 | for (i = length; i-- !== 0;) 57 | if (!KELI$equal(a[i], b[i])) return false; 58 | return true; 59 | } 60 | 61 | if (arrA != arrB) return false; 62 | 63 | const dateA = a instanceof Date 64 | , dateB = b instanceof Date; 65 | if (dateA != dateB) return false; 66 | if (dateA && dateB) return a.getTime() == b.getTime(); 67 | 68 | const regexpA = a instanceof RegExp 69 | , regexpB = b instanceof RegExp; 70 | if (regexpA != regexpB) return false; 71 | if (regexpA && regexpB) return a.toString() == b.toString(); 72 | 73 | const keys = keyList(a); 74 | length = keys.length; 75 | 76 | if (length !== keyList(b).length) 77 | return false; 78 | 79 | for (i = length; i-- !== 0;) 80 | if (!hasProp.call(b, keys[i])) return false; 81 | 82 | for (i = length; i-- !== 0;) { 83 | key = keys[i]; 84 | if (!KELI$equal(a[key], b[key])) return false; 85 | } 86 | 87 | return true; 88 | } 89 | 90 | return a!==a && b!==b; 91 | }; -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util where 2 | 3 | import Prelude hiding (id, head, tail, last, init) 4 | import Data.List hiding (last) 5 | import Control.Monad 6 | import qualified Ast.Raw as Raw 7 | import Data.Maybe 8 | import Data.Set hiding (map, (\\), foldl') 9 | 10 | data OneOf3 a b c = First a | Second b | Third c deriving (Show) 11 | 12 | data MatchResult 13 | = GotDuplicates [Raw.StringToken] 14 | | ZeroIntersection 15 | | GotExcessive [Raw.StringToken] -- means there are extraneous elements in source 16 | | Missing [String] -- means some elements in target is not matched 17 | | PerfectMatch -- means all elements in source matches all elements in target 18 | deriving (Show, Eq) 19 | 20 | -- NOTE: 21 | -- source also means actual elements 22 | -- target also means expected elements 23 | match :: [Raw.StringToken] -> [Raw.StringToken] -> MatchResult 24 | match source target = 25 | let source' = sort (map snd source) in 26 | let target' = sort (map snd target) in 27 | let intersection' = intersect source' target' in 28 | let intersectionLength = length intersection' in 29 | case findDuplicates source of 30 | Just duplicates -> 31 | GotDuplicates duplicates 32 | Nothing -> 33 | if intersectionLength == 0 then 34 | ZeroIntersection 35 | else if intersectionLength == length target then ( 36 | if length source > length target then 37 | let excessiveCases = 38 | catMaybes (map 39 | (\x -> find (\y -> snd y == x) source) 40 | (toList (difference (fromList source') (fromList target')))) in 41 | GotExcessive excessiveCases 42 | else 43 | PerfectMatch) 44 | else if intersectionLength < length target then 45 | Missing (target' \\ source') 46 | else 47 | error "impossible" 48 | 49 | findDuplicates :: [Raw.StringToken] -> Maybe [Raw.StringToken] 50 | findDuplicates tokens = 51 | let result = 52 | foldl' 53 | (\acc t@(pos, id) -> 54 | if acc == [] then 55 | case find (\(pos', id') -> pos /= pos' && id == id') tokens of 56 | Just t' -> 57 | [t, t'] 58 | Nothing -> 59 | [] 60 | else 61 | acc) 62 | [] 63 | tokens in 64 | if length result > 0 then 65 | Just result 66 | else 67 | Nothing 68 | 69 | 70 | head :: [a] -> Maybe a 71 | head [] = Nothing 72 | head (x:_) = Just x 73 | 74 | last :: [a] -> Maybe a 75 | last [] = Nothing 76 | last (x:[]) = Just x 77 | last (_:xs) = last xs -------------------------------------------------------------------------------- /test_output.txt: -------------------------------------------------------------------------------- 1 | 2 | ~ 3 | suggest-object-alias-1 4 | ~ 5 | suggest-for-lambda-shorthand-2 6 | ~ 7 | suggest-for-function-chaining-1 8 | ~ 9 | suggest-tagged-union-1 10 | ~ 11 | suggest-for-function-chaining-2 12 | ~ 13 | suggest-imported-symbol-1 14 | ~ 15 | suggest-for-lambda-shorthand-1 16 | ~ 17 | suggest-case-expr-1 18 | 19 | Finished in 0.0099 seconds 20 | 8 examples, 0 failures 21 | 22 | ~ 23 | record-as-type-annot-2 24 | ~ 25 | record-value-setter-1 26 | ~ 27 | ffi-javascript-1 28 | ~ 29 | identity-func-1 30 | ~ 31 | generic-tagged-union-5 32 | ~ 33 | insensitive-decl-order-1 34 | ~ 35 | generic-tagged-union-3 36 | ~ 37 | tostring-1 38 | ~ 39 | carryless-tag-1 40 | ~ 41 | lambda-shorthand-1 42 | ~ 43 | fix#33 44 | ~ 45 | complete-tag-matcher-1 46 | ~ 47 | @generic-tagged-union-type-mismatch-1 48 | ~ 49 | mutual-recursion-1 50 | ~ 51 | @type-mismatch-1 52 | ~ 53 | module-import-4 54 | ~ 55 | @tag-matcher-duplicate-tags-1 56 | ~ 57 | @incorrect-carry-type-1 58 | ~ 59 | module-import-3 60 | ~ 61 | record-getter-1 62 | ~ 63 | @tag-matcher-hetero-branch-1 64 | ~ 65 | func-chaining-2 66 | ~ 67 | @importing-unexisting-file-1 68 | ~ 69 | docstring-1 70 | ~ 71 | @record-prop-type-mismatch-1 72 | ~ 73 | recursive-tagged-union-1 74 | ~ 75 | func-without-return-type-annot-1 76 | ~ 77 | generic-tagged-union-1 78 | ~ 79 | recursive-func-1 80 | ~ 81 | multiple-dispatch-1 82 | ~ 83 | ffi-javascript-2 84 | ~ 85 | @tag-matcher-missing-branch-1 86 | ~ 87 | func-chaining-1 88 | ~ 89 | access-tag-carry-1 90 | ~ 91 | bifunc-1 92 | ~ 93 | module-import-2 94 | ~ 95 | @duplicated-func-1 96 | ~ 97 | multiline-string-1 98 | ~ 99 | record-type-alias-1 100 | ~ 101 | tagged-union-as-type-annot-1 102 | ~ 103 | @tag-invalid-carry-type-1 104 | ~ 105 | record-as-type-annot-1 106 | ~ 107 | @record-missing-prop-1 108 | ~ 109 | array-literal-1 110 | ~ 111 | fix#41 112 | ~ 113 | access-tag-carry-2 114 | ~ 115 | comment-1 116 | ~ 117 | record-creation-1 118 | ~ 119 | @incorrect-lambda-param-type-1 120 | ~ 121 | carryful-tag-1 122 | ~ 123 | trifunc-1 124 | ~ 125 | @duplicated-const-id-1 126 | ~ 127 | record-lambda-setter-1 128 | ~ 129 | module-import-1 130 | ~ 131 | generic-tagged-union-4 132 | ~ 133 | generic-tagged-union-2 134 | ~ 135 | multiple-dispatch-2 136 | ~ 137 | else-tag-matcher-1 138 | ~ 139 | @tag-matcher-using-unknown-tag-1 140 | 141 | Finished in 2.6415 seconds 142 | 59 examples, 0 failures 143 | 144 | match 145 | got duplicate 146 | zero intersection 147 | got excessive 148 | missing 149 | perfect match 150 | keli parser 151 | identifiers 152 | string expr 153 | lambda expr 154 | multiple decl 155 | const decl 156 | monofunc decl 157 | polyfunc decl 158 | monofunc call 159 | polyfunc call 160 | 161 | Finished in 0.0024 seconds 162 | 14 examples, 0 failures 163 | -------------------------------------------------------------------------------- /src/PreludeJSCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module PreludeJSCode where 3 | 4 | import Text.RawString.QQ 5 | 6 | -- The following code is copied from '../kelilib/prelude.js' 7 | preludeJSCode :: String 8 | preludeJSCode = [r| 9 | "use strict"; 10 | // For displaying a particular data 11 | function KELI$show(o) { 12 | // if o is an array 13 | if (Array.isArray(o)) { 14 | return "[" + o.map(KELI$show) + "]" 15 | } 16 | 17 | if (typeof o === "object") { 18 | let result = ""; 19 | // if is a tag 20 | if (o.hasOwnProperty("__tag")) { 21 | result += `${o.__union}.${o.__tag}`; 22 | // if is a carryful tag 23 | if (o.hasOwnProperty("__carry")) { 24 | result += `(${KELI$show(o.__carry)})`; 25 | } 26 | } else { // if is a object 27 | result += "$."; 28 | const keys = Object.keys(o); 29 | for (let i = 0; i < keys.length; i++) { 30 | result += `${keys[i]}(${KELI$show(o[keys[i]])})` 31 | if (i < keys.length - 1) { 32 | result += " "; 33 | } 34 | } 35 | } 36 | return result; 37 | } else if (typeof o === "string") { 38 | return `"${o}"`; 39 | } else { 40 | return o; 41 | } 42 | 43 | } 44 | 45 | // For comparing if 2 values are equals 46 | // Modified from https://github.com/epoberezkin/fast-deep-equal/blob/master/index.js 47 | const isArray = Array.isArray; 48 | const keyList = Object.keys; 49 | const hasProp = Object.prototype.hasOwnProperty; 50 | 51 | function KELI$equal(a, b) { 52 | if (a === b) return true; 53 | 54 | if (a && b && typeof a == 'object' && typeof b == 'object') { 55 | let arrA = isArray(a) 56 | , arrB = isArray(b) 57 | , i 58 | , length 59 | , key; 60 | 61 | if (arrA && arrB) { 62 | length = a.length; 63 | if (length != b.length) return false; 64 | for (i = length; i-- !== 0;) 65 | if (!KELI$equal(a[i], b[i])) return false; 66 | return true; 67 | } 68 | 69 | if (arrA != arrB) return false; 70 | 71 | const dateA = a instanceof Date 72 | , dateB = b instanceof Date; 73 | if (dateA != dateB) return false; 74 | if (dateA && dateB) return a.getTime() == b.getTime(); 75 | 76 | const regexpA = a instanceof RegExp 77 | , regexpB = b instanceof RegExp; 78 | if (regexpA != regexpB) return false; 79 | if (regexpA && regexpB) return a.toString() == b.toString(); 80 | 81 | const keys = keyList(a); 82 | length = keys.length; 83 | 84 | if (length !== keyList(b).length) 85 | return false; 86 | 87 | for (i = length; i-- !== 0;) 88 | if (!hasProp.call(b, keys[i])) return false; 89 | 90 | for (i = length; i-- !== 0;) { 91 | key = keys[i]; 92 | if (!KELI$equal(a[key], b[key])) return false; 93 | } 94 | 95 | return true; 96 | } 97 | 98 | return a!==a && b!==b; 99 | }; 100 | |] -------------------------------------------------------------------------------- /src/Cli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Cli where 3 | 4 | 5 | import Options.Applicative 6 | import Data.Semigroup ((<>)) 7 | import Data.Aeson 8 | import qualified Data.ByteString.Lazy.Char8 as Char8 9 | import qualified Data.HashMap.Strict as HashMap 10 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 11 | 12 | import System.IO 13 | import PreludeJSCode 14 | import Interpreter 15 | import Repl 16 | import Transpiler 17 | import Package 18 | import Compiler 19 | import Diagnostics(toDiagnostic) 20 | import CompletionItems 21 | 22 | keliCompilerVersion :: String 23 | keliCompilerVersion = "0.0.2-alpha" 24 | 25 | data KeliCommand 26 | = Execute 27 | String -- filename 28 | Bool -- whether to show line number or not 29 | | Repl 30 | | Analyze 31 | String -- filename 32 | | Compile 33 | String -- filename 34 | | Suggest 35 | String --filename 36 | Int --line number 37 | Int --column number 38 | | NewPackage 39 | String -- package name 40 | | AddDependency 41 | String -- git repo url 42 | String -- tag 43 | | Version 44 | | Install 45 | String -- path to purse.json 46 | deriving (Show) 47 | 48 | allParser :: Parser KeliCommand 49 | allParser = subparser ( 50 | command "run" (info 51 | (Execute 52 | <$> (argument str (metavar "FILENAME")) 53 | <*> switch 54 | ( long "show-line-number" 55 | <> short 'l' 56 | <> help "Where to show line number or not." )) 57 | (progDesc "Execute a Keli program (*.keli)")) 58 | <> 59 | command "analyze" (info 60 | (Analyze 61 | <$> (argument str (metavar "FILENAME"))) 62 | (progDesc "Analyze a Keli program (*.keli) and display error as JSON.")) 63 | <> 64 | command "compile" (info 65 | (Compile 66 | <$> (argument str (metavar "FILENAME"))) 67 | (progDesc "Compile a Keli program (*.keli) into JavaScript file.")) 68 | 69 | <> 70 | command "suggest" (info 71 | (Suggest 72 | <$> (argument str (metavar "FILENAME")) 73 | <*> (argument auto (metavar "LINE_NUMBER(zero-based index)")) 74 | <*> (argument auto (metavar "COLUMN_NUMBER(zero-based index)"))) 75 | (progDesc "Analyze a Keli program (*.keli) and suggest completion items.")) 76 | <> 77 | command "repl" (info 78 | (pure Repl) 79 | (progDesc "Starts the Keli REPL.")) 80 | <> 81 | command "new-package" (info 82 | (NewPackage 83 | <$> (argument str (metavar "FILENAME"))) 84 | (progDesc "Create a new Keli package")) 85 | <> 86 | command "add-dependency" (info 87 | (AddDependency 88 | <$> (argument str (metavar "GIT_REPO_URL")) 89 | <*> (argument str (metavar "TAG"))) 90 | (progDesc "Create a new Keli package")) 91 | <> 92 | command "install" (info 93 | (Install 94 | <$> (argument str (metavar "PATH_TO_PURSE.JSON"))) 95 | (progDesc "Install dependencies based on the specified purse.json")) 96 | <> 97 | command "version" (info 98 | (pure Version) 99 | (progDesc "Get the version of this Keli compiler.")) 100 | ) 101 | 102 | cli :: IO () 103 | cli = handleKeliCommand =<< execParser opts 104 | where 105 | opts = info (allParser <**> helper) 106 | ( fullDesc 107 | <> progDesc "Compile or interpret Keli program." 108 | <> header "The Keli Compiler" ) 109 | 110 | handleKeliCommand :: KeliCommand -> IO () 111 | handleKeliCommand input = 112 | case input of 113 | Execute filename showLineNumber -> do 114 | result <- keliInterpret showLineNumber filename 115 | case result of 116 | Right output -> 117 | hPutStrLn stdout output 118 | 119 | Left err -> 120 | hPutStrLn stderr err 121 | 122 | Compile filename -> do 123 | contents <- readFile filename 124 | (errors, module', _, _) <- keliCompile filename contents (HashMap.empty) [] 125 | if length errors > 0 then 126 | putStr (Char8.unpack (encode (concat (map toDiagnostic errors)))) 127 | else 128 | putStr (preludeJSCode ++ transpileModule True False module') 129 | 130 | Repl -> 131 | keliRepl 132 | 133 | Analyze filename -> do 134 | contents <- readFile filename 135 | (errors, _, _, _) <- keliCompile filename contents (HashMap.empty) [] 136 | putStr (Char8.unpack (encode (concat (map toDiagnostic errors)))) 137 | 138 | Suggest filename lineNumber columnNumber -> do 139 | completionItems <- suggestCompletionItemsAt filename (lineNumber, columnNumber) 140 | putStr (Char8.unpack (encode completionItems)) 141 | 142 | Install pursePath -> 143 | installDeps pursePath 144 | 145 | Version -> 146 | putStrLn keliCompilerVersion 147 | 148 | NewPackage packageName -> do 149 | createNewPackage packageName 150 | 151 | AddDependency gitRepoUrl tag -> do 152 | addDependency gitRepoUrl tag 153 | 154 | 155 | 156 | 157 | -------------------------------------------------------------------------------- /src/StaticError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module StaticError where 6 | 7 | 8 | import Module 9 | import Text.ParserCombinators.Parsec 10 | import Text.Parsec.Error 11 | -- import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 12 | 13 | import qualified Ast.Verified as Verified 14 | import Env 15 | import qualified Ast.Raw as Raw 16 | import Util 17 | 18 | data Messages = Messages [Message] 19 | 20 | data KeliError 21 | = KErrorParseError SourcePos Messages 22 | | KErrorDuplicatedId [Verified.StringToken] 23 | | KErrorDuplicatedProperties [Verified.StringToken] 24 | | KErrorDuplicatedTags [Verified.StringToken] 25 | | KErrorExcessiveTags 26 | [Verified.StringToken] -- excessive tags 27 | Verified.StringToken -- name of tagged union 28 | | KErrorExcessiveProperties [Verified.StringToken] 29 | | KErrorIncorrectCarryType 30 | Verified.Type -- expected type 31 | Verified.Expr -- actual expr 32 | | KErrorIncorrectUsageOfObject Verified.StringToken 33 | | KErrorIncorrectUsageOfTag Verified.StringToken 34 | | KErrorIncorrectUsageOfFFI Verified.StringToken 35 | | KErrorMissingTags 36 | Verified.Expr -- subject 37 | [Verified.Tag] -- missing tags 38 | 39 | | KErrorMissingProperties 40 | Verified.Expr' -- for telling where is the object constructor 41 | [String] -- missing props 42 | 43 | | KErrorUnmatchingFuncReturnType 44 | Verified.Expr -- actual body 45 | Verified.Type -- expected type 46 | | KErrorUsingUndefinedFunc 47 | [Verified.StringToken] -- function ids 48 | [Verified.FuncSignature] -- list of possible functions with the same ids 49 | 50 | | KErrorUsingUndefinedId Verified.StringToken 51 | | KErrorWrongTypeInSetter Verified.Expr Verified.Type 52 | | KErrorPropertyTypeMismatch 53 | Verified.StringToken -- property name 54 | Verified.Type -- expected type 55 | Verified.Type -- actual type 56 | Verified.Expr' -- actual expr 57 | | KErrorNotAFunction [Verified.StringToken] 58 | | KErrorDuplicatedFunc Verified.FuncSignature 59 | | KErrorFuncCallTypeMismatch 60 | Verified.Type -- expected type 61 | Verified.Expr -- actual expr (type-checked) 62 | 63 | | KErrorCannotDeclareTypeAsAnonymousConstant Verified.TypeAnnotation 64 | | KErrorCannotDeclareTagAsAnonymousConstant [Verified.UnlinkedTag] 65 | 66 | | KErrorExpectedTypeAnnotButGotExpr Verified.Expr 67 | | KErrorExpectedTagButGotExpr Verified.Expr 68 | | KErrorExpectedTagButGotTypeAnnotation Verified.TypeAnnotation 69 | | KErrorExpectedExprButGotTypeAnnotation Verified.TypeAnnotation 70 | | KErrorExpectedTypeAnnotationButGotTag [Verified.UnlinkedTag] 71 | | KErrorExpectedExprButGotTag [Verified.UnlinkedTag] 72 | | KErrorExpectedExprOrTypeButGotTag [Verified.UnlinkedTag] 73 | | KErrorUnknownFFITarget Verified.StringToken 74 | | KErrorFFIValueShouldBeString Verified.Expr 75 | | KErrorInvalidBoundedTypeVarDecl Raw.Expr 76 | | KErrorIncorrectUsageOfTagConstructorPrefix Verified.Expr 77 | | KErrorTagNotFound 78 | Raw.StringToken -- tag that user wanted to use 79 | Raw.StringToken -- name of the tagged union 80 | [Verified.Tag] -- list of possible tags 81 | 82 | | KErrorIncompleteFuncCall -- for implementing Intellisense 83 | (OneOf3 Verified.Expr Verified.TypeAnnotation [Verified.UnlinkedTag]) 84 | SourcePos -- position of the dot operator 85 | 86 | | KErrorCannotRedefineReservedConstant Raw.StringToken 87 | | KErrorCannotDefineCustomPrimitiveType Raw.StringToken 88 | | KErrorTypeConstructorIdsMismatch 89 | [Raw.StringToken] -- expected ids 90 | [Raw.StringToken] -- actual ids 91 | 92 | | KErrorTypeMismatch 93 | Verified.Expr' -- actual expr (for locating error position) 94 | Verified.Type -- actual type 95 | Verified.Type -- expected type 96 | 97 | | KErrorNotAllBranchHaveTheSameType 98 | Verified.Expr' -- actual expr (for locating error position) 99 | Verified.Type -- actual type 100 | Verified.Type -- expected type 101 | Verified.TagBranch -- first branch 102 | 103 | | KErrorExpectedId 104 | Raw.Expr 105 | 106 | | KErrorExpectedKeywordIf 107 | Raw.StringToken 108 | 109 | | KErrorExpectedPropDefOrId 110 | Raw.Expr 111 | 112 | | KErrorExpectedTypeAnnotationAfterThis 113 | Raw.StringToken 114 | 115 | | KErrorExpectedKeywordIfOrDefault 116 | Raw.StringToken 117 | 118 | | KErrorExpectedColon 119 | Raw.StringToken 120 | 121 | | KErrorUnknownTag 122 | Raw.StringToken 123 | 124 | | KErrorBindingCarrylessTag 125 | Raw.StringToken 126 | 127 | | KErrorExpectedTagBindings 128 | Raw.Expr 129 | 130 | | KErrorUnknownProp 131 | Raw.StringToken 132 | 133 | | KErrorMoreThanOneElseBranch 134 | [Raw.StringToken] 135 | 136 | | KErrorTVarSelfReferencing 137 | Verified.Expr 138 | String 139 | Verified.Type 140 | 141 | | KErrorCannotImport 142 | Raw.StringToken 143 | 144 | | KErrorAmbiguousUsage 145 | [Raw.StringToken] 146 | [(Verified.Scope, KeliSymbol)] 147 | 148 | | KErrorPartiallyMatchedFuncFound KeliError 149 | 150 | | KErrorIncorrectTagDeclSyntax 151 | [Raw.StringToken] 152 | 153 | | KErrorCircularImport 154 | Raw.StringToken -- location of error 155 | [String] -- related filepaths 156 | 157 | deriving (Show) 158 | 159 | instance Show Messages where 160 | show (Messages msgs) = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" msgs 161 | 162 | 163 | 164 | -------------------------------------------------------------------------------- /src/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Compiler where 2 | 3 | import Data.List 4 | 5 | import StaticError 6 | import Control.Monad 7 | import Analyzer 8 | import Parser 9 | import qualified Ast.Raw as Raw 10 | import Env 11 | import System.FilePath.Posix 12 | import Data.List.Utils (replace) 13 | import System.Directory 14 | import Module 15 | import qualified Data.HashMap.Strict as HashMap 16 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 17 | 18 | 19 | type ImportTree = [ImportNode] 20 | 21 | data ImportNode 22 | = ImportNode 23 | String -- importer's absolute filepath 24 | String -- importees' absolute filepaths 25 | deriving (Eq, Show) 26 | 27 | findImportersOf :: ImportTree -> String -> [String] 28 | tree `findImportersOf` targetName = 29 | case tree of 30 | [] -> 31 | [] 32 | 33 | (ImportNode importerName importeeName):tree' -> 34 | let directImportersNames = 35 | let result = tree' `findImportersOf` targetName in 36 | if importeeName == targetName then 37 | importerName:result 38 | else 39 | result 40 | 41 | -- we also need to find the importers of importers 42 | -- for detecting transitive dependencies 43 | in directImportersNames ++ concatMap (\name -> tree `findImportersOf` name) directImportersNames 44 | 45 | 46 | -- used for representing a module with parse error 47 | nullModule :: String -> Module 48 | nullModule name = Module name "" [] emptyEnv [] 49 | 50 | type ModuleCache = HashMap.HashMap String Module 51 | 52 | keliCompile 53 | :: String 54 | -> String 55 | -> ModuleCache 56 | -> ImportTree 57 | -> IO ([KeliError], Module, ModuleCache, ImportTree) 58 | keliCompile filepath contents cache importTree = do 59 | let currentModulename = takeBaseName (replace "\\" "/" filepath) -- Refer http://hackage.haskell.org/package/filepath-1.4.2.1/docs/System-FilePath-Posix.html#v:takeBaseName 60 | importerFilePath <- makeAbsolute filepath 61 | case keliParse filepath contents of 62 | Right rawDecls -> do 63 | let (importStatements, nonImportRawDecls) = 64 | partition 65 | (\x -> case x of ImportDecl{} -> True; NonImportDecl{} -> False) 66 | (map differentiateRawDecl rawDecls) 67 | 68 | let importersOfCurrentModule = importTree `findImportersOf` importerFilePath 69 | 70 | -- importeeErrors means errors at the imported files 71 | (importeeErrors, importedModules, updatedCache, updatedImportTree) <- 72 | foldM 73 | (\(prevErrors, prevModules, prevCache, prevTree) (ImportDecl importFilePath) -> do 74 | let importPath = 75 | if isAbsolute (snd importFilePath) then 76 | snd importFilePath 77 | else 78 | takeDirectory (replace "\\" "/" importerFilePath) ++ "/" ++ snd importFilePath 79 | importeeFilePath <- canonicalizePath importPath 80 | yes <- doesFileExist importeeFilePath 81 | if yes then 82 | -- check for circular imports 83 | if importeeFilePath `elem` importersOfCurrentModule then 84 | let newError = KErrorCircularImport importFilePath (importerFilePath:importersOfCurrentModule) in 85 | return (newError:prevErrors, prevModules, prevCache, prevTree) 86 | else 87 | -- update import tree 88 | let newImportTree = (ImportNode importerFilePath importeeFilePath):importTree in 89 | 90 | -- check if the module had been imported before or not 91 | case HashMap.lookup importeeFilePath prevCache of 92 | -- if already imported previously 93 | Just m -> 94 | return (prevErrors, prevModules ++ [m], prevCache, newImportTree) 95 | 96 | -- if never imported before 97 | Nothing -> do 98 | importedContents <- readFile importeeFilePath 99 | (currentErrors, currentModule, newCache, newImportTree') <- keliCompile importeeFilePath importedContents prevCache newImportTree 100 | return ( 101 | prevErrors ++ currentErrors, 102 | prevModules ++ [currentModule], 103 | HashMap.insert importeeFilePath currentModule newCache, 104 | nub (newImportTree ++ newImportTree')) -- nub is for removing duplicates 105 | else 106 | return (prevErrors ++ [KErrorCannotImport importFilePath], prevModules, prevCache, prevTree)) 107 | (([],[], cache, importTree) :: ([KeliError], [Module], ModuleCache, ImportTree)) 108 | importStatements 109 | 110 | let (currentErrors, currentEnv, currentDecls) = 111 | -- import intial environment here 112 | let importedEnvs = map (\m -> (moduleName m, moduleEnv m)) importedModules in 113 | analyze (("",initialEnv):importedEnvs) (map (\(NonImportDecl d) -> d) nonImportRawDecls) 114 | 115 | return ( 116 | importeeErrors ++ currentErrors, 117 | Module currentModulename importerFilePath importedModules currentEnv currentDecls, 118 | updatedCache, 119 | updatedImportTree) 120 | 121 | Left errs -> 122 | return (errs, nullModule currentModulename, cache, importTree) 123 | 124 | data DifferentiationResult 125 | = ImportDecl Raw.StringToken 126 | | NonImportDecl Raw.Decl 127 | deriving (Show) 128 | 129 | differentiateRawDecl :: Raw.Decl -> DifferentiationResult 130 | differentiateRawDecl 131 | (Raw.IdlessDecl _ (Raw.FuncCall ((Raw.Id (_,"module"):(Raw.StringExpr filePath):[])) ((_,"import"):[]))) = 132 | ImportDecl filePath 133 | 134 | differentiateRawDecl other = NonImportDecl other -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | import Test.Hspec 4 | import Parser 5 | import Debug.Trace 6 | import System.Directory 7 | import Control.Monad 8 | import Data.Strings 9 | import Data.List 10 | import Data.String.Utils 11 | 12 | import Compiler 13 | import Util 14 | import Interpreter 15 | import Ast.Verified (newStringToken, newStringToken', StringToken) 16 | import CompletionItems 17 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 18 | 19 | testParseKeli :: String -> Expectation 20 | testParseKeli x = 21 | (case (keliParse "" x) of 22 | Right _ -> True 23 | Left err -> trace (show err) $ False) `shouldBe` True 24 | 25 | runTestCases_compile :: IO () 26 | runTestCases_compile = do 27 | let parentDir = "./test/specs/execute/" 28 | allTestCases <- listDirectory parentDir 29 | 30 | -- search for test cases prefix with `ONLY:` 31 | let onlyTestCases = filter (\t -> t `strStartsWith` "ONLY:") allTestCases 32 | finalTestCases <- 33 | if length onlyTestCases > 0 then 34 | return onlyTestCases 35 | else do 36 | -- take out all test cases prefix with `SKIP:` 37 | let (testCasesToBeRun, testCasesNotToBeRun) = partition (\t -> not (t `strStartsWith` "SKIP:")) allTestCases 38 | putStrLn ("Skipping " ++ show (length testCasesNotToBeRun) ++ " test cases..." ) 39 | return testCasesToBeRun 40 | hspec $ do 41 | forM_ 42 | finalTestCases 43 | (\t -> do 44 | describe "~" $ do 45 | it t $ do 46 | -- 1. validate if the test cases is structured in the correct format 47 | validateTestCase parentDir t 48 | 49 | -- 2. interpret the entry file of this test cases 50 | result <- keliInterpret True (parentDir ++ t ++ "/entry.keli") 51 | 52 | -- 3. compare the output with expected output 53 | expectedOutput <- readFile (parentDir ++ t ++ "/output") 54 | case result of 55 | Right output -> 56 | strip output `shouldBe` strip expectedOutput 57 | Left err -> do 58 | -- putStrLn err 59 | strip err `shouldBe` strip expectedOutput) 60 | 61 | where 62 | 63 | -- This function is to make sure the following files exist 64 | -- * entry.keli 65 | -- * output 66 | validateTestCase :: String -> String -> IO () 67 | validateTestCase parentDir testCaseName = do 68 | filenames <- listDirectory (parentDir ++ testCaseName) 69 | if ["entry.keli", "output"] `isSubListOf` filenames then 70 | return () 71 | else 72 | error ("The file `entry.keli` and `output` should be created inside " ++ parentDir ++ testCaseName) 73 | 74 | 75 | runTestCases_suggest :: IO () 76 | runTestCases_suggest = do 77 | let parentDir = "./test/specs/suggest/" 78 | allTestCases <- listDirectory parentDir 79 | 80 | -- search for test cases prefix with `ONLY:` 81 | let onlyTestCases = filter (\t -> t `strStartsWith` "ONLY:") allTestCases 82 | let finalTestCases = if length onlyTestCases > 0 then onlyTestCases else allTestCases 83 | hspec $ do 84 | forM_ 85 | finalTestCases 86 | (\t -> do 87 | describe "~" $ do 88 | it t $ do 89 | -- 1. validate if the test cases is structured in the correct format 90 | validateTestCase parentDir t 91 | 92 | -- 2. extract position 93 | position <- readFile (parentDir ++ t ++ "/where") 94 | let [lineNumber, columnNumber] = map (\x -> (read x) :: Int) (lines position) 95 | 96 | -- 3. look for suggestion at the entry file of this test cases 97 | output <- suggestCompletionItemsAt (parentDir ++ t ++ "/entry.keli") (lineNumber, columnNumber) 98 | 99 | -- 4. compare the output with expected output 100 | expectedOutput <- readFile (parentDir ++ t ++ "/output") 101 | output `shouldBe` (read expectedOutput :: [CompletionItem])) 102 | 103 | where 104 | 105 | -- This function is to make sure the following files exist 106 | -- * entry.keli 107 | -- * output 108 | -- * where 109 | validateTestCase :: String -> String -> IO () 110 | validateTestCase parentDir testCaseName = do 111 | filenames <- listDirectory (parentDir ++ testCaseName) 112 | if sort ["entry.keli", "output", "where"] `isSubListOf` sort filenames then 113 | return () 114 | else 115 | error ("The file `entry.keli`, `where` and `output` should be created inside " ++ parentDir ++ testCaseName) 116 | 117 | -- copied from https://stackoverflow.com/questions/47232335/check-if-list-is-a-sublist-of-another-list 118 | isSubListOf :: Eq a => [a] -> [a] -> Bool 119 | isSubListOf [] [] = True 120 | isSubListOf _ [] = False 121 | isSubListOf [] _ = True 122 | isSubListOf (x:xs) (y:ys) 123 | | x == y = isSubListOf xs ys 124 | | otherwise = isSubListOf (x:xs) ys 125 | 126 | 127 | main :: IO () 128 | main = do 129 | runTestCases_suggest 130 | runTestCases_compile 131 | otherTest 132 | 133 | targetTags :: [StringToken] 134 | targetTags = [newStringToken "a", newStringToken "b", newStringToken "c"] 135 | 136 | otherTest :: IO () 137 | otherTest = hspec $ do 138 | describe "import trees" $ do 139 | it "case 1" $ do 140 | let tree = [ImportNode "A" "B", ImportNode "B" "C", ImportNode "A" "D"] 141 | let importersOfC = tree `findImportersOf` "C" 142 | importersOfC `shouldBe` ["B", "A"] 143 | 144 | describe "match" $ do 145 | it "got duplicate" $ do 146 | let source = [ 147 | newStringToken' (0,0,"a"), 148 | newStringToken' (1,1,"b"), 149 | newStringToken' (2,2,"c"), 150 | newStringToken' (3,3,"a") 151 | ] 152 | match source targetTags `shouldBe` GotDuplicates [newStringToken' (0,0,"a"),newStringToken' (3,3,"a")] 153 | 154 | it "zero intersection" $ do 155 | let source = [newStringToken "x", newStringToken "y"] 156 | match source targetTags `shouldBe` ZeroIntersection 157 | 158 | it "got excessive" $ do 159 | let source = [ 160 | newStringToken "a", 161 | newStringToken "b", 162 | newStringToken "c", 163 | newStringToken "d" -- extra 164 | ] 165 | match source targetTags `shouldBe` GotExcessive [newStringToken "d"] 166 | 167 | it "missing" $ do 168 | let source = [ newStringToken "a", newStringToken "b"] 169 | match source targetTags `shouldBe` Missing ["c"] 170 | 171 | it "perfect match" $ do 172 | let source = [newStringToken "a", newStringToken "b", newStringToken "c"] 173 | match source targetTags `shouldBe` PerfectMatch 174 | 175 | describe "keli parser" $ do 176 | it "identifiers" $ do 177 | testParseKeli "_=0" 178 | testParseKeli "even?=0" 179 | 180 | it "string expr" $ do 181 | -- comments are just string expressions! 182 | testParseKeli "=\"this is a string\" pi=3.142" 183 | 184 | it "lambda expr" $ do 185 | testParseKeli "hi = x | console.log(x)" 186 | testParseKeli "hi = x | y | x.+(y)" 187 | 188 | it "multiple decl" $ do 189 | testParseKeli "x=5 y=5" 190 | 191 | it "const decl" $ do 192 | testParseKeli "x=5" 193 | testParseKeli "=5" 194 | 195 | it "monofunc decl" $ do 196 | testParseKeli "(this string).reverse|string=undefined" 197 | testParseKeli "(this string).! |string=undefined" 198 | testParseKeli "{a type}(x a).unit|a=undefined" 199 | -- testParseKeli "{a type}{b type}(x (a.with b)).invert|(b.with a)=x.second.with(x.first);" 200 | 201 | it "polyfunc decl" $ do 202 | testParseKeli "(this string).splitby(that string)|string=undefined" 203 | testParseKeli "(this string).replace(that string) with (the string)|string=undefined" 204 | testParseKeli "(this Int). == (that Int)|Int=undefined" 205 | 206 | it "monofunc call" $ do 207 | testParseKeli "=x.reverse" 208 | testParseKeli "=x.!" 209 | 210 | it "polyfunc call" $ do 211 | testParseKeli "=compiler.import(x)" 212 | testParseKeli "=x.replace(a) with (b)" 213 | testParseKeli "=x.+(y)" 214 | -------------------------------------------------------------------------------- /src/Package.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | module Package where 4 | 5 | import GHC.Generics hiding(packageName) 6 | import Control.Monad 7 | import Control.Concurrent 8 | import qualified Data.ByteString.Lazy.Char8 as Char8 9 | import Text.ParserCombinators.Parsec hiding (token) 10 | import Data.Either 11 | import System.Directory 12 | import System.IO 13 | import System.Exit 14 | import qualified System.Info as SysInfo 15 | import System.Process 16 | import Data.Aeson.Encode.Pretty 17 | import Data.Aeson 18 | 19 | type Version = String 20 | 21 | data Purse = Purse { 22 | os :: String, 23 | arch :: String, 24 | compiler :: Version, 25 | git :: Version, 26 | node :: Version, 27 | dependencies :: [Dependency] 28 | } deriving (Show, Generic, Eq, Read) 29 | 30 | instance ToJSON Purse where 31 | instance FromJSON Purse where 32 | 33 | data Dependency = Dependency { 34 | url :: String, 35 | tag :: String 36 | } deriving (Show, Generic, Eq, Read) 37 | 38 | instance ToJSON Dependency where 39 | instance FromJSON Dependency where 40 | 41 | createNewPackage :: String -> IO() 42 | createNewPackage packageName = do 43 | putStrLn ("Creating package `" ++ packageName ++ "`") 44 | createDirectory packageName 45 | 46 | putStrLn ("Creating _src folder") 47 | createDirectory (packageName ++ "/_src") 48 | 49 | putStrLn ("Initializing purse.json") 50 | purse <- getPurse 51 | writeFile (packageName ++ "/_src/purse.json") (Char8.unpack (encodePretty purse)) 52 | 53 | putStrLn ("Creating _test folder") 54 | createDirectory (packageName ++ "/_test") 55 | 56 | putStrLn ("Creating README file") 57 | writeFile (packageName ++ "/README.md") ("# " ++ packageName) 58 | 59 | putStrLn ("Creating LICENSE file") 60 | writeFile (packageName ++ "/LICENSE") "" 61 | 62 | putStrLn ("Creating .gitignore file") 63 | writeFile 64 | (packageName ++ "/.gitignore") 65 | ( "# ignore all folders\n" 66 | ++ "/*\n\n" 67 | ++ "# ignore __temp__.keli generated by Keli Language Extension\n" 68 | ++ "__temp__.keli\n\n" 69 | ++ "# except\n" 70 | ++ "!.gitignore\n" 71 | ++ "!README.md\n" 72 | ++ "!LICENSE\n" 73 | ++ "!_src/\n" 74 | ++ "!_test/\n") 75 | 76 | -- initialize git 77 | output <- readCreateProcess ((shell "git init") { cwd = Just ("./" ++ packageName) }) "" 78 | putStrLn output 79 | 80 | -- stage and commit auto-generated files 81 | putStrLn "Staging and commiting initial files" 82 | !_ <- readCreateProcess ((shell "git add .") { cwd = Just ("./" ++ packageName) }) "" 83 | !_ <- readCreateProcess ((shell "git commit -m 'Package initialization'") { cwd = Just ("./" ++ packageName) }) "" 84 | 85 | putStrLn "\n==== Package successfully created! ====\n" 86 | putStrLn "Type the following command to go into your package:\n" 87 | putStrLn (" cd " ++ packageName ++ "\n") 88 | 89 | getPurse :: IO Purse 90 | getPurse = do 91 | compilerVersion' <- readProcess "keli" ["version"] [] 92 | gitVersion <- readProcess "git" ["--version"] [] 93 | nodeVersion <- readProcess "node" ["--version"] [] 94 | 95 | return Purse { 96 | os = SysInfo.os, 97 | arch = SysInfo.arch, 98 | compiler = init compilerVersion', -- init is used for removing the last newline character 99 | node = init nodeVersion, 100 | git = init gitVersion, 101 | dependencies = [] 102 | 103 | } 104 | 105 | defaultPursePath :: String 106 | defaultPursePath = "./_src/purse.json" 107 | 108 | readPurse :: String -> IO (Maybe Purse) 109 | readPurse pursePath = do 110 | purseFileExist <- doesPathExist pursePath 111 | if purseFileExist then do 112 | contents <- readFile pursePath 113 | return ((decode (Char8.pack contents)) :: Maybe Purse) 114 | else do 115 | hPutStrLn stderr ("Cannot locate the file named " ++ pursePath ++ ". Make sure you are in the package root.") 116 | return Nothing 117 | 118 | 119 | addDependency :: String -> String -> IO() 120 | addDependency gitRepoUrl tag = do 121 | let newDep = Dependency gitRepoUrl tag 122 | case toGitRepoUrl newDep of 123 | Left err -> 124 | hPutStrLn stderr (show err) 125 | Right{} -> do 126 | result <- readPurse defaultPursePath 127 | case result of 128 | Just purse -> do 129 | let prevDeps = dependencies purse 130 | if newDep `elem` prevDeps then 131 | hPutStrLn stderr $ "The dependency you intended to add is already added previously." 132 | else do 133 | let newPurse = purse {dependencies = prevDeps ++ [newDep]} 134 | putStrLn "Updating `dependencies` of `./_src/purse.json`" 135 | writeFile defaultPursePath (Char8.unpack (encodePretty newPurse)) 136 | installDeps defaultPursePath 137 | 138 | Nothing -> 139 | hPutStrLn stderr $ 140 | "Error:couldn't parse `./_src/purse.json`\n" ++ 141 | "Make sure it is in the correct format, " ++ 142 | "as defined at https://keli-language.gitbook.io/doc/specification/section-8-packages#8-4-manifest-file" 143 | 144 | installDeps :: String -> IO() 145 | installDeps pursePath = do 146 | putStrLn ("\nInstalling dependencies, referring: " ++ pursePath) 147 | result <- readPurse pursePath 148 | case result of 149 | Nothing -> 150 | return () 151 | 152 | Just purse -> do 153 | let parseResults = map toGitRepoUrl (dependencies purse) 154 | let errors = lefts parseResults 155 | case errors of 156 | -- if no parse errors 157 | [] -> do 158 | let grurls = rights parseResults 159 | !_ <- forM 160 | grurls 161 | (\u -> do 162 | let targetFolderName = authorName u ++ "." ++ repoName u ++ "." ++ tagString u 163 | alreadyDownloaded <- doesPathExist targetFolderName 164 | if alreadyDownloaded then 165 | -- skip the download for this grurl 166 | return () 167 | else do 168 | putStrLn ("\n-- Installing " ++ targetFolderName ++ "\n") 169 | !_ <- clonePackage u targetFolderName 170 | return()) 171 | 172 | putStrLn ("Dependencies installation completed for " ++ pursePath) 173 | 174 | -- if there are parse errors 175 | errors' -> do 176 | -- display parse errors 177 | !_ <- forM errors' (\e -> hPutStrLn stderr (show e)) 178 | return () 179 | 180 | 181 | clonePackage :: GitRepoUrl -> String -> IO() 182 | clonePackage u targetFolderName = do 183 | !_ <- 184 | readProcess 185 | "git" 186 | [ "clone", "-b", tagString u, "--single-branch", "--depth", "1", fullUrl u, targetFolderName, 187 | "-c", "advice.detachedHead=false"] -- this line is to silent all the stuff from git clone 188 | [] 189 | 190 | -- restructure the folder 191 | -- luckily, `mv` command works on both Windows and Linux 192 | sourceFiles <- listDirectory (targetFolderName ++ "/_src") 193 | 194 | exitCodes <- forM sourceFiles 195 | (\name -> do 196 | mvHandle <- spawnProcess "mv" [targetFolderName ++ "/_src/" ++ name, targetFolderName] 197 | waitForProcess mvHandle) 198 | 199 | -- if some files cannot be moved 200 | if any (\e -> case e of ExitFailure{}->True; _->False) exitCodes then 201 | hPutStrLn stderr ("Error unpacking files from _src.") 202 | else do 203 | -- remove unneeded files 204 | removeDirIfExists (targetFolderName ++ "/_src") 205 | removeDirIfExists (targetFolderName ++ "/_test") 206 | removeDirIfExists (targetFolderName ++ "/_.git") 207 | 208 | -- install its dependencies 209 | installDeps (targetFolderName ++ "/purse.json") 210 | return () 211 | 212 | removeDirIfExists :: FilePath -> IO() 213 | removeDirIfExists path = do 214 | yes <- doesPathExist path 215 | if yes then 216 | removeDirectoryRecursive path 217 | else 218 | return () 219 | 220 | data GitRepoUrl = GitRepoUrl { 221 | fullUrl :: String, 222 | authorName :: String, 223 | repoName :: String, 224 | tagString :: String 225 | } 226 | 227 | toGitRepoUrl :: Dependency -> Either ParseError GitRepoUrl 228 | toGitRepoUrl dep = parse parser "" (url dep) 229 | where 230 | parser :: Parser GitRepoUrl 231 | parser = 232 | (string "https://github.com/" <|> string "https://gitlab.com/") >>= \_ 233 | -> manyTill anyChar (char '/') >>= \authorName' 234 | -> manyTill anyChar (string ".git") >>= \repoName' 235 | -> return (GitRepoUrl (url dep) authorName' repoName' (tag dep)) -------------------------------------------------------------------------------- /src/Transpiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Transpiler 3 | where 4 | 5 | import Prelude hiding (id) 6 | import Data.List 7 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 8 | import Text.ParserCombinators.Parsec.Pos 9 | import Data.Char 10 | import Diagnostics 11 | 12 | import qualified Ast.Verified as V 13 | import Module 14 | 15 | prefix :: String -> String 16 | prefix s = "k$" ++ s -- k means Keli, this is to prevent conflicts with other JS libraries 17 | 18 | transpileModule 19 | :: Bool -- isEntryFile 20 | -> Bool -- showLineNumber 21 | -> Module 22 | -> String 23 | transpileModule isEntryFile showLineNumber (Module name _ importedModules _ decls) = 24 | "const " 25 | ++ prefix name 26 | ++ "=(()=>{" 27 | ++ transpiledModules 28 | ++ transpiledDecls 29 | ++ "return{" ++ exports ++ "}})();" 30 | where 31 | transpiledModules = 32 | concatMap (transpileModule False showLineNumber) (importedModules) 33 | 34 | transpiledDecls = 35 | let !decls' = 36 | if isEntryFile then 37 | decls 38 | else -- remove all idless decls, accoding to specification 39 | filter (\d -> case d of V.IdlessDecl _ -> False; _ -> True) decls in 40 | (intercalate ";" (map (transpile showLineNumber) (decls'))) ++ ";" 41 | 42 | exports = 43 | intercalate "," ( 44 | concatMap 45 | (\d -> 46 | case d of 47 | V.ConstDecl (_,id) _ -> 48 | [prefix id] 49 | V.FuncDecl signature _ -> 50 | [getFuncName signature] 51 | 52 | V.TaggedUnionDecl (V.TaggedUnion (_,name') _ _ _) -> 53 | [prefix name'] 54 | 55 | _ -> 56 | []) 57 | decls) 58 | 59 | 60 | 61 | class Transpilable a where 62 | transpile 63 | :: Bool -- show line number 64 | -> a 65 | -> String 66 | 67 | quote :: String -> String 68 | quote s = "\"" ++ s ++ "\"" 69 | 70 | squareBracket :: String -> String 71 | squareBracket s = "[" ++ s ++ "]" 72 | 73 | instance Transpilable V.Tag where 74 | transpile _ tag = case tag of 75 | V.CarrylessTag (_,id) (V.TaggedUnion (_,name) _ _ _) -> 76 | quote id ++ ":({__union:\"" ++ name ++ "\",__tag:\"" ++ id ++ "\"})" 77 | 78 | V.CarryfulTag (_,id) _ (V.TaggedUnion (_,name) _ _ _) -> 79 | quote id ++ ":(__carry)=>({__union:\"" ++ name ++ "\",__tag:\"" ++ id ++ "\",__carry})" 80 | 81 | joinIds :: [V.StringToken] -> String 82 | joinIds ids = intercalate "_" (map snd ids) 83 | 84 | instance Transpilable V.Decl where 85 | transpile showLineNumber decl = 86 | case decl of 87 | V.ConstDecl (_, id) expr -> 88 | "const " ++ prefix id ++ "=" ++ (transpile False expr) 89 | 90 | V.IdlessDecl expr -> 91 | let lineNumber = line (start (getRange expr)) in 92 | if showLineNumber then 93 | "console.log(" ++ "\"Line " ++ show (lineNumber + 1) ++ " = \"+" ++ 94 | "KELI$show(" ++ transpile False expr ++ "))" 95 | else 96 | "console.log(KELI$show(" ++ transpile False expr ++ "))" 97 | 98 | V.FuncDecl signature body -> 99 | transpile False signature ++ "(" ++ transpile showLineNumber body ++ ");" 100 | 101 | V.TaggedUnionDecl (V.TaggedUnion (_,id) _ tags _) -> 102 | "const " ++ prefix id ++ "={" ++ intercalate "," (map (transpile showLineNumber) tags) ++ "}" 103 | 104 | V.ObjectAliasDecl{} -> 105 | "" 106 | 107 | 108 | instance Transpilable V.Scope where 109 | transpile _ scope = 110 | case scope of 111 | V.FromCurrentScope -> 112 | "" 113 | 114 | V.FromImports modulename -> 115 | prefix modulename ++ "." 116 | 117 | 118 | instance Transpilable V.FuncSignature where 119 | transpile _ f@(V.FuncSignature _ _ params _ _) = 120 | let params' = intercalate "," (map (\((_,id),_) -> prefix id) params) in 121 | "const " ++ getFuncName f ++ "=(" ++ params' ++ ")=>" 122 | 123 | instance Transpilable V.Expr where 124 | transpile _ expr = case expr of 125 | V.Expr(V.IntExpr (_,value)) _ 126 | -> show value 127 | 128 | V.Expr(V.DoubleExpr (_, value)) _ 129 | -> show value 130 | 131 | V.Expr(V.StringExpr (_,value)) _ 132 | -> show value 133 | 134 | V.Expr(V.GlobalId _ (_, id) scope) _ 135 | -> transpile False scope ++ prefix id 136 | 137 | V.Expr(V.LocalId _ (_, id)) _ 138 | -> prefix id 139 | 140 | V.Expr(V.Lambda ((_, paramId),_) body) _ 141 | -> "(" ++ prefix paramId ++ ")=>(" ++ transpile False body ++ ")" 142 | 143 | V.Expr(V.Object kvs) _ 144 | -> transpileKeyValuePairs False kvs 145 | 146 | V.Expr(V.ObjectGetter expr prop) _ 147 | -> transpile False expr ++ "." ++ (snd prop) 148 | 149 | V.Expr(V.ObjectSetter subject prop newValue) _ 150 | -> "({...(" ++ transpile False subject ++ ")," ++ (snd prop) 151 | ++ ":(" ++ transpile False newValue ++ ")})" 152 | 153 | V.Expr (V.ObjectLambdaSetter subject (_,prop) (_, lambdaParamId) lambdaBody) _ 154 | -> 155 | "({...(" ++ transpile False subject ++ ")," 156 | ++ prop ++ ":(" 157 | ++ "((" ++ prefix lambdaParamId ++ ")=>(" 158 | ++ transpile False lambdaBody ++ "))" 159 | ++ "((" ++ transpile False subject ++ ")." ++ prop ++ ")" 160 | ++ ")})" 161 | 162 | 163 | V.Expr(V.TagMatcher subject branches elseBranch) _ 164 | -> 165 | -- We will need to implement lazy evaluation here, as JavaScript is strict 166 | -- Also, lazy evaluation is needed to prevent evaluating unentered branch 167 | "(($$=>({" ++ intercalate "," (map (transpile False) branches) 168 | ++ "})[$$.__tag])(" ++ transpile False subject ++ ")" 169 | ++ (case elseBranch of 170 | Just expr' -> " || " ++ "(" ++ (lazify (transpile False expr')) ++ ")" 171 | Nothing -> "") ++ ")()" 172 | 173 | V.Expr(V.FuncCall params _ (scope,ref)) _ -> 174 | transpile False scope ++ getFuncName ref ++ "(" ++ intercalate "," (map (transpile False) params) ++")" 175 | 176 | V.Expr(V.FFIJavascript (_,code)) _ -> 177 | code 178 | 179 | V.Expr 180 | (V.CarryfulTagExpr (_,taggedUnionName) (_,tag) carry scope) _ 181 | -> transpile False scope 182 | ++ prefix taggedUnionName ++ squareBracket (quote tag) 183 | ++ "("++ transpile False carry ++")" 184 | 185 | V.Expr 186 | (V.CarrylessTagExpr (_,taggedUnionName) (_,tag) _ scope) _ 187 | -> transpile False scope ++ prefix taggedUnionName ++ squareBracket (quote tag) 188 | 189 | V.Expr (V.FuncApp f arg) _ -> 190 | transpile False f ++ "(" ++ transpile False arg ++ ")" 191 | 192 | 193 | V.Expr (V.Array exprs _) _ -> 194 | "[" ++ intercalate "," (map (transpile False) exprs) ++ "]" 195 | 196 | other -> 197 | error (show other) 198 | 199 | instance Transpilable V.TagBranch where 200 | transpile _ b = case b of 201 | V.CarrylessTagBranch (V.VerifiedTagname (_,tagname)) expr -> 202 | tagname ++ ":" ++ lazify (transpile False expr) 203 | 204 | V.CarryfulTagBranch (V.VerifiedTagname (_,tagname)) (_,binding) expr -> 205 | tagname ++ ":" ++ lazify( "((" ++ prefix binding ++ ")=>" ++ transpile False expr ++ ")($$.__carry)" ) 206 | 207 | 208 | transpileKeyValuePairs :: Bool -> [(V.StringToken, V.Expr)] -> String 209 | transpileKeyValuePairs lazifyExpr kvs 210 | = "({" ++ (foldl' (\acc (key,expr) -> acc ++ snd key ++ ":" 211 | ++ (if lazifyExpr then lazify (transpile False expr) else (transpile False expr)) 212 | ++ ",") "" kvs) ++ "})" 213 | 214 | 215 | lazify :: String -> String 216 | lazify str = "()=>(" ++ str ++ ")" 217 | 218 | -- Each function identifier shall follows the following format: 219 | -- 220 | -- $$ 221 | -- id1$id2$id3$$hash 222 | -- 223 | -- where is function names and is the hash 224 | -- hash is the line number of where the first funcId is defined 225 | -- 226 | -- Example: 227 | -- this:String.replace old:String with new:String | String = undefined 228 | -- Shall have id of 229 | -- replace$with$$1 230 | -- 231 | -- This format is necessary, so that when we do function lookup, 232 | -- we can still construct back the function details from its id when needed 233 | -- especially when looking up generic functions 234 | getFuncName :: V.FuncSignature -> String 235 | getFuncName (V.FuncSignature{V.funcDeclIds=ids}) = 236 | let hash = sourceLine (fst (head ids)) in 237 | intercalate "$" (map (toValidJavaScriptId . snd) ids) ++ "$$" ++ show hash 238 | 239 | -- Basically, this function will convert all symbols to its corresponding ASCII code 240 | -- e.g. toValidJavaScriptId "$" = "k$36" 241 | toValidJavaScriptId :: String -> String 242 | toValidJavaScriptId s = prefix (concatMap (\x -> if (not . isAlphaNum) x then show (ord x) else [x]) s) -------------------------------------------------------------------------------- /src/Ast/Verified.hs: -------------------------------------------------------------------------------- 1 | module Ast.Verified where 2 | 3 | import Prelude hiding (id) 4 | import Text.Parsec.Pos 5 | import Data.List 6 | -- import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 7 | import qualified Ast.Raw as Raw 8 | 9 | type StringToken = (SourcePos, String) 10 | 11 | nullStringToken :: StringToken 12 | nullStringToken = (newPos "" (-1) (-1), "null") 13 | 14 | newStringToken :: String -> StringToken 15 | newStringToken value = (newPos "" (-1) (-1), value) 16 | 17 | newStringToken' :: (Int,Int,String) -> StringToken 18 | newStringToken' (line,col,value) = (newPos "" line col, value) 19 | 20 | data Scope 21 | = FromCurrentScope 22 | | FromImports 23 | String -- imporeted module name 24 | deriving (Show) 25 | 26 | 27 | data Decl 28 | = ConstDecl 29 | StringToken 30 | Expr 31 | 32 | | FuncDecl 33 | FuncSignature -- function signature 34 | Expr -- function body 35 | 36 | | IdlessDecl 37 | Expr 38 | 39 | | ObjectAliasDecl 40 | StringToken 41 | [(StringToken, TypeAnnotation)] 42 | 43 | | TaggedUnionDecl 44 | TaggedUnion 45 | deriving (Show) 46 | 47 | -- Func means the signature of a function 48 | data FuncSignature = FuncSignature { 49 | funcDeclDocString :: Maybe String, 50 | funcDeclGenericParams :: [Type], -- all should be BoundedTypeVar 51 | funcDeclParams :: [(StringToken, TypeAnnotation)], 52 | funcDeclIds :: [StringToken], 53 | funcDeclReturnType :: Type 54 | } deriving (Show) 55 | 56 | 57 | data TypeAnnotation 58 | = TypeAnnotSimple 59 | StringToken -- name 60 | Type -- ref 61 | 62 | | TypeAnnotCompound 63 | StringToken -- constructor name 64 | [(StringToken, TypeAnnotation)] -- key-type pairs 65 | Type -- ref 66 | 67 | | TypeAnnotObject 68 | [(StringToken, TypeAnnotation)] -- key-type pairs 69 | deriving (Show) 70 | 71 | getTypeRef :: TypeAnnotation -> Type 72 | getTypeRef x = case x of 73 | TypeAnnotSimple _ t -> t 74 | TypeAnnotCompound _ _ t -> t 75 | TypeAnnotObject propTypeAnnotPairs -> 76 | TypeObject Nothing (map (\(k, typeAnnot) -> (k, getTypeRef typeAnnot)) propTypeAnnotPairs) 77 | 78 | data Type 79 | = TypeFloat 80 | | TypeInt 81 | | TypeString 82 | | TypeObject 83 | (Maybe StringToken) -- associated name 84 | [(StringToken, Type)] -- prop-type pairs 85 | -- TODO: implement generic object 86 | -- (Maybe TypeParams) -- type params 87 | 88 | 89 | | TypeTaggedUnion TaggedUnion 90 | 91 | | TypeUndefined 92 | 93 | | TypeObjectConstructor 94 | (Maybe StringToken) -- object type alias name 95 | [(StringToken, Type)] -- expected key-type pairs 96 | 97 | | TypeTagConstructorPrefix 98 | StringToken -- name 99 | [Tag] -- available tags 100 | [Type] -- type params 101 | Scope 102 | 103 | | TypeTypeParam StringToken (Maybe TypeConstraint) 104 | | TypeType -- type of type 105 | 106 | | TypeSelf -- for defining recursive type 107 | 108 | | TypeTypeConstructor TaggedUnion 109 | 110 | | FreeTypeVar String (Maybe TypeConstraint) 111 | 112 | | BoundedTypeVar StringToken (Maybe TypeConstraint) 113 | 114 | 115 | data TaggedUnion = 116 | TaggedUnion 117 | StringToken -- name (name is compulsory, meaning that user cannot create anonymous tagged union) 118 | [StringToken] -- ids 119 | [Tag] -- list of tags 120 | [Type] -- type params 121 | 122 | instance Show TaggedUnion where 123 | show (TaggedUnion (_,name) ids tags typeParams) = 124 | "*taggedunion{"++name++","++concat (map show typeParams) ++ "," ++ show (length tags) ++ "}" 125 | 126 | instance Show Type where 127 | show TypeFloat = "*float" 128 | show TypeInt = "*Int" 129 | show TypeString = "*String" 130 | show (TypeObject name _) = "*object:" ++ show name 131 | show (TypeUndefined) = "undefined" 132 | show (TypeObjectConstructor _ _) = undefined -- "*object constructorshow:" ++ show kvs 133 | show (TypeTypeParam name _) = "*type param:" ++ show name 134 | show TypeType = "*type type" 135 | show TypeSelf = "*self" 136 | show TypeTypeConstructor{} = "*type constructor" 137 | show (TypeTaggedUnion t) = show t 138 | show (FreeTypeVar name _) = "*freetypevar:" ++ name 139 | show (BoundedTypeVar name _) = "*boundedtypevar:" ++ snd name 140 | show (TypeTagConstructorPrefix{}) = "TypeTagConstructorPrefix" 141 | 142 | 143 | data TypeConstraint 144 | = ConstraintAny 145 | deriving (Show, Eq) 146 | 147 | data UnlinkedTag 148 | = UnlinkedCarrylessTag 149 | StringToken -- tag 150 | 151 | | UnlinkedCarryfulTag 152 | StringToken -- tag 153 | TypeAnnotation 154 | deriving (Show) 155 | 156 | data Tag 157 | = CarrylessTag 158 | StringToken -- tag 159 | TaggedUnion -- belonging type 160 | 161 | | CarryfulTag 162 | StringToken -- tag 163 | Type -- carry type 164 | TaggedUnion -- beloging type 165 | deriving (Show) 166 | 167 | tagnameOf :: Tag -> StringToken 168 | tagnameOf (CarrylessTag t _) = t 169 | tagnameOf (CarryfulTag t _ _) = t 170 | 171 | instance Eq Tag where 172 | (CarrylessTag t1 _) == (CarrylessTag t2 _) = t1 == t2 173 | (CarryfulTag t1 _ _) == (CarryfulTag t2 _ _) = t1 == t2 174 | _ == _ = False 175 | 176 | data Expr = 177 | Expr 178 | Expr' 179 | Type -- type of this expr 180 | deriving (Show) 181 | 182 | data Expr' 183 | = IntExpr (SourcePos, Integer) 184 | | DoubleExpr (SourcePos, Double) 185 | | StringExpr StringToken 186 | | Array [Expr] SourcePos 187 | | GlobalId -- for global constants 188 | StringToken -- actual usage 189 | StringToken -- reference (where is this id originally defined) 190 | Scope 191 | 192 | | LocalId -- for function and lambda parameters 193 | StringToken -- actual usage 194 | StringToken -- reference (where is this id originally defined) 195 | 196 | | FuncCall { 197 | funcCallParams :: [Expr], -- for transpilation 198 | funcCallIds :: [StringToken], -- for reporting error 199 | funcCallRef :: (Scope, FuncSignature) -- for transpilation 200 | } 201 | | FuncApp { 202 | funcAppFunc :: Expr, 203 | funcAppArg :: Expr 204 | } 205 | | PartiallyInferredLambda 206 | StringToken -- param 207 | Raw.Expr -- body 208 | 209 | 210 | | Lambda 211 | (StringToken, Type) -- param 212 | Expr -- body 213 | 214 | | Object { 215 | objectKeyValues :: [(StringToken, Expr)] 216 | } 217 | | ObjectGetter { 218 | objectGetterSubject :: Expr, 219 | objectGetterPropertyName :: StringToken 220 | } 221 | | ObjectSetter { 222 | objectSetterSubject :: Expr, 223 | objectSetterPropertyName :: StringToken, 224 | objectSetterNewValue :: Expr 225 | } 226 | | ObjectLambdaSetter 227 | Expr -- subject 228 | StringToken -- property name 229 | StringToken -- lambda param 230 | Expr -- lambda body 231 | 232 | | TagMatcher { 233 | tagMatcherSubject :: Expr, 234 | tagMatcherBranches :: [TagBranch], 235 | tagMatcherElseBranch :: Maybe Expr 236 | } 237 | | CarrylessTagExpr 238 | StringToken -- prefix (for highlighting error) 239 | StringToken -- where is it defined? 240 | StringToken -- where is it used? 241 | Scope 242 | 243 | | CarryfulTagExpr 244 | StringToken -- prefix (for highlighting error) 245 | StringToken -- tag name 246 | Expr -- carry expr 247 | Scope 248 | 249 | | CarryfulTagConstructor 250 | StringToken -- tag name 251 | TypeAnnotation -- expected carry type 252 | 253 | 254 | | ObjectConstructor 255 | (Maybe StringToken) -- object type alias name 256 | [(StringToken, Type)] 257 | 258 | | TagConstructorPrefix StringToken 259 | 260 | | TypeConstructorPrefix StringToken 261 | 262 | | FFIJavascript StringToken 263 | 264 | deriving (Show) 265 | 266 | data VerifiedTagname = VerifiedTagname StringToken 267 | deriving (Show) 268 | 269 | data TagBranch 270 | = CarrylessTagBranch 271 | VerifiedTagname -- tag name 272 | Expr 273 | 274 | | CarryfulTagBranch 275 | VerifiedTagname -- tag name 276 | StringToken -- binding 277 | Expr 278 | 279 | | ElseBranch 280 | Expr 281 | deriving (Show) 282 | 283 | stringifyType :: Type -> String 284 | stringifyType t = case t of 285 | TypeFloat -> "Float" 286 | TypeInt -> "Int" 287 | TypeString -> "String" 288 | TypeObject name propTypePairs -> 289 | case name of 290 | Just n -> 291 | snd n 292 | Nothing -> 293 | "object." ++ 294 | intercalate " " 295 | (map (\((_,prop),type') -> 296 | prop ++ "(" ++ stringifyType type' ++ ")") 297 | propTypePairs) 298 | 299 | TypeTypeParam _ _ -> "" 300 | TypeType -> "Type" 301 | TypeTaggedUnion (TaggedUnion name ids _ innerTypes) -> 302 | let tailPart = intercalate " " (map (\((_,id), t') -> id ++ "(" ++ stringifyType t' ++ ")") (zip ids innerTypes)) in 303 | snd name ++ (if length ids > 0 then "." ++ tailPart else "") 304 | 305 | BoundedTypeVar name _ -> snd name 306 | FreeTypeVar name _ -> name 307 | TypeUndefined -> "Undefined" 308 | _ -> error (show t) 309 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC #-} 3 | 4 | module Parser where 5 | 6 | import Prelude hiding (id) 7 | 8 | import qualified Ast.Raw as Raw 9 | 10 | import Lexer 11 | 12 | import Text.Parsec.Pos 13 | import StaticError 14 | import Text.ParserCombinators.Parsec hiding (token) 15 | import Text.ParserCombinators.Parsec.Expr 16 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 17 | import Text.ParserCombinators.Parsec.Error 18 | import Data.List 19 | 20 | keliParser :: Parser [Raw.Decl] 21 | keliParser = whiteSpace >> keliDecl 22 | 23 | keliDecl :: Parser [Raw.Decl] 24 | keliDecl = do 25 | list <- (many1 keliDecl') 26 | eof 27 | return list 28 | 29 | keliDecl' :: Parser Raw.Decl 30 | keliDecl' 31 | = try keliFuncDecl 32 | <|> try keliGenericTypeDecl 33 | <|> keliConstDecl 34 | 35 | keliConstDecl :: Parser Raw.Decl 36 | keliConstDecl 37 | = optionMaybe (keliFuncId) >>= \token 38 | -> getPosition >>= \pos 39 | -> reservedOp "=" >>= \_ 40 | -> keliExpr >>= \expr 41 | -> case token of 42 | Just t -> return (Raw.ConstDecl (Raw.Const t expr)) 43 | Nothing -> return (Raw.IdlessDecl pos expr) 44 | 45 | keliExpr :: Parser Raw.Expr 46 | keliExpr 47 | = try keliIncompleteFuncCall 48 | <|> keliExpr' 49 | 50 | keliExpr' :: Parser Raw.Expr 51 | keliExpr' 52 | = try keliFuncCall 53 | <|> try keliLambda 54 | <|> try keliLambdaShortHand 55 | <|> keliAtomicExpr 56 | 57 | keliIncompleteFuncCall :: Parser Raw.Expr 58 | keliIncompleteFuncCall 59 | = (try 60 | keliExpr' >>= \param1 61 | -> getPosition >>= \pos 62 | -> char ';' >> spaces >>= \_ 63 | -> return (Raw.IncompleteFuncCall param1 pos)) 64 | <|> 65 | (-- for lambda shorthand 66 | getPosition >>= \pos 67 | -> char ';' >>= \_ 68 | -> 69 | let lambdaParam = generateLambdaParamName pos in 70 | let lambdaBody = Raw.IncompleteFuncCall (Raw.Id lambdaParam) pos in 71 | return (Raw.Lambda lambdaParam lambdaBody True)) 72 | 73 | 74 | 75 | keliFuncCall :: Parser Raw.Expr 76 | keliFuncCall 77 | = keliAtomicExpr >>= \param1 78 | -> char '.' >> spaces >>= \_ 79 | -> keliFuncCallTail >>= \chain 80 | -> case param1 of 81 | -- if user is declaring tagged union 82 | Raw.Id token@(_,"choice") -> 83 | return (Raw.TaggedUnion token (flattenFuncCallChain chain)) 84 | 85 | -- otherwise 86 | _ -> 87 | return (convertFuncCallChainToFuncCall chain param1) 88 | 89 | keliLambda :: Parser Raw.Expr 90 | keliLambda 91 | = keliFuncId >>= \param 92 | -> reservedOp "|" >>= \_ 93 | -> keliExpr >>= \expr 94 | -> return (Raw.Lambda param expr False) 95 | 96 | keliLambdaShortHand :: Parser Raw.Expr 97 | keliLambdaShortHand 98 | = getPosition >>= \pos 99 | -> char '.' >> spaces >>= \_ 100 | -> keliFuncCallTail >>= \chain 101 | -> 102 | let autoGeneratedLambaParam = generateLambdaParamName pos in 103 | let lambdaBody = convertFuncCallChainToFuncCall chain (Raw.Id autoGeneratedLambaParam) in 104 | return (Raw.Lambda autoGeneratedLambaParam lambdaBody True) 105 | 106 | generateLambdaParamName :: SourcePos -> Raw.StringToken 107 | generateLambdaParamName pos = 108 | -- example, $0$3 109 | (pos, "$" ++ show (sourceLine pos) ++ "$" ++ show (sourceColumn pos)) 110 | 111 | data KeliFuncCallChain 112 | = KeliFuncCallChain KeliFuncCallChain KeliFuncCallChain 113 | | KeliPartialFuncCall { 114 | partialFuncCallIds :: [Raw.StringToken], 115 | partialFuncCallParams :: [Raw.Expr] 116 | } 117 | 118 | convertFuncCallChainToFuncCall 119 | :: KeliFuncCallChain 120 | -> Raw.Expr 121 | -> Raw.Expr -- subject expr, e.g., in `123.square` , `123` is the subject 122 | 123 | convertFuncCallChainToFuncCall chain subject = 124 | let pairs = flattenFuncCallChain chain in 125 | let firstChain = head pairs in 126 | let remainingChain = tail pairs in 127 | (foldl' 128 | (\acc next -> (Raw.FuncCall (acc : Raw.funcCallParams next) (Raw.funcCallIds next))) -- reducer 129 | (Raw.FuncCall (subject:(snd firstChain)) (fst firstChain)) -- initial value 130 | (map (\(funcIds,params) -> Raw.FuncCall params funcIds) remainingChain) -- foldee 131 | ) 132 | 133 | type FuncCallTail = ([Raw.StringToken], [Raw.Expr]) 134 | flattenFuncCallChain :: KeliFuncCallChain -> [FuncCallTail] 135 | flattenFuncCallChain (KeliFuncCallChain x y) = (flattenFuncCallChain x ++ flattenFuncCallChain y) 136 | flattenFuncCallChain (KeliPartialFuncCall ids params) = [(ids, params)] 137 | 138 | 139 | 140 | keliFuncCallTail :: Parser KeliFuncCallChain 141 | keliFuncCallTail 142 | = buildExpressionParser [[Infix (char '.' >> spaces >> return KeliFuncCallChain) AssocLeft]] keliPartialFuncCall 143 | 144 | 145 | keliPartialFuncCall 146 | -- binary/ternary/polynary 147 | = try ((many1 $ try ( 148 | keliFuncId >>= \token 149 | -- -> notFollowedBy (reservedOp "=") >>= \_ 150 | -> parens keliExpr >>= \expr 151 | -> return (token, expr) 152 | )) >>= \pairs 153 | -> return (KeliPartialFuncCall (map fst pairs) (map snd pairs)) 154 | ) 155 | -- unary 156 | <|> ( 157 | keliFuncId >>= \token 158 | -> return (KeliPartialFuncCall [token] [])) 159 | 160 | keliAtomicExpr :: Parser Raw.Expr 161 | keliAtomicExpr 162 | = parens keliExpr 163 | <|> (getPosition >>= \pos -> arrayLit >>= \(pos,exprs) -> return (Raw.Array exprs pos)) 164 | <|> (getPosition >>= \pos -> try float >>= \n 　-> return (Raw.NumberExpr (pos, Right n))) 165 | <|> (getPosition >>= \pos -> try natural >>= \n 　-> return (Raw.NumberExpr (pos, Left n))) 166 | <|> (getPosition >>= \pos -> stringLit >>= \str 　-> return (Raw.StringExpr (pos, str))) 167 | <|> ( keliFuncId >>= \id 　-> return (Raw.Id id)) 168 | 169 | arrayLit :: Parser (SourcePos, [Raw.Expr]) 170 | arrayLit 171 | = between 172 | (symbol "[") 173 | (symbol "]") 174 | (keliExpr `sepBy` (symbol ",")) >>= \exprs -> 175 | 176 | getPosition >>= \pos -> 177 | return (pos, exprs) 178 | 179 | 180 | stringLit :: Parser String 181 | stringLit 182 | = try multilineString 183 | <|> singlelineString 184 | 185 | 186 | multilineString :: Parser String 187 | multilineString 188 | = string "\"\"\"" >>= \_ 189 | -> manyTill anyChar (try (string "\"\"\"" >> whiteSpace)) 190 | "end of multiline string literal" 191 | 192 | 193 | keliFuncDecl :: Parser Raw.Decl 194 | keliFuncDecl 195 | = try keliPolyFuncDecl 196 | <|> keliMonoFuncDecl 197 | 198 | keliMonoFuncDecl :: Parser Raw.Decl 199 | keliMonoFuncDecl 200 | = optionMaybe stringLit >>= \docstring 201 | -> keliGenericParams >>= \genparams 202 | -> keliFuncDeclParam >>= \param 203 | -> char '.' >> spaces >>= \_ 204 | -> keliFuncId >>= \token 205 | -> keliFuncReturnType >>= \typeExpr 206 | -> reservedOp "=" >>= \_ 207 | -> keliExpr >>= \expr 208 | -> return (Raw.FuncDecl (Raw.Func docstring (unpackMaybe genparams) [param] [token] typeExpr expr)) 209 | 210 | keliPolyFuncDecl :: Parser Raw.Decl 211 | keliPolyFuncDecl 212 | = optionMaybe stringLit >>= \docstring 213 | -> keliGenericParams >>= \genparams 214 | -> keliFuncDeclParam >>= \param1 215 | -> char '.' >> spaces >>= \_ 216 | -> keliIdParamPair >>= \xs 217 | -> keliFuncReturnType >>= \typeExpr 218 | -> reservedOp "=" >>= \_ 219 | -> keliExpr >>= \expr 220 | -> return (Raw.FuncDecl (Raw.Func docstring (unpackMaybe genparams) (param1:(map snd xs)) (map fst xs) typeExpr expr)) 221 | 222 | keliGenericTypeDecl :: Parser Raw.Decl 223 | keliGenericTypeDecl 224 | = getPosition >>= \typenamePos 225 | -> identifier >>= \typename 226 | -> char '.' >> spaces >>= \_ 227 | -> keliIdParamPair >>= \idParamPairs 228 | -> keliFuncReturnType >>= \typeExpr 229 | -> reservedOp "=" >>= \_ 230 | -> keliExpr >>= \expr 231 | -> return (Raw.GenericTypeDecl (typenamePos, typename) (map fst idParamPairs) (map snd idParamPairs) expr) 232 | 233 | keliFuncReturnType :: Parser (Maybe Raw.Expr) 234 | keliFuncReturnType = 235 | optionMaybe ( 236 | reservedOp "|" >>= \_ 237 | -> keliExpr >>= \typeExpr 238 | -> optionMaybe stringLit >>= \_ 239 | -> return typeExpr) 240 | 241 | unpackMaybe :: Maybe [a] -> [a] 242 | unpackMaybe (Just x) = x 243 | unpackMaybe Nothing = [] 244 | 245 | 246 | braces = between (symbol "{") (symbol "}") 247 | keliGenericParams :: Parser (Maybe [Raw.FuncDeclConstraint]) 248 | keliGenericParams 249 | = optionMaybe $ many1 $ (braces keliFuncDeclParam' >>= \param -> return param) 250 | 251 | 252 | keliIdParamPair = 253 | many1 ( 254 | keliFuncId >>= \token 255 | -> keliFuncDeclParam >>= \param 256 | -> return (token, param)) 257 | 258 | keliFuncId = 259 | getPosition >>= \pos 260 | -> choice [identifier, operator] >>= \id 261 | -> return (pos, id) 262 | 263 | keliFuncDeclParam ::Parser (Raw.StringToken, Raw.Expr) 264 | keliFuncDeclParam = 265 | parens keliFuncDeclParam' >>= \params 266 | -> optionMaybe stringLit >>= \_ 267 | -> return params 268 | 269 | keliFuncDeclParam' ::Parser (Raw.StringToken, Raw.Expr) 270 | keliFuncDeclParam' 271 | = 272 | keliFuncId >>= \id 273 | -> keliExpr >>= \typeExpr 274 | -> return (id, typeExpr) 275 | 276 | preprocess :: String -> String 277 | preprocess str = str 278 | -- just in case we need it in the future: 279 | -- let packed = T.pack str in 280 | -- T.unpack (T.replace "\n\n" "\n;;;\n" packed) 281 | 282 | keliParse :: String -> String -> Either [KeliError] [Raw.Decl] 283 | keliParse filename input = 284 | case parse keliParser filename (preprocess input) of 285 | Right decls -> Right decls 286 | Left parseError -> Left [KErrorParseError (errorPos parseError) (Messages (errorMessages parseError))] 287 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright 2019 Wong Jia Hau 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /src/CompletionItems.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module CompletionItems where 4 | 5 | import GHC.Generics 6 | import Module 7 | import Parser 8 | import Data.Sequence(fromList, update, index) 9 | import Data.Aeson 10 | import Data.Foldable 11 | import Data.Char 12 | import Env 13 | import Data.List 14 | import Compiler 15 | import Analyzer 16 | import Util 17 | import qualified Data.List as List 18 | import qualified Ast.Raw as Raw 19 | import qualified Ast.Verified as V 20 | import TypeCheck 21 | import Prelude hiding(id) 22 | import StaticError(KeliError(KErrorIncompleteFuncCall)) 23 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 24 | import qualified Data.HashMap.Strict as HashMap 25 | 26 | 27 | import qualified Ast.Verified as V 28 | 29 | -- The interface is based on CompletionItem described in https://microsoft.github.io/language-server-protocol/specification 30 | 31 | data CompletionItem = CompletionItem { 32 | kind :: Int 33 | {- 34 | export declare namespace CompletionItemKind { 35 | const Text: 1; 36 | const Method: 2; 37 | const Function: 3; 38 | const Constructor: 4; 39 | const Field: 5; 40 | const Variable: 6; 41 | const Class: 7; 42 | const Interface: 8; 43 | const Module: 9; 44 | const Property: 10; 45 | const Unit: 11; 46 | const Value: 12; 47 | const Enum: 13; 48 | const Keyword: 14; 49 | const Snippet: 15; 50 | const Color: 16; 51 | const File: 17; 52 | const Reference: 18; 53 | const Folder: 19; 54 | const EnumMember: 20; 55 | const Constant: 21; 56 | const Struct: 22; 57 | const Event: 23; 58 | const Operator: 24; 59 | const TypeParameter: 25; 60 | } 61 | -}, 62 | label :: String, 63 | detail:: String, 64 | insertText :: String, -- text to be inserted if user chose this completion item 65 | insertTextFormat :: Int, -- 1 = Plain Text, 2 = Snippet 66 | -- For snippet format, refer https://github.com/Microsoft/vscode/blob/master/src/vs/editor/contrib/snippet/snippet.md 67 | 68 | documentation :: String 69 | } deriving (Show, Generic, Eq, Read) 70 | 71 | instance ToJSON CompletionItem where 72 | 73 | 74 | toCompletionItem ::KeliSymbol -> [CompletionItem] 75 | toCompletionItem symbol = 76 | case symbol of 77 | KeliSymLocalConst (_,id) _ -> 78 | [CompletionItem 6 id "Constant" id 1 ""] 79 | 80 | KeliSymGlobalConst (_, id) _ -> 81 | [CompletionItem 6 id "Constant" id 1 ""] 82 | 83 | KeliSymType t -> 84 | case t of 85 | -- if is object alias 86 | V.TypeObject (Just (_,id)) propTypePairs -> 87 | [CompletionItem { 88 | kind = 7, 89 | label = id, 90 | detail = "Object constructor", 91 | insertText = id 92 | ++ "." 93 | ++ makeKeyValuesSnippet (map (\(p,t') -> (snd p, V.stringifyType t')) propTypePairs), 94 | insertTextFormat = 2, 95 | documentation = "" }] 96 | 97 | 98 | _ -> 99 | let id = V.stringifyType t in 100 | [CompletionItem 7 id "Type" id 1 ""] 101 | 102 | KeliSymTaggedUnion (V.TaggedUnion (_,id) ids _ _) -> 103 | [CompletionItem 7 id "Tagged union type constructor" id 1 ""] 104 | 105 | KeliSymFunc funcs -> 106 | concatMap 107 | (\f -> 108 | let ids = V.funcDeclIds f in 109 | let funcParams = V.funcDeclParams f in 110 | let signature = (intercalate "() " (map snd ids)) in 111 | let label' = 112 | (if length funcParams > 1 then 113 | signature ++ "()" 114 | else 115 | signature) in 116 | 117 | let text = 118 | (if length funcParams == 1 then 119 | signature 120 | else 121 | makeKeyValuesSnippet (zip (map snd ids) (map (snd . fst) (tail funcParams)))) in 122 | [CompletionItem 3 123 | label' 124 | (rebuildSignature f) 125 | text 126 | 2 127 | (case V.funcDeclDocString f of Just doc -> doc; Nothing -> "")]) 128 | funcs 129 | 130 | makeKeyValuesSnippet :: [(String,String)] -> String 131 | makeKeyValuesSnippet kvs = 132 | intercalate " " 133 | (map 134 | (\((key, value), index') -> 135 | key ++ "(${" ++ show index' ++ ":" ++ value ++ "})") 136 | (zip kvs [1..])) 137 | 138 | 139 | rebuildSignature :: V.FuncSignature-> String 140 | rebuildSignature 141 | (V.FuncSignature _ genparams 142 | params@(firstParam:tailParams) 143 | funcIds@(firstFuncId:tailFuncIds) 144 | returnType) = 145 | let 146 | front = stringifyFuncParam firstParam ++ "." 147 | back = " | " ++ V.stringifyType returnType 148 | in 149 | if length tailFuncIds == 0 && length tailParams == 0 then 150 | front ++ snd firstFuncId ++ back 151 | else 152 | front ++ intercalate " " (map (\(funcId, param) -> snd funcId ++ stringifyFuncParam param) (zip funcIds (tail params))) ++ back 153 | 154 | 155 | 156 | stringifyFuncParam :: (V.StringToken, V.TypeAnnotation) -> String 157 | stringifyFuncParam ((_,paramName), paramTypeAnnot) = 158 | bracketize (paramName ++ " " ++ stringifyTypeAnnot paramTypeAnnot) 159 | 160 | stringifyTypeAnnot :: V.TypeAnnotation -> String 161 | stringifyTypeAnnot (V.TypeAnnotSimple (_,name) _) = name 162 | stringifyTypeAnnot (V.TypeAnnotCompound (_,name) keyTypeAnnotPairs _) = 163 | name ++ "." ++ intercalate " " (map (\(key, ta) -> snd key ++ "(" ++ stringifyTypeAnnot ta ++ ")") keyTypeAnnotPairs) 164 | stringifyTypeAnnot (V.TypeAnnotObject keyTypePairs) = 165 | "$." ++ intercalate " " (map (\(k,t) -> snd k ++ "(" ++ stringifyTypeAnnot t ++ ")") keyTypePairs) 166 | 167 | bracketize :: String -> String 168 | bracketize str = "(" ++ str ++ ")" 169 | 170 | suggestCompletionItemsAt 171 | :: String -- filename 172 | -> (Int,Int) -- (lineNumber, columnNumber) 173 | -> IO [CompletionItem] 174 | 175 | suggestCompletionItemsAt filename (lineNumber, columnNumber) = do 176 | contents <- readFile filename 177 | let lines' = lines contents 178 | let currentChar = lines' !! lineNumber !! columnNumber 179 | let modifiedContents = 180 | -- if the current character is a dot(.) 181 | -- replace it with semicolon(;) 182 | -- so that we can parse KeliIncompleteFuncCall properly 183 | if currentChar == '.' then 184 | let lines'' = fromList (map fromList lines') in 185 | let result = ( 186 | update 187 | -- at 188 | lineNumber 189 | 190 | -- with new value 191 | (update 192 | -- at 193 | columnNumber 194 | 195 | -- with new value 196 | ';' 197 | 198 | -- over 199 | (lines'' `index` lineNumber)) 200 | 201 | -- over 202 | lines'') in 203 | 204 | intercalate "\n" (map toList (toList (result))) 205 | else 206 | contents 207 | 208 | (errors, currentModule, _, _) <- keliCompile filename modifiedContents (HashMap.empty) [] 209 | case keliParse filename modifiedContents of 210 | Right decls -> 211 | let envs = [moduleEnv currentModule] ++ map moduleEnv (moduleImported currentModule) in 212 | let items = suggestCompletionItems envs errors in 213 | 214 | 215 | -- remove duplicates 216 | return (nubBy (\x y -> label x == label y) items) 217 | 218 | Left err -> 219 | return [] 220 | 221 | 222 | suggestCompletionItems :: [Env] -> [KeliError] -> [CompletionItem] 223 | suggestCompletionItems importedEnvs errors = 224 | let symbols = concatMap extractSymbols importedEnvs in 225 | case find (\e -> case e of KErrorIncompleteFuncCall{} -> True; _ -> False) errors of 226 | Just (KErrorIncompleteFuncCall thing positionOfDotOperator) -> 227 | -- suggest functions 228 | suggestCompletionItems' importedEnvs symbols (Just thing) 229 | 230 | _ -> 231 | -- suggest identifiers 232 | suggestCompletionItems' importedEnvs symbols Nothing 233 | 234 | 235 | -- suggest completion item based on `subjectExpr` 236 | suggestCompletionItems' :: [Env] -> [KeliSymbol] -> Maybe (OneOf3 V.Expr V.TypeAnnotation [V.UnlinkedTag]) -> [CompletionItem] 237 | suggestCompletionItems' importedEnvs symbols subjectExpr = case subjectExpr of 238 | -- if not triggered by pressing the dot operator 239 | Nothing -> 240 | -- then only return only non-functions identifiers 241 | concatMap 242 | toCompletionItem 243 | ((filter (\d -> case d of KeliSymFunc{} -> False; _ -> True) (symbols))) 244 | 245 | -- if is triggered by pressing the dot operator 246 | Just thing -> 247 | case thing of 248 | First expr -> 249 | let relatedFuncs = 250 | concatMap 251 | (\s -> 252 | case s of 253 | KeliSymFunc funcs -> 254 | concatMap 255 | (\f -> 256 | let (_,firstParamTypeAnnon) = V.funcDeclParams f !! 0 in 257 | -- instantiate type variables first 258 | let (_, subst) = instantiateTypeVar (Context 999 emptyEnv []) (V.funcDeclGenericParams f) in 259 | case unify (Context 0 (List.head importedEnvs) []) subst expr (applySubstitutionToType subst (V.getTypeRef firstParamTypeAnnon)) of 260 | Right _ -> 261 | [KeliSymFunc [f]] 262 | Left _ -> 263 | []) 264 | funcs 265 | _ -> 266 | []) 267 | symbols in 268 | 269 | let relatedFuncsCompletionItems = concatMap toCompletionItem relatedFuncs in 270 | 271 | case expr of 272 | -- tag constructor prefix 273 | V.Expr _ (V.TypeTagConstructorPrefix _ tags typeParams _) -> 274 | map 275 | (\t -> 276 | case t of 277 | V.CarryfulTag (_,tagname) (V.TypeObject _ propTypePairs) _ -> 278 | CompletionItem { 279 | kind = 13, -- enum 280 | label = tagname, 281 | detail = "", 282 | insertText = tagname 283 | ++ "($." 284 | ++ makeKeyValuesSnippet (map (\(p,t') -> (snd p, V.stringifyType t')) propTypePairs) 285 | ++ ")", 286 | insertTextFormat = 2, 287 | documentation = "" 288 | } 289 | 290 | V.CarryfulTag (_,tagname) otherType _ -> 291 | CompletionItem { 292 | kind = 13, -- enum 293 | label = tagname, 294 | detail = "", 295 | insertText = tagname ++ "(${1:" ++ V.stringifyType otherType ++ "})", 296 | insertTextFormat = 2, 297 | documentation = "" 298 | } 299 | 300 | V.CarrylessTag (_,tagname) _ -> 301 | CompletionItem { 302 | kind = 13, -- enum 303 | label = tagname, 304 | detail = "", 305 | insertText = tagname, 306 | insertTextFormat = 1, 307 | documentation = "" 308 | }) 309 | tags 310 | 311 | -- object constructor 312 | V.Expr _ (V.TypeObjectConstructor name propTypePairs) -> 313 | let text = concat (map (\((_,prop), t) -> prop ++ "(" ++ V.stringifyType t ++ ") ") propTypePairs) in 314 | [CompletionItem { 315 | kind = 4, -- constructor 316 | label = text, 317 | detail = "constructor", 318 | insertText = makeKeyValuesSnippet (map (\(p, t) -> (snd p, V.stringifyType t)) propTypePairs), 319 | insertTextFormat = 2, 320 | documentation = "" 321 | }] 322 | 323 | 324 | -- lambda 325 | V.Expr f (V.TypeTaggedUnion (V.TaggedUnion (_,"Function") _ _ _)) -> 326 | case f of 327 | V.Lambda ((_,paramName), _) lambdaBody -> 328 | -- If the paramName contains no alphabet, then it must be an auto-generated name 329 | -- implying that it is a lambda shorthand 330 | if all (not . isAlpha) paramName then 331 | -- is shorthand lambda 332 | -- this is kind of a hack, but it works 333 | -- give suggestion item based on the lambda body 334 | suggestCompletionItems' importedEnvs symbols (Just (First lambdaBody)) 335 | else 336 | defaultResult 337 | 338 | _ -> 339 | defaultResult 340 | 341 | where 342 | defaultResult = 343 | -- is normal lambda 344 | [CompletionItem { 345 | kind = 2, 346 | label = "apply", 347 | detail = "", 348 | insertText = "apply($1)", 349 | insertTextFormat = 2, 350 | documentation = "" 351 | }] 352 | 353 | -- tag matchers 354 | V.Expr _ (V.TypeTaggedUnion (V.TaggedUnion _ _ tags _)) -> 355 | let insertText' = intercalate "\n" $ 356 | map 357 | (\(t,index') -> "\n\t" ++ 358 | (case t of 359 | V.CarryfulTag (_,tagname@(firstChar:_)) _ _ -> 360 | "if(." ++ tagname ++ "(" ++ [toLower firstChar] ++ ")) then" ++ 361 | "\n\t\t(${" ++ show index' ++ ":undefined})" 362 | 363 | V.CarrylessTag (_,tagname) _ -> 364 | "if(." ++ tagname ++ ") then" ++ 365 | "\n\t\t(${" ++ show index' ++ ":undefined})")) 366 | (zip tags [1..]) in 367 | [CompletionItem { 368 | kind = 12, -- value 369 | label = "if(...)", 370 | detail = "tag matcher", 371 | insertText = insertText', 372 | insertTextFormat = 2, 373 | documentation = "" 374 | }] ++ relatedFuncsCompletionItems 375 | 376 | -- object (getter/setter) 377 | V.Expr _ (V.TypeObject _ propTypePairs) -> 378 | (concatMap 379 | (\((_,prop), expectedType') -> 380 | [CompletionItem { 381 | kind = 10, -- property 382 | label = prop, 383 | detail = "getter", 384 | insertText = prop, 385 | insertTextFormat = 1, 386 | documentation = "" 387 | }, 388 | CompletionItem { 389 | kind = 10, -- property 390 | label = prop ++ "()", 391 | detail = "setter", 392 | insertText = prop ++ "(${1:undefined})", 393 | insertTextFormat = 2, 394 | documentation = "" 395 | }]) 396 | propTypePairs) ++ relatedFuncsCompletionItems 397 | 398 | 399 | 400 | -- -- otherwise: scope related functions 401 | _ -> 402 | relatedFuncsCompletionItems 403 | 404 | Third tag -> 405 | [] 406 | 407 | _ -> 408 | [CompletionItem { 409 | kind = 1, 410 | label = "Gotcha", 411 | detail = "Declare a carryful tag.", 412 | insertText = "(tag.#(${1:tagName}) carry(${2:carryType}))", 413 | insertTextFormat = 1, 414 | documentation = "" 415 | }] 416 | 417 | -------------------------------------------------------------------------------- /src/Analyzer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | module Analyzer where 5 | 6 | import Text.Parsec.Pos 7 | import Control.Monad 8 | import Data.List hiding (lookup) 9 | import Data.Map.Ordered ((|>), assocs, member) 10 | import Debug.Pretty.Simple (pTraceShowId, pTraceShow) 11 | import Prelude hiding (lookup,id) 12 | 13 | import qualified Ast.Raw as Raw 14 | import qualified Ast.Verified as V 15 | import StaticError 16 | import Module 17 | import Env 18 | import TypeCheck 19 | import Util 20 | 21 | analyze :: [(ModuleName,Env)] -> [Raw.Decl] -> ([KeliError], Env, [V.Decl]) 22 | analyze importedEnvs decls = 23 | let (errors, env, analyzedDecls) = analyzeDecls importedEnvs emptyEnv decls in 24 | 25 | -- sorting is necessary, so that the transpilation order will be correct 26 | -- Smaller number means will be transpiled first 27 | let sortedDecls = sortOn ( 28 | \x -> case x of 29 | V.TaggedUnionDecl{} -> 1 30 | V.ObjectAliasDecl{} -> 2 31 | V.FuncDecl{} -> 3 32 | V.ConstDecl{} -> 4 33 | V.IdlessDecl{} -> 5 34 | ) (analyzedDecls) in 35 | 36 | (errors, env, sortedDecls) 37 | 38 | extractSymbols :: Env -> [KeliSymbol] 39 | extractSymbols env = map snd (assocs env) 40 | 41 | data TypeDecl = 42 | TypeDecl 43 | [V.StringToken] -- type signature 44 | V.Type -- type body 45 | 46 | analyzeDecls 47 | :: [(ModuleName,Env)] -- imported envs 48 | -> Env -- previous env 49 | -> [Raw.Decl] -- parsed input 50 | -> ([KeliError], Env, [V.Decl]) -- (accumulatedErrors, newEnv, symbols) 51 | 52 | analyzeDecls importedEnvs env rawDecls = 53 | let (errors, updatedEnv, _, analyzedDecls) = analyzeDecls' importedEnvs env rawDecls [] in 54 | (errors, updatedEnv, analyzedDecls) 55 | 56 | -- this function will perform multipassing 57 | -- so that declaration order will be insignificant 58 | analyzeDecls' 59 | :: [(ModuleName,Env)] -- imported envs 60 | -> Env -- current envs 61 | -> [Raw.Decl] -- input raw decls 62 | -> [V.Decl] -- previous verified decls 63 | -> 64 | ([KeliError], -- errors 65 | Env, -- updated env 66 | [Raw.Decl], -- declarations that failed to pass the type checker 67 | [V.Decl]) -- declarations that passed the type checker 68 | 69 | analyzeDecls' importedEnvs env inputRawDecls prevVerifiedDecls = 70 | let (currentErrors, updatedEnv, failedDecls, currentVerifiedDecls) = 71 | foldl' 72 | ((\(errors, prevEnv, prevFailedDecls, prevPassedDecls) currentRawDecl -> 73 | let (newErrors, newEnv, newFailedDecls, newPassedDecls) = 74 | -- Do partial analyzation (to get function signature (if it's a function)) 75 | case analyzeDecl currentRawDecl prevEnv importedEnvs of 76 | Right partiallyAnalyzedDecl -> 77 | 78 | -- add the function signature into env 79 | -- this is to allow recursive (even mutually recursive) functio to be type checked 80 | let updatedPrevEnv = 81 | case partiallyAnalyzedDecl of 82 | PaFuncDecl f _ _ -> 83 | insertSymbolIntoEnv (KeliSymFunc [f]) prevEnv 84 | 85 | _ -> 86 | Right prevEnv in 87 | 88 | case updatedPrevEnv of 89 | Right updatedPrevEnv' -> 90 | case analyzePaDecl partiallyAnalyzedDecl updatedPrevEnv' importedEnvs of 91 | Right analyzedDecl -> 92 | case toSymbol analyzedDecl of 93 | Just symbol -> 94 | case insertSymbolIntoEnv symbol prevEnv of 95 | Right newEnv' -> 96 | ([], newEnv', [], [analyzedDecl]) 97 | 98 | Left err' -> 99 | ([err'], updatedPrevEnv', [currentRawDecl], []) 100 | 101 | Nothing -> 102 | ([], updatedPrevEnv', [], [analyzedDecl]) 103 | 104 | Left err' -> 105 | ([err'], updatedPrevEnv', [currentRawDecl],[]) 106 | 107 | Left err' -> 108 | ([err'], prevEnv, [currentRawDecl],[]) 109 | 110 | Left err' -> 111 | ([err'], prevEnv, [currentRawDecl],[]) in 112 | 113 | (errors ++ newErrors, 114 | newEnv, 115 | prevFailedDecls ++ newFailedDecls, 116 | prevPassedDecls ++ newPassedDecls) 117 | )::([KeliError], Env, [Raw.Decl], [V.Decl]) -> Raw.Decl -> ([KeliError],Env, [Raw.Decl], [V.Decl])) 118 | ([], env, [], []) 119 | inputRawDecls in 120 | 121 | -- if the number of failedDecls had decreased, continue multipassing 122 | if length failedDecls < length inputRawDecls then 123 | -- note that the current errors will be ignored 124 | analyzeDecls' importedEnvs updatedEnv failedDecls (prevVerifiedDecls ++ currentVerifiedDecls) 125 | 126 | -- else stop multipassing 127 | else 128 | (currentErrors, updatedEnv, failedDecls, prevVerifiedDecls ++ currentVerifiedDecls) 129 | 130 | 131 | -- NOTE: Pa means Partially Analyzed 132 | data PaDecl 133 | = PaConstDecl 134 | Raw.Const 135 | 136 | | PaFuncDecl 137 | V.FuncSignature 138 | Raw.Expr 139 | Env -- previous env that stores implicit type parameters (e.g. A) 140 | 141 | | PaIdlessDecl 142 | SourcePos 143 | Raw.Expr 144 | 145 | | PaGenericTypeDecl 146 | Raw.StringToken -- name 147 | [Raw.StringToken] -- trailing ids 148 | [(Raw.StringToken, Raw.Expr)] -- type params 149 | Raw.Expr -- type body 150 | 151 | analyzeDecl :: Raw.Decl -> Env -> [(ModuleName,Env)] -> Either KeliError PaDecl 152 | analyzeDecl rawDecl env importedEnvs = case rawDecl of 153 | Raw.ConstDecl c -> 154 | Right (PaConstDecl c) 155 | 156 | Raw.IdlessDecl pos expr -> 157 | Right (PaIdlessDecl pos expr) 158 | 159 | Raw.GenericTypeDecl typeConstructorName ids typeParams typeBody -> 160 | Right (PaGenericTypeDecl typeConstructorName ids typeParams typeBody) 161 | 162 | Raw.FuncDecl(Raw.Func { 163 | Raw.funcDeclDocString = docstring, 164 | Raw.funcDeclGenericParams = genericParams, 165 | Raw.funcDeclIds = funcIds, 166 | Raw.funcDeclParams = funcParams, 167 | Raw.funcDeclReturnType = returnType, 168 | Raw.funcDeclBody = funcBody 169 | }) -> do 170 | let ctx = Context 0 env importedEnvs 171 | 172 | -- 1.0 Verify implicit type params 173 | verifiedGenericParams <- mapM (verifyBoundedTypeVar ctx) genericParams 174 | let verifiedGenericParams' = map (\(id, c) -> V.BoundedTypeVar id c) verifiedGenericParams 175 | 176 | -- 1.1 populate symbol table with implicit type params 177 | env1 <- 178 | foldM 179 | (\acc (id, constraint) -> 180 | if member (snd id) acc then 181 | Left (KErrorDuplicatedId [id]) 182 | else 183 | Right (acc |> (snd id, KeliSymType (V.BoundedTypeVar id constraint)))) 184 | env 185 | verifiedGenericParams 186 | 187 | -- 2 Verify annotated types of each func param 188 | verifiedFuncParams <- 189 | mapM 190 | (\(id, typeAnnot) -> do 191 | (_, verifiedTypeAnnotation) <- verifyTypeAnnotation (Context 0 env1 importedEnvs) typeAnnot 192 | return (id, verifiedTypeAnnotation)) 193 | funcParams 194 | 195 | -- 3. verify return type 196 | verifiedReturnType <- 197 | (case returnType of 198 | Just t -> do 199 | (_, verifiedTypeAnnot) <- verifyTypeAnnotation (Context 0 env1 importedEnvs) t 200 | Right (V.getTypeRef verifiedTypeAnnot) 201 | 202 | Nothing -> 203 | Right (V.TypeUndefined)) 204 | 205 | 206 | 207 | -- 4. Return this function signature 208 | let funcSig = V.FuncSignature{ 209 | V.funcDeclDocString = docstring, 210 | V.funcDeclIds = funcIds, 211 | V.funcDeclGenericParams = verifiedGenericParams', 212 | V.funcDeclParams = verifiedFuncParams, 213 | V.funcDeclReturnType = verifiedReturnType 214 | } 215 | 216 | Right (PaFuncDecl funcSig funcBody env1) 217 | 218 | 219 | analyzePaDecl :: PaDecl -> Env -> [(ModuleName,Env)] -> Either KeliError V.Decl 220 | analyzePaDecl paDecl env importedEnvs = case paDecl of 221 | PaConstDecl Raw.Const { 222 | Raw.constDeclId=id, 223 | Raw.constDeclValue=expr 224 | } -> 225 | case expr of 226 | Raw.Id _ -> 227 | let reservedConstants = [ 228 | "choice", 229 | "$", 230 | "module", 231 | "if", 232 | "else", 233 | "Int", 234 | "Float", 235 | "String"] in 236 | case find (\x -> x == snd id) reservedConstants of 237 | Just _ -> 238 | Left (KErrorCannotRedefineReservedConstant id) 239 | 240 | Nothing -> 241 | continueAnalyzeConstDecl 242 | 243 | _ -> 244 | continueAnalyzeConstDecl 245 | 246 | where 247 | continueAnalyzeConstDecl = do 248 | -- insert temporary types into env to allow declaraion of recursive types 249 | let updatedEnv = env |> (snd id, KeliSymType V.TypeSelf) 250 | (_, result) <- typeCheckExpr (Context 0 updatedEnv importedEnvs) CanBeAnything expr 251 | case result of 252 | First typeCheckedExpr -> 253 | Right (V.ConstDecl id typeCheckedExpr) 254 | 255 | Second (V.TypeAnnotCompound _ _ t) -> do 256 | case t of 257 | V.TypeTaggedUnion taggedUnion -> 258 | Right (V.TaggedUnionDecl taggedUnion) 259 | 260 | _ -> 261 | undefined 262 | 263 | Second (V.TypeAnnotObject expectedPropTypePairs) -> 264 | Right (V.ObjectAliasDecl id expectedPropTypePairs) 265 | 266 | 267 | Second (V.TypeAnnotSimple _ t) -> do 268 | undefined 269 | 270 | Third tag -> do 271 | taggedUnionType <- linkTagsTogether id [] tag [] 272 | Right (V.TaggedUnionDecl taggedUnionType) 273 | 274 | PaFuncDecl funcSignature funcBody prevEnv -> do 275 | -- 5. populate symbol table with function parameters 276 | env2 <- 277 | foldM 278 | (\acc (id, typeAnnot) -> 279 | if member (snd id) acc then 280 | Left (KErrorDuplicatedId [id]) 281 | else 282 | Right (acc |> (snd id, KeliSymLocalConst id (V.getTypeRef typeAnnot)))) 283 | prevEnv 284 | (V.funcDeclParams funcSignature) 285 | 286 | -- 6. type check the function body 287 | (_, typeCheckedBody) <- verifyExpr (Context 0 env2 importedEnvs) CanBeAnything funcBody 288 | let bodyType = getType typeCheckedBody 289 | 290 | let verifiedReturnType = V.funcDeclReturnType funcSignature 291 | -- 7. ensure body type adheres to return type 292 | case verifiedReturnType of 293 | -- if return type is not declared, the return type of this function is inferred as the type of the body 294 | V.TypeUndefined -> 295 | Right (V.FuncDecl (funcSignature {V.funcDeclReturnType = bodyType}) typeCheckedBody) 296 | 297 | _ -> do 298 | case unify (Context 0 env []) emptySubstitution typeCheckedBody verifiedReturnType of 299 | Left err -> 300 | Left err 301 | 302 | Right _ -> 303 | -- if body type match expected return types 304 | Right (V.FuncDecl funcSignature typeCheckedBody) 305 | 306 | PaIdlessDecl pos expr -> do 307 | let ctx = Context 0 env importedEnvs 308 | (_, result) <- typeCheckExpr ctx CanBeAnything expr 309 | case result of 310 | First checkedExpr -> 311 | -- search for the `toString` function that match the type of this expr 312 | let lookupResult = lookupFunction ctx CanBeAnything [checkedExpr] [(pos,"toString")] in 313 | case lookupResult of 314 | Right (_,toStringExpr) -> 315 | Right (V.IdlessDecl toStringExpr) 316 | 317 | _ -> 318 | Right (V.IdlessDecl checkedExpr) 319 | 320 | Second typeAnnot -> 321 | Left (KErrorCannotDeclareTypeAsAnonymousConstant typeAnnot) 322 | 323 | Third tags -> 324 | Left (KErrorCannotDeclareTagAsAnonymousConstant tags) 325 | 326 | PaGenericTypeDecl typeConstructorName ids typeParams typeBody -> do 327 | -- 1. verify all type params 328 | verifiedTypeParams <- mapM (verifyBoundedTypeVar (Context 0 env importedEnvs)) typeParams 329 | 330 | -- 2. populate symbol table with type params 331 | env2 <- 332 | foldM 333 | (\acc (id, constraint) -> 334 | if member (snd id) acc then 335 | Left (KErrorDuplicatedId [id]) 336 | else 337 | Right (acc |> (snd id, KeliSymType (V.BoundedTypeVar id constraint)))) 338 | env 339 | verifiedTypeParams 340 | 341 | 342 | 343 | -- 3. populate symbol table with this type constructor (to allow recursve definition) 344 | let verifiedTypeParams' = map (\(id, c) -> V.BoundedTypeVar id c) verifiedTypeParams 345 | env3 <- 346 | if member (snd typeConstructorName) env2 then 347 | Left (KErrorDuplicatedId [typeConstructorName]) 348 | else 349 | Right (env2 |> (snd typeConstructorName, 350 | KeliSymTaggedUnion (V.TaggedUnion typeConstructorName ids [] verifiedTypeParams'))) 351 | 352 | -- 4. type check the body 353 | (_, typeCheckedBody) <- (typeCheckExpr (Context 0 env3 importedEnvs) StrictlyAnalyzingType typeBody) 354 | case typeCheckedBody of 355 | Third tag -> do 356 | taggedUnion <- linkTagsTogether typeConstructorName ids tag verifiedTypeParams' 357 | Right (V.TaggedUnionDecl taggedUnion) 358 | 359 | Second (V.TypeAnnotObject keyTypePairs) -> 360 | undefined 361 | 362 | _ -> 363 | undefined 364 | 365 | 366 | -- this function is for performing tying the knots (for tagged union types) 367 | linkTagsTogether :: V.StringToken -> [V.StringToken] -> [V.UnlinkedTag] -> [V.Type] -> Either KeliError V.TaggedUnion 368 | linkTagsTogether taggedUnionName ids tags typeParams = 369 | let tagnames = 370 | map 371 | (\t -> case t of 372 | V.UnlinkedCarrylessTag name -> name 373 | V.UnlinkedCarryfulTag name _ -> name) tags in 374 | 375 | case findDuplicates tagnames of 376 | Just duplicates -> 377 | Left (KErrorDuplicatedTags duplicates) 378 | 379 | Nothing -> 380 | let 381 | -- circular structure. Refer https://wiki.haskell.org/Tying_the_Knot 382 | tagUnionType = (V.TaggedUnion taggedUnionName ids tags' typeParams) 383 | 384 | 385 | tags' = 386 | map 387 | (\x -> case x of 388 | V.UnlinkedCarrylessTag tag -> 389 | (V.CarrylessTag tag tagUnionType) 390 | V.UnlinkedCarryfulTag tag carryType -> 391 | let carryType' = substituteSelfType (V.TypeTaggedUnion tagUnionType) (V.getTypeRef carryType) in 392 | 393 | (V.CarryfulTag tag carryType' tagUnionType)) 394 | tags 395 | in 396 | 397 | Right tagUnionType 398 | 399 | 400 | 401 | -- substitute source into target 402 | substituteSelfType :: V.Type -> V.Type -> V.Type 403 | substituteSelfType source target = 404 | case target of 405 | V.TypeSelf -> 406 | source 407 | 408 | V.TypeObject name propTypePairs -> 409 | let updatedPropTypePairs = 410 | map 411 | (\(prop, type') -> 412 | (prop, substituteSelfType source type')) 413 | propTypePairs 414 | in (V.TypeObject name updatedPropTypePairs) 415 | 416 | V.TypeTaggedUnion (V.TaggedUnion (_,name1) _ _ _) -> 417 | -- TODO: something fishy here, not sure if got bug or not 418 | case source of 419 | V.TypeTaggedUnion (V.TaggedUnion (_,name2) _ _ _) -> 420 | if name1 == name2 then 421 | source 422 | else 423 | target 424 | 425 | _ -> 426 | target 427 | 428 | _ -> 429 | target 430 | 431 | 432 | toSymbol :: V.Decl -> Maybe KeliSymbol 433 | toSymbol decl = 434 | case decl of 435 | V.ConstDecl id expr -> 436 | Just (KeliSymGlobalConst id (getType expr)) 437 | 438 | V.FuncDecl signature _ -> 439 | Just (KeliSymFunc [signature]) 440 | 441 | V.IdlessDecl _ -> 442 | Nothing 443 | 444 | V.ObjectAliasDecl id expectedPropTypePairs -> 445 | Just (KeliSymType (V.TypeObject (Just id) 446 | (map (\(k,t) -> (k, V.getTypeRef t)) expectedPropTypePairs))) 447 | 448 | V.TaggedUnionDecl t -> 449 | Just (KeliSymTaggedUnion t) 450 | --------------------------------------------------------------------------------