├── .gitignore ├── .travis.yml ├── HLint.hs ├── LICENSE ├── README.md ├── Setup.hs ├── libs └── std │ ├── arrays.el │ ├── arrays.js │ ├── arrays.lua │ ├── arrays.oc │ ├── arrays.rb │ ├── eithers.oc │ ├── ff.el │ ├── ff.js │ ├── ff.lua │ ├── ff.oc │ ├── ff.pre.el │ ├── ff.pre.js │ ├── ff.pre.lua │ ├── ff.pre.rb │ ├── ff.rb │ ├── foldable.oc │ ├── lists.oc │ ├── maybes.oc │ ├── numbers.oc │ ├── prelude.oc │ └── std.oc ├── occ └── Main.hs ├── oczor.cabal ├── src └── Oczor │ ├── CodeGen │ ├── CodeGenElisp.hs │ ├── CodeGenJs.hs │ ├── CodeGenLua.hs │ ├── CodeGenRuby.hs │ └── Utl.hs │ ├── Compiler │ ├── CommandLine.hs │ ├── Compiler.hs │ ├── Files.hs │ ├── State.hs │ └── Utl.hs │ ├── Converter │ ├── CodeGenAst.hs │ ├── Converter.hs │ └── Rewriter.hs │ ├── Desugar │ └── Desugar.hs │ ├── Infer │ ├── Infer.hs │ ├── InferAst.hs │ ├── InferContext.hs │ ├── Module.hs │ ├── State.hs │ ├── Substitutable.hs │ ├── Unify.hs │ └── UnifyState.hs │ ├── Parser │ ├── Expr.hs │ ├── Lexer.hs │ ├── Parser.hs │ ├── ParserState.hs │ ├── Statements.hs │ ├── Types.hs │ └── Utl.hs │ ├── Pretty │ ├── Errors.hs │ ├── Pretty.hs │ └── Types.hs │ ├── Syntax │ ├── Ast.hs │ ├── Errors.hs │ ├── Operators.hs │ ├── Syntax.hs │ └── Types.hs │ ├── Test │ ├── Files.hs │ ├── Simple.hs │ ├── TestCompiler.hs │ ├── TestEngine.hs │ └── Tests.hs │ └── Utl.hs ├── stack.yaml ├── test └── Spec.hs └── tests ├── codegen ├── 01 access.txt ├── 02 array.txt ├── 03 class eq.txt ├── 04 classes.txt ├── 05 class show41.txt ├── 06 classes2.txt ├── 07 classes3.txt ├── 08 function.txt ├── 09 lit.txt ├── 10 match.txt ├── 11 maybe.txt ├── 12 record.txt ├── 13 test.txt ├── 14 typechange.txt ├── 15 types.txt └── class-map ├── compiler ├── dirModule │ └── dirFoo.oc ├── output │ ├── std │ │ ├── eithers.module.js │ │ ├── foldable.module.js │ │ ├── lists.module.js │ │ ├── maybes.module.js │ │ └── prelude.module.js │ ├── testModule.module.js │ ├── test_array.js │ ├── test_array.module.js │ ├── test_code.el │ ├── test_code.js │ ├── test_code.lua │ ├── test_code.module.js │ ├── test_code.rb │ ├── test_either.js │ ├── test_either.module.js │ ├── test_foldable.js │ ├── test_foldable.module.js │ ├── test_import.js │ ├── test_import.module.js │ ├── test_list.js │ ├── test_list.module.js │ ├── test_maybe.el │ ├── test_maybe.js │ ├── test_maybe.lua │ ├── test_maybe.module.js │ ├── test_maybe.rb │ ├── test_numbers.el │ ├── test_numbers.js │ ├── test_numbers.lua │ ├── test_numbers.module.js │ ├── test_numbers.rb │ ├── test_prelude.el │ ├── test_prelude.js │ ├── test_prelude.lua │ ├── test_prelude.module.js │ ├── test_prelude.rb │ ├── test_syntax.el │ ├── test_syntax.js │ ├── test_syntax.lua │ ├── test_syntax.module.js │ ├── test_syntax.rb │ └── testing.module.js ├── testModule.oc ├── test_array.oc ├── test_code.oc ├── test_either.oc ├── test_empty.oc ├── test_foldable.oc ├── test_import.oc ├── test_importDir.oc ├── test_list.oc ├── test_maybe.oc ├── test_numbers.oc ├── test_prelude.oc ├── test_syntax.oc ├── testing.oc ├── tests.bat └── tests2.bat ├── converter-class ├── 01 class-body.txt ├── 02 class-show.txt ├── 03 class-call.txt ├── 04 class-show.txt ├── 05 class-show.txt ├── 06 class-show.txt ├── 07 class-show.txt ├── 08 class-show.txt ├── 09 cases-show.txt ├── 10 class-show-foo.txt ├── 11 class-mempty.txt ├── 12 class-eq.txt ├── 12 class-pure ├── 13 class-eq-maybe ├── 13 class-show-maybe.txt ├── 14 class-show6 ├── 14 triple.txt ├── 15 class-in-record ├── 15 show-label.txt ├── 16 class-map ├── 16 two-classes.txt ├── 17 label.txt ├── 18 show-rec.txt ├── 19 order └── 20 params.txt ├── converter ├── 01 lit.txt ├── 02 record.txt ├── 03 removetype.txt ├── 04 open ├── 05 match.txt ├── 06 tuple.txt ├── 07 cases.txt ├── 08 either.txt ├── 09 ffi-class ├── 10 typechange.txt ├── 11 typechange-union.txt ├── 12 lazy.txt ├── 13 union.txt ├── 14 union-maker.txt ├── 15 if.txt ├── 16 set.txt ├── 17 let.txt ├── 18 with.txt ├── instance ├── removetype-cases └── tuple2 ├── infer ├── 01 let.txt ├── 02 list.txt ├── 03 access.txt ├── 04 array.txt ├── 05 cases show.txt ├── 06 classes.txt ├── 07 class pure.txt ├── 08 class show.txt ├── 09 class show2.txt ├── 10 class show maybe ├── 11 conflict.txt ├── 12 either.txt ├── 13 emptytype.txt ├── 14 fails.txt ├── 15 func.txt ├── 16 generic.txt ├── 17 guard.txt ├── 18 instance typecheck.txt ├── 19 kinds.txt ├── 20 maker.txt ├── 21 match.txt ├── 22 match2.txt ├── 23 maybe.txt ├── 24 none.txt ├── 25 open.txt ├── 26 record.txt ├── 27 recursion.txt ├── 28 two classes.txt ├── 29 typechange.txt ├── 30 typeDesc.txt ├── 31 typerow.txt ├── 32 union.txt ├── 33 union2.txt ├── 34 union3.txt ├── 35 with type.txt ├── 36 lazy.txt ├── 37 with.txt ├── 38 if.txt ├── 39 set.txt ├── cases match ├── class eq ├── class maybe ├── func c └── tuple ├── inferast ├── 1 call.txt ├── 2 call.txt ├── 3 class show.txt ├── 4 lit.txt ├── 5 cases show.txt └── 6 typechange.txt ├── parser ├── 01 ident.txt ├── 02 lit.txt ├── 03 array.txt ├── 04 ffi.txt ├── 05 func.txt ├── 06 anonfunc.txt ├── 07 call.txt ├── 08 call-op.txt ├── 09 indent.txt ├── 10 label.txt ├── 11 let.txt ├── 12 instance.txt ├── 13 classes.txt ├── 14 monoid.txt ├── 15 import.txt ├── 16 open.txt ├── 17 cases.txt ├── 18 match.txt ├── 19 poly.txt ├── 20 typeapply.txt ├── 21 types.txt ├── 22 withtype.txt ├── 23 emptytype.txt ├── 24 semi ├── 25 operator.txt ├── 26 as.txt ├── 27 destruct.txt ├── 28 partial.txt ├── 29 with.txt ├── 30 if.txt ├── 31 set.txt ├── 32 keyword-multiline.txt ├── cases-match └── label-type ├── pretty ├── 01 record.txt ├── 02 constrain.txt ├── 03 type.txt ├── 04 union.txt └── 05 sub.txt └── rewriter ├── 01 eta.txt ├── 02 operator ├── 03 apply.txt ├── 04 instance.txt └── 05 operators /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | .idea/ 22 | .ideaHaskellLib/ 23 | cabal.config 24 | oczor.iml -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: generic 3 | cache: 4 | directories: 5 | - $HOME/.stack 6 | addons: 7 | apt: 8 | packages: 9 | - libgmp-dev 10 | before_install: 11 | - mkdir -p ~/.local/bin 12 | - export PATH=$HOME/.local/bin:$PATH 13 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 14 | install: 15 | - stack --no-terminal --install-ghc test --only-dependencies 16 | script: 17 | - stack --no-terminal test 18 | -------------------------------------------------------------------------------- /HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.Default 2 | import "hint" HLint.HLint 3 | 4 | infixl 4 <$> 5 | infixr 9 . 6 | infixl 1 <&> 7 | infixl 1 & 8 | infixl 3 <|> 9 | infixl 4 *> 10 | infixl 4 <* 11 | infixl 4 <*> 12 | infixr 0 $ 13 | infixr 6 <> 14 | infixr 5 ++ 15 | -- warn "my-a" = a (b $ c d) ==> a . b $ c d 16 | -- warn "my-b" = a (b *> c) ==> a $ b *> c 17 | -- warn "my-c" = a (b (c d)) ==> a (b $ c d) 18 | -- warn "my-d" = [a (b c)] ==> [a $ b c] 19 | warn "Use liftA2" = a <$> b <*> c ==> liftA2 a b c 20 | warn "my-e" = (a $ b c (d e), f) ==> (a . b c $ d e, f) 21 | warn "my-f" = [a b (c d), e] ==> [a b $ c d, e] 22 | warn "my-g" = (if a then (b $ c) else (b $ d)) ==> (b $ if a then c else d) 23 | warn "my-h" = (do x <- a ; return $ b x) ==> b <$> a 24 | warn "my-ha" = (do x <- a ; b x) ==> b <*> a 25 | warn "my-i" = (\x -> a <$> b x) ==> fmap a . b 26 | warn "my-j" = either (f . a) (f . b) ==> f . either a b 27 | warn "my-ja" = either (f . a) (f . b) c ==> f . either a b c 28 | warn "my-k" = (\x -> f x >>= y) ==> f >=> y 29 | warn "my-l" = (a . b) . c ==> a . b . c 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 ptol 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /libs/std/arrays.el: -------------------------------------------------------------------------------- 1 | (foo (error "arrays is not implemented")) 2 | -------------------------------------------------------------------------------- /libs/std/arrays.js: -------------------------------------------------------------------------------- 1 | function arrayIndexEx(index,a){ 2 | var r = a[index]; 3 | if(typeof r === 'undefined'){ 4 | throw "array length == " + a.lentgh + ", index == " + index; 5 | } 6 | } 7 | 8 | var arrayEmpty = [] 9 | 10 | var arrayIndex = function(i,a){ 11 | var r = a[index]; 12 | if(typeof r === 'undefined'){ 13 | return {just: r}; 14 | }else{ 15 | return oc.std.maybes.none; 16 | } 17 | } 18 | 19 | var arrayLength = function(a){ 20 | return a.length; 21 | } 22 | 23 | var arrayEq = function(eq, a1,a2) { 24 | if(a1.length != a2.length){ 25 | return false; 26 | } 27 | for (var i = 0, l=this.length; i < l; i++) { 28 | if(!eq(a1[i],a2[i])){ 29 | return false; 30 | } 31 | } 32 | return true; 33 | } 34 | 35 | var arrayMap = function(f, a){ return a.map(f); } 36 | 37 | var arrayPure = function(x){ return [x]; } 38 | 39 | var arrayAppend = function(a1, a2){ return a1.concat(a2); } 40 | 41 | var arrayFoldl = function(f, s, a){ return a.reduce(f,s); } 42 | -------------------------------------------------------------------------------- /libs/std/arrays.lua: -------------------------------------------------------------------------------- 1 | error("arrays is not implemented") 2 | -------------------------------------------------------------------------------- /libs/std/arrays.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import std.foldable 3 | 4 | arrayShow x = "array" 5 | 6 | ffi arrayEmpty : Array a 7 | 8 | ffi arrayIndex : (Int,Array a) => Maybe a 9 | 10 | ffi arrayEq : a eq <: (Array a, Array a) => Bool 11 | 12 | ffi arrayLength : (Array a) => Int 13 | 14 | ffi arrayPure : a => Array a 15 | 16 | ffi arrayAppend : Array a, Array a => Array a 17 | 18 | ffi arrayMap : (a => b), Array a => Array b 19 | 20 | ffi arrayFoldl : (a, e => e), a, Array e => a 21 | 22 | /* ffi arrayZipWith : (a, b => c), Array a, Array b => Array c */ 23 | 24 | /* ffi arrayBind : (a => Array b), Array a => Array b */ 25 | 26 | instance (Array (a eq <: a)) eq x y = arrayEq x y 27 | instance Array pure x = arrayPure x 28 | instance Array append x y = arrayAppend x y 29 | instance Array map f x = arrayMap f x 30 | instance Array foldl f i x = arrayFoldl f i x 31 | /* instance (Maybe (a show <: a)) show x = showMaybe x */ 32 | 33 | arrayIsEmpty x = eq x arrayEmpty 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /libs/std/arrays.rb: -------------------------------------------------------------------------------- 1 | raise "arrays is not implemented" 2 | -------------------------------------------------------------------------------- /libs/std/eithers.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | 3 | type Either a b = left : a | right : b 4 | 5 | pureEither : b => Either a b 6 | pureEither x = right = x 7 | 8 | either : (a => c), (b => c), (Either a b) => c 9 | either fl fr m = m # case 10 | (left = x) => fl x 11 | (right = x) => fr x 12 | 13 | isLeft : Either a b => Bool 14 | isLeft x = either (cnst true) (cnst false) x 15 | 16 | isRight : Either a b => Bool 17 | isRight x = either (cnst false) (cnst true) x 18 | 19 | fromEither : b, Either a b => b 20 | fromEither x m = either (cnst x) id m 21 | 22 | mapEither : (b => c, (Either a b)) => Either a c 23 | mapEither f z = z # case 24 | (left = x) => left = x 25 | (right = x) => right = f x 26 | 27 | bindEither : ((b => Either a b), (Either a b)) => Either a b 28 | bindEither f z = z # case 29 | (left = x) => left = x 30 | (right = x) => f x 31 | 32 | showEither : Either ((a show <: a)) ((b show <: b)) => String 33 | showEither x = either show show x 34 | 35 | /* eqEither : a eq <: Either (((Either a b), (Either a b))) => Bool */ 36 | eqEither : (a eq, b eq <: ((Either a b), (Either a b))) => Bool 37 | eqEither = case 38 | \(left = x) (left = y) => eq x y 39 | \(right = x) (right = y) => eq x y 40 | \_ _ => false 41 | 42 | /* foldlMaybe : ((b,a) => b, b, (Maybe a)) => b */ 43 | /* foldlMaybe f i x = maybe i (y => f i y) x */ 44 | /* */ 45 | /* */ 46 | /* */ 47 | /* instance Maybe foldl = foldlMaybe */ 48 | instance (Either a) pure x = pureEither x 49 | instance (Either a) map = mapEither 50 | instance (Either a) bind = bindEither 51 | 52 | /* instance (a show, b show <: Either a b) show x = showEither x */ 53 | instance (a show, b show <: Either a b) show x = showEither x 54 | instance (a eq, b eq <: Either a b) eq x y = eqEither x y 55 | -------------------------------------------------------------------------------- /libs/std/ff.el: -------------------------------------------------------------------------------- 1 | (print (lambda (x) (progn (princ x) (princ "\n")))) 2 | 3 | (add-any (lambda (x y) (+ x y))) 4 | 5 | (mul-any (lambda (x y) (* x y))) 6 | 7 | (sub-any (lambda (x y) (- x y))) 8 | 9 | (div-any (lambda (x y) (/ x y))) 10 | 11 | (eq-any (lambda (x y) (eql x y))) 12 | 13 | 14 | (unit '()) 15 | (empty-object '()) 16 | 17 | (eq-int eq-any) 18 | (eq-double eq-any) 19 | (eq-string (lambda (x y) (string= x y))) 20 | (eq-char eq-any) 21 | (eq-bool eq-any) 22 | 23 | (show-int 'number-to-string) 24 | 25 | (show-double 'number-to-string) 26 | (show-string (lambda (x) x)) 27 | (show-char (lambda (x) x)) 28 | (show-bool (lambda (x) (if x "true" "false"))) 29 | 30 | (add-int add-any) 31 | (mul-int mul-any) 32 | (sub-int mul-any) 33 | (div-int mul-any) 34 | 35 | (add-double add-any) 36 | (mul-double mul-any) 37 | (sub-double mul-any) 38 | (div-double mul-any) 39 | 40 | 41 | (or-bool (lambda (x y) (or x y))) 42 | (and-bool (lambda (x y) (and x y))) 43 | 44 | (add-bool 'orBool) 45 | (mul-bool 'andBool) 46 | 47 | (_not 'not) 48 | 49 | (append-string 'concat) 50 | -------------------------------------------------------------------------------- /libs/std/ff.js: -------------------------------------------------------------------------------- 1 | function print(x){ console.log(x); } 2 | 3 | function addAny(x,y){ return x + y; } 4 | 5 | function mulAny(x,y){ return x * y; } 6 | 7 | function subAny(x,y){ return x - y; } 8 | 9 | function eqAny(x,y){ return x === y; } 10 | 11 | function showAny(x){ return x + ""; } 12 | 13 | var unit = {} 14 | var emptyObject = {} 15 | 16 | var eqInt = eqAny; 17 | var eqDouble = eqAny; 18 | var eqString = eqAny; 19 | var eqChar = eqAny; 20 | var eqBool = eqAny; 21 | 22 | var showInt = showAny; 23 | var showDouble = showAny; 24 | var showString = showAny; 25 | var showChar = showAny; 26 | var showBool = showAny; 27 | 28 | var addInt = addAny 29 | var mulInt = mulAny 30 | var subInt = subAny 31 | var divInt = function(x,y){return x / y | 0;} 32 | 33 | var addDouble = addAny 34 | var mulDouble = mulAny 35 | var subDouble = subAny 36 | var divDouble = function(x,y){return x / y;} 37 | 38 | var addBool = function(x,y){return x || y} 39 | var mulBool = function(x,y){return x && y} 40 | 41 | var not = function(x){return !x} 42 | var orBool = function(x,y){return x || y} 43 | var andBool = function(x,y){return x && y} 44 | 45 | var appendString = addAny 46 | 47 | -------------------------------------------------------------------------------- /libs/std/ff.lua: -------------------------------------------------------------------------------- 1 | local _print = function(x) print(x); end 2 | 3 | function addAny(x,y) return x + y end 4 | 5 | function mulAny(x,y) return x * y end 6 | 7 | function subAny(x,y) return x - y end 8 | 9 | function eqAny(x,y) return x == y end 10 | 11 | function showAny(x) return tostring(x) end 12 | 13 | local unit = {} 14 | local emptyObject = {} 15 | local eqAny = eqAny 16 | 17 | local eqInt = eqAny 18 | local eqDouble = eqAny 19 | local eqString = eqAny 20 | local eqChar = eqAny 21 | local eqBool = eqAny 22 | 23 | local showInt = showAny 24 | local showDouble = showAny 25 | local showString = showAny 26 | local showChar = showAny 27 | local showBool = showAny 28 | 29 | local addInt = addAny 30 | local mulInt = mulAny 31 | local subInt = subAny 32 | local divInt = function(x,y) return math.floor( x / y) end 33 | 34 | local addDouble = addAny 35 | local mulDouble = mulAny 36 | local subDouble = subAny 37 | local divDouble = function(x,y) return x / y end 38 | 39 | local addBool = function(x,y) return x or y end 40 | local mulBool = function(x,y) return x and y end 41 | 42 | local _not = function(x) return not x end 43 | local orBool = function(x,y) return x or y end 44 | local andBool = function(x,y) return x and y end 45 | 46 | local appendString = function(x,y) return x .. y end 47 | -------------------------------------------------------------------------------- /libs/std/ff.oc: -------------------------------------------------------------------------------- 1 | ffi type Int 2 | ffi type Double 3 | ffi type String 4 | ffi type Char 5 | ffi type Bool 6 | ffi type Unit 7 | ffi type Array a 8 | 9 | ffi unit : Unit 10 | 11 | ffi showInt : Int => String 12 | ffi showDouble : Double => String 13 | ffi showString : String => String 14 | ffi showChar : Char => String 15 | ffi showBool : Bool => String 16 | 17 | ffi eqAny : a, a => Bool 18 | 19 | ffi eqInt : Int, Int => Bool 20 | ffi eqDouble : Double, Double => Bool 21 | ffi eqString : String, String => Bool 22 | ffi eqChar : Char, Char => Bool 23 | ffi eqBool : Bool, Bool => Bool 24 | 25 | ffi not : Bool => Bool 26 | ffi andBool : Bool, Bool => Bool 27 | ffi orBool : Bool, Bool => Bool 28 | 29 | ffi addInt : Int, Int => Int 30 | ffi mulInt : Int, Int => Int 31 | ffi subInt : Int, Int => Int 32 | ffi divInt : Int, Int => Int 33 | 34 | ffi addDouble : Double, Double => Double 35 | ffi mulDouble : Double, Double => Double 36 | ffi subDouble : Double, Double => Double 37 | ffi divDouble : Double, Double => Double 38 | 39 | ffi appendString : String, String => String 40 | 41 | ffi print : a => Unit 42 | -------------------------------------------------------------------------------- /libs/std/ff.pre.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t -*- 2 | (require 'cl) 3 | (setq oc (make-hash-table :test 'equal)) 4 | 5 | ; (defun oc-hash-from-alist (alist) 6 | ; (let ((hash (make-hash-table :test 'equal))) 7 | ; (mapcar (lambda (element) 8 | ; (puthash (car element) (cdr element) hash)) 9 | ; alist) 10 | ; hash)) 11 | 12 | (defun oc-hash-from-alist (plist) 13 | (let ((pl plist) 14 | (result (make-hash-table :test 'equal))) 15 | (while pl 16 | (puthash (car pl) (cadr pl) result) 17 | (setq pl (cddr pl))) 18 | result)) 19 | 20 | (puthash 'instances (make-hash-table :test 'equal) oc) 21 | 22 | (puthash 'clone-object (lambda (obj) (copy-hash-table obj)) oc) 23 | 24 | ; (puthash 'clone-object (lambda (obj) 25 | ; (let ((result (make-hash-table :test 'equal))) 26 | ; (maphash (lambda (key val) (puthash key val result)) obj) 27 | ; result)) oc) 28 | -------------------------------------------------------------------------------- /libs/std/ff.pre.js: -------------------------------------------------------------------------------- 1 | var oc = {}; 2 | oc.instances = {}; 3 | 4 | oc.cloneObject = function(obj){ 5 | var result = {}; 6 | for (var key in obj) { 7 | if (obj.hasOwnProperty(key)) result[key] = obj[key]; 8 | } 9 | return result; 10 | } 11 | -------------------------------------------------------------------------------- /libs/std/ff.pre.lua: -------------------------------------------------------------------------------- 1 | oc = {} 2 | oc.instances = {} 3 | 4 | oc.cloneObject = function (t) 5 | local t2 = {} 6 | for k,v in pairs(t) do 7 | t2[k] = v 8 | end 9 | return t2 10 | end 11 | 12 | function print_r(arr, indentLevel) 13 | local str = "" 14 | local indentStr = "#" 15 | 16 | if(indentLevel == nil) then 17 | print(print_r(arr, 0)) 18 | return 19 | end 20 | 21 | for i = 0, indentLevel do 22 | indentStr = indentStr.."\t" 23 | end 24 | 25 | for index,value in pairs(arr) do 26 | if type(value) == "table" then 27 | str = str..indentStr..index..": \n"..print_r(value, (indentLevel + 1)) 28 | else 29 | str = str..indentStr..index..": "..value.."\n" 30 | end 31 | end 32 | return str 33 | end 34 | -------------------------------------------------------------------------------- /libs/std/ff.pre.rb: -------------------------------------------------------------------------------- 1 | oc = {} 2 | oc[:instances] = {} 3 | 4 | oc[:cloneObject] = -> (obj) do 5 | result = {}; 6 | obj.each {|key, value| 7 | result[key] = value 8 | } 9 | result; 10 | end 11 | 12 | class UniqObject 13 | end 14 | -------------------------------------------------------------------------------- /libs/std/ff.rb: -------------------------------------------------------------------------------- 1 | print = -> (x) {puts x} 2 | 3 | addAny = -> (x,y) {x + y} 4 | 5 | mulAny = -> (x,y) {x * y} 6 | 7 | subAny = -> (x,y) {x - y} 8 | divAny = -> (x,y) {x / y} 9 | 10 | eqAny = -> (x,y) {x == y} 11 | 12 | showAny = -> (x) {x.to_s} 13 | 14 | unit = {} 15 | emptyObject = {} 16 | 17 | eqInt = eqAny 18 | eqDouble = eqAny 19 | eqString = eqAny 20 | eqChar = eqAny 21 | eqBool = eqAny 22 | 23 | showInt = showAny 24 | showDouble = showAny 25 | showString = showAny 26 | showChar = showAny 27 | showBool = showAny 28 | 29 | addInt = addAny 30 | mulInt = mulAny 31 | subInt = subAny 32 | divInt = divAny 33 | 34 | addDouble = addAny 35 | mulDouble = mulAny 36 | subDouble = subAny 37 | divDouble = divAny 38 | 39 | addBool = -> (x,y) {x || y} 40 | mulBool = -> (x,y) {x && y} 41 | 42 | _not = -> (x) {!x} 43 | orBool = -> (x,y) {x || y} 44 | andBool = -> (x,y) {x && y} 45 | 46 | appendString = addAny 47 | -------------------------------------------------------------------------------- /libs/std/foldable.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | 3 | class foldl f : (b, a => b), b, f a => b 4 | 5 | any : (a => Bool), f a => Bool 6 | any f l = foldl (a e => a || f e) false l 7 | 8 | all : (a => Bool), f a => Bool 9 | all f l = foldl (a e => a && f e) true l 10 | 11 | or : f Bool => Bool 12 | or l = any id l 13 | 14 | and : f Bool => Bool 15 | and l = all id l 16 | 17 | sum l = foldl (a e => a + e) zero l 18 | product l = foldl (a e => a * e) one l 19 | 20 | contains : a, f a => Bool 21 | contains x l = any (y => x == y) l 22 | 23 | count l = foldl (a e => a + 1) 0 l 24 | 25 | foldMap f l = foldl (a e => a ++ f e) mempty l 26 | 27 | concat l = foldMap id l 28 | 29 | /* find */ 30 | -------------------------------------------------------------------------------- /libs/std/lists.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import std.maybes 3 | 4 | type NonEmptyList a = (a, List a) 5 | type List a = emptyList | NonEmptyList a 6 | 7 | pureList : a => List a 8 | pureList x = x, emptyList 9 | 10 | range : Int, Int => List Int 11 | range = case 12 | x y | x == y => pureList x 13 | x y => z = range (x + 1) y in (x, z) 14 | 15 | ifEmpty : a, (NonEmptyList b => a), List b => a 16 | ifEmpty def f l = l # case 17 | ^emptyList => def 18 | x => f x 19 | 20 | isEmpty : List a => Bool 21 | isEmpty l = ifEmpty true (x => false) l 22 | 23 | length : List a => Int 24 | length = case 25 | ^emptyList => 0 26 | h t => length t + 1 27 | 28 | /* head : List a => Maybe a */ 29 | /* head = case */ 30 | /* ^emptyList => none */ 31 | /* h t => just = h */ 32 | 33 | /* uncons : List a => Maybe (NonEmptyList a) */ 34 | /* uncons = case */ 35 | /* ^emptyList => none */ 36 | /* x => just = x */ 37 | 38 | /* last : (List a) => (Maybe a) */ 39 | /* last = case */ 40 | /* ^emptyList => none */ 41 | /* \x y | (isEmpty y) => just = x */ 42 | /* \x y => last y */ 43 | 44 | /* index : ((List a), Int) => Maybe a */ 45 | /* index = case */ 46 | /* \(l : EmptyList) i => none */ 47 | /* \(h,t) i | (eq i 0) => just = h */ 48 | /* \(h,t) i => index t (subInt i 1) */ 49 | 50 | eqList : a eq <: (List a, List a) => Bool 51 | eqList = case 52 | ^emptyList ^emptyList => true 53 | ^emptyList y => false 54 | x ^emptyList => false 55 | \(h1,t1) (h2,t2) => h1 == h2 && eqList t1 t2 56 | 57 | appendList : List a, List a => List a 58 | appendList = case 59 | ^emptyList y => y 60 | \(h,t) y => h, appendList t y 61 | 62 | foldlList : (b, a => b), b, List a => b 63 | foldlList f i l = ifEmpty i (\h t => foldlList f (f i h) t) l 64 | 65 | mapList : (a => b), List a => List b 66 | mapList f l = ifEmpty emptyList (h t => (f h, mapList f t)) l 67 | 68 | /* applyList : ((List (a => b)), (List a)) => List b */ 69 | /* applyList f l = ifEmpty emptyList (\h t => appendList (mapList h l) (applyList t l)) f */ 70 | 71 | /* bindList : ((a => List b), (List a)) => List b */ 72 | /* bindList = case */ 73 | /* \f (x : EmptyList) => emptyList */ 74 | /* \f (h,t) => appendList (f h) (bindList f t) */ 75 | 76 | /* lift2 : (((a,b) => c), (m a), (m b)) => m c */ 77 | /* lift2 f x y = apply (map (\xx => (\z => f xx z)) x) y */ 78 | /*f (m a, m a) -> m (f a) */ 79 | /* traverseList : ((a => m b), List a) => m (List b) */ 80 | /* traverseList f l = isEmpty (pure emptyList) (\h t => lift2 id (f h) t) l */ 81 | /* \f (x : EmptyList) => pure emptyList */ 82 | /* \f (h,t) => ( */ 83 | 84 | instance (List (a eq <: a)) eq x y = eqList x y 85 | 86 | -------------------------------------------------------------------------------- /libs/std/maybes.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import std.foldable 3 | 4 | type Maybe a = none | just : a 5 | 6 | noneMaybe : Maybe a 7 | noneMaybe = none 8 | 9 | pureMaybe : a => Maybe a 10 | pureMaybe x = just = x 11 | 12 | maybe : b, (a => b), Maybe a => b 13 | maybe = case 14 | x f ^none => x 15 | x f z => f z.just 16 | 17 | isNone : Maybe a => Bool 18 | isNone x = maybe true (cnst false) x 19 | 20 | isJust : Maybe a => Bool 21 | isJust x = maybe false (cnst true) x 22 | 23 | fromMaybe : x, Maybe x => x 24 | fromMaybe x m = maybe x id m 25 | 26 | mapMaybe : (a => b), Maybe a => Maybe b 27 | mapMaybe f x = maybe noneMaybe (y => just = (f y)) x 28 | 29 | bindMaybe : ((a => Maybe b), (Maybe a)) => Maybe b 30 | bindMaybe f x = maybe none f x 31 | 32 | applyMaybe : Maybe (a => b), Maybe a => Maybe b 33 | applyMaybe f x = maybe none (y => mapMaybe y x) f 34 | 35 | showMaybe : Maybe ((a show <: a)) => String 36 | showMaybe x = maybe ("none", show, x) 37 | 38 | eqMaybe : a eq <: (Maybe a, Maybe a) => Bool 39 | eqMaybe = case 40 | ^none ^none => true 41 | ^none y => false 42 | x ^none => false 43 | x y => eq x.just y.just 44 | 45 | foldlMaybe : (b, a => b), b, Maybe a => b 46 | foldlMaybe f i x = maybe i (y => f i y) x 47 | 48 | /* traverseMaybe : b pure <: (a => m b), Maybe a => m (Maybe b) */ 49 | /* traverseMaybe f x = maybe (pure none) f x */ 50 | 51 | instance (Maybe (a show <: a)) show x = showMaybe x 52 | instance (Maybe (a eq <: a)) eq x y = eqMaybe x y 53 | 54 | instance Maybe foldl = foldlMaybe 55 | instance Maybe pure x = pureMaybe x 56 | instance Maybe map = mapMaybe 57 | instance Maybe apply = applyMaybe 58 | instance Maybe bind = bindMaybe 59 | instance Maybe mempty = none 60 | /* instance Maybe traverse = traverseMaybe */ 61 | -------------------------------------------------------------------------------- /libs/std/numbers.oc: -------------------------------------------------------------------------------- 1 | import std.ff 2 | 3 | class 4 | add a : a, a => a 5 | zero a : a 6 | mul a : a, a => a 7 | one a : a 8 | sub a : a, a => a 9 | div a : a, a => a 10 | 11 | infixl + 6 add 12 | infixl - 6 sub 13 | infixl * 7 mul 14 | infixl / 7 div 15 | 16 | instance 17 | Int add = addInt 18 | Int mul = mulInt 19 | Int zero = 0 20 | Int one = 1 21 | Int sub = subInt 22 | Int div = divInt 23 | 24 | instance 25 | Double add = addDouble 26 | Double mul = mulDouble 27 | Double zero = 0.0 28 | Double one = 1.0 29 | Double sub = subDouble 30 | Double div = divDouble 31 | 32 | negate x = zero - x 33 | -------------------------------------------------------------------------------- /libs/std/prelude.oc: -------------------------------------------------------------------------------- 1 | import 2 | std.ff 3 | std.numbers 4 | include 5 | std.ff 6 | std.numbers 7 | 8 | flip f = \a b => f b a 9 | 10 | cnst x = y => x 11 | 12 | id x = x 13 | 14 | fst x y = x 15 | snd x y = y 16 | 17 | class show a : a => String 18 | 19 | class eq a : a, a => Bool 20 | infix == 4 eq 21 | 22 | class 23 | mempty a : a 24 | append a : a, a => a 25 | 26 | infixr ++ 5 append 27 | 28 | class 29 | map f : (a => b, (f a)) => f b 30 | apply f : ((f (a => b)), (f a)) => f b 31 | pure f : a => f a 32 | bind f : ((a => f b), (f a)) => f b 33 | traverse t : ((a => m b), t a) => m (t b) 34 | 35 | instance 36 | Int show = showInt 37 | Double show = showDouble 38 | String show = showString 39 | Char show = showChar 40 | Bool show = showBool 41 | 42 | instance 43 | Int eq = eqInt 44 | Double eq = eqDouble 45 | String eq = eqString 46 | Char eq = eqChar 47 | Bool eq = eqBool 48 | 49 | instance 50 | String mempty = "" 51 | String append x y = appendString x y 52 | 53 | infixr && 3 andBool 54 | infixr || 2 orBool 55 | -------------------------------------------------------------------------------- /libs/std/std.oc: -------------------------------------------------------------------------------- 1 | import 2 | std.ff 3 | std.numbers 4 | std.prelude 5 | std.maybes 6 | std.arrays 7 | std.foldable 8 | 9 | include 10 | std.ff 11 | std.numbers 12 | std.prelude 13 | std.maybes 14 | std.arrays 15 | std.foldable 16 | -------------------------------------------------------------------------------- /occ/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import ClassyPrelude 3 | import Oczor.Compiler.CommandLine 4 | 5 | main :: IO () 6 | main = run 7 | -------------------------------------------------------------------------------- /src/Oczor/CodeGen/CodeGenElisp.hs: -------------------------------------------------------------------------------- 1 | module Oczor.CodeGen.CodeGenElisp (codeGen) where 2 | import Oczor.CodeGen.Utl 3 | import Data.List.Split 4 | import Data.Functor.Foldable 5 | 6 | phi :: AstF Doc -> Doc 7 | phi = \case 8 | NoneF -> empty 9 | UniqObjectF name -> parens (text "lambda") 10 | NotEqualF x y -> c "not" [c "eq" [x, y]] 11 | EqualF x y -> c "eq" [x, y] 12 | LitF value -> lit value 13 | IdentF name -> ident name 14 | LabelF x y -> p [text x, y] 15 | VarF name ast -> c "setq" [ident name, ast] 16 | SetF astl astr -> c "setq" [astl, astr] 17 | ThrowF error -> c "error" [dquotes $ text error] 18 | IfF p l r -> cn "if" [p, progn l, progn r] 19 | ReturnF ast -> ast 20 | FieldF ast name -> field ast name 21 | HasFieldF ast name -> c "gethash" [symbol name, ast] 22 | ObjectF list -> c "oc-hash-from-alist" [if onull list then text "'()" else cn "list" (list &map (\(name,ast) -> symbol name <+> ast))] 23 | CallF name args -> c "funcall" (name : args) 24 | OperatorF name x -> p (text name : x) 25 | ArrayF list -> brackets (sep list) 26 | ConditionOperatorF astb astl astr -> c "if" [astb,astl,astr] 27 | BoolAndsF list -> c "and" list 28 | StmtListF list -> progn list 29 | ParensF x -> x 30 | x -> error $ unwords ["codegen", show x] 31 | 32 | codeGen :: Ast -> Doc 33 | codeGen = code where 34 | code = \case 35 | Set (Field ast name) astr -> c "puthash" [symbol name, code astr, code ast] 36 | Function params body -> func params body 37 | Scope list y -> scope list y 38 | x -> phi $ fmap codeGen $ project x 39 | 40 | scope :: [Ast] -> Ast -> Doc 41 | scope list r = bodyCode vars ffiVars 42 | where 43 | (newBody, ffiVars) = case list ++ [Return r] of (Code x : t) -> (t, x); body -> (body, "") 44 | vars = fmap (\x -> p [ident x, nil]) $ mapMaybe getVarName newBody 45 | bodyCode [] "" = progn $ fmap codeGen newBody 46 | bodyCode vars ffiVars = cn "let*" $ parens (vcat $ text ffiVars : vars) : fmap codeGen newBody 47 | 48 | func :: [String] -> [Ast] -> Doc 49 | func params body = p [text "lambda", p (fmap ident params), bodyCode vars ffiVars] 50 | where 51 | (newBody, ffiVars) = case body of (Code x : t) -> (t, x); _ -> (body, "") 52 | vars = fmap (\x -> p [ident x, nil]) $ mapMaybe getVarName newBody 53 | bodyCode [] "" = progn $ fmap codeGen newBody 54 | bodyCode vars ffiVars = c "let*" [parensNest $ text ffiVars : vars, progn $ fmap codeGen newBody] 55 | 56 | nil = text "nil" 57 | 58 | lit = createLit (('?':) . (:[])) "nil" ("t", "nil") 59 | 60 | convertName x = x & split (startsWithOneOf ['A'..'Z']) <&> toLower & intercalate "-" 61 | 62 | keywords = setFromList ["not", "log", "eq"] 63 | identKw = createIdent keywords 64 | ident name = let newName = convertName name in identKw newName 65 | 66 | parensNest [] = parens empty 67 | parensNest l = nest 2 (lparen <$> vcat l) <$> rparen 68 | 69 | symbol s = text "'" <> ident s 70 | 71 | field ast name = p [text "gethash", symbol name, ast] 72 | 73 | p l = parens (hsep l) 74 | c name args = p (text name : args) 75 | cn name args = nest 2 ((lparen <> text name) <$> vcat args) <> rparen 76 | 77 | progn = \case 78 | [] -> empty 79 | [x] -> x 80 | l -> cn "progn" l 81 | -------------------------------------------------------------------------------- /src/Oczor/CodeGen/CodeGenJs.hs: -------------------------------------------------------------------------------- 1 | module Oczor.CodeGen.CodeGenJs where 2 | import Oczor.CodeGen.Utl 3 | 4 | codeGen :: Ast -> Doc 5 | codeGen = x 6 | where 7 | x = cata $ \case 8 | NoneF -> empty 9 | UniqObjectF {} -> text "{}" 10 | CodeF x -> text x 11 | NotEqualF x y -> sep [x, text "!=", y] 12 | EqualF x y -> sep [x, text "==", y] 13 | LitF value -> lit value 14 | IdentF name -> ident name 15 | VarF name ast -> stmt [text "var", text name, equals, ast] 16 | SetF astl astr -> stmt [astl, equals, astr] 17 | ThrowF error -> stmt [text "throw", dquotes $ text error] 18 | IfF p l r -> hcat [text "if", parens p] <> bracesNest l <> if onull r then empty else text "else" <> bracesNest r 19 | ReturnF ast -> stmt [text "return", ast] 20 | FieldF ast name -> field ast name 21 | HasFieldF ast name -> sep [field ast name, text "!==", text "undefined"] 22 | ObjectF list -> bracesNest $ punctuate comma (list <&> (\(name,ast) -> hsep [ident name, text ":", ast])) 23 | FunctionF params body -> func params body 24 | ScopeF list y -> parens (func [] (list ++ [text "return" <+> y]) ) <> parens empty 25 | CallF name args -> name <> parens (hcat $ punctuate comma args) 26 | OperatorF name param -> (hsep $ case param of {[x] -> [text name, x]; [x,y] -> [x,text name, y]} ) 27 | ArrayF list -> jsArray list 28 | ConditionOperatorF astb astl astr -> parens $ hsep [astb, text "?", astl, text ":", astr] 29 | BoolAndsF list -> parens $ hcat $ punctuate (text " && ") list 30 | StmtListF list -> vcat list 31 | ParensF x -> parens x 32 | LabelF x y -> stmt [text "var", text x, equals, y] 33 | 34 | func params body = hcat [text "function", parens $ hcat $ punctuate comma (params <&> text) ] <> bracesNest body 35 | 36 | lit = createLit show "null" ("true", "false") 37 | 38 | keywords = setFromList ["false", "true", "null", "abstract", "arguments", "boolean", "break", "byte case", "catch", "char", "class", "const continue", "debugger", "default", "delete", "do double", "else", "enum", "eval", "export extends", "false", "final", "finally", "float", "for", "function", "goto", "if", "implements import", "in", "instanceof", "int", "interface let", "long", "native", "new", "null package", "private", "protected", "public", "return short", "static", "super", "switch", "synchronized this", "throw", "throws", "transient", "true try", "typeof", "var", "void", "volatile while", "with", "yield"] 39 | 40 | ident = createIdent keywords 41 | 42 | stmt x = hsep x <> text ";" 43 | 44 | field ast name = ast <> dot <> ident name 45 | 46 | 47 | -------------------------------------------------------------------------------- /src/Oczor/CodeGen/CodeGenLua.hs: -------------------------------------------------------------------------------- 1 | module Oczor.CodeGen.CodeGenLua where 2 | import Oczor.CodeGen.Utl 3 | 4 | codeGen :: Ast -> Doc 5 | codeGen = x 6 | where 7 | x = cata $ \case 8 | NoneF -> empty 9 | UniqObjectF {} -> text "{}" 10 | CodeF x -> text x 11 | NotEqualF x y -> sep [x, text "~=", y] 12 | EqualF x y -> sep [x, text "==", y] 13 | LitF value -> lit value 14 | IdentF i -> ident i 15 | VarF name ast -> hsep [text "local", ident name, equals, ast] 16 | SetF astl astr -> hsep [astl, equals, astr] 17 | ThrowF error -> codeGen (Call (Ident "error") [litString error]) 18 | IfF p l r -> hsep [text "if", p, text "then"] <> nested l <$> (if onull r then end else text "else" <> nested r <$> end) 19 | ScopeF list y -> parens (func [] (list ++ [text "return" <+> y]) ) <> parens empty 20 | ReturnF ast -> hsep [text "return", ast] 21 | FieldF ast name -> field ast name 22 | HasFieldF ast name -> sep [field ast name, text "~=", text "nil"] 23 | ObjectF list -> bracesNest $ punctuate comma (list <&> (\(name,ast) -> hsep [ident name, text "=", ast])) 24 | FunctionF params body -> hcat [text "function", parens $ cat $ punctuate comma (params <&> text) ] <> nested body <$> end 25 | CallF name args -> name <> parens (hsep $ punctuate comma args) 26 | OperatorF name param -> (hsep $ case param of {[x] -> [text name, x]; [x,y] -> [x,text name, y]} ) 27 | ArrayF list -> braces (cat $ punctuate comma list) 28 | ConditionOperatorF astb astl astr -> parens $ hsep [astb, text "and", astl, text "or", astr] 29 | BoolAndsF list -> parens $ cat $ punctuate (text " and ") list 30 | StmtListF list -> vcat list 31 | ParensF x -> parens x 32 | 33 | lit = createLit (show . (:[])) "nil" ("true", "false") 34 | 35 | keywords = setFromList ["print", "and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while"] 36 | 37 | ident = createIdent keywords 38 | 39 | field ast name = ast <> dot <> ident name 40 | 41 | nested l = nest 2 (empty <$> vcat l) 42 | 43 | end = text "end" 44 | 45 | func params body = hcat [text "function", parens $ cat $ punctuate comma (params <&> text) ] <> nested body <$> end 46 | -------------------------------------------------------------------------------- /src/Oczor/CodeGen/CodeGenRuby.hs: -------------------------------------------------------------------------------- 1 | module Oczor.CodeGen.CodeGenRuby where 2 | import Oczor.CodeGen.Utl 3 | 4 | codeGen :: Ast -> Doc 5 | codeGen = x 6 | where 7 | x = cata $ \case 8 | NoneF -> empty 9 | UniqObjectF {} -> text "UniqObject.new" 10 | CodeF x -> text x 11 | NotEqualF x y -> sep [x, text "!=", y] 12 | EqualF x y -> sep [x, text "==", y] 13 | LitF value -> lit value 14 | IdentF i -> ident i 15 | VarF name ast -> hsep [ident name, equals, ast] 16 | SetF astl astr -> hsep [astl, equals, astr] 17 | ThrowF error -> hsep [text "raise", dquotes $ text error] 18 | IfF p l r -> hsep [text "if", p] <> nested l <$> (if onull r then end else text "else" <> nested r <$> end) 19 | ReturnF ast -> hsep [text "return", ast] 20 | FieldF ast name -> field ast name 21 | HasFieldF ast name -> sep [field ast name, text "!=", text "nil"] 22 | ObjectF list -> bracesNest $ punctuate comma (list <&> (\(name,ast) -> hsep [text ":" <> ident name, text "=>", ast])) 23 | FunctionF params body -> hcat [text "->", parens $ cat $ punctuate comma (params <&> text) ] <+> text "do" <> nested body <$> end 24 | ScopeF list y -> parens (func [] (list ++ [text "return" <+> y]) ) <> dot <> parens empty 25 | CallF name args -> name <> dot <> parens (hsep $ punctuate comma args) 26 | OperatorF name param -> (hsep $ case param of {[x] -> [text name, x]; [x,y] -> [x,text name, y]} ) 27 | ArrayF list -> jsArray list 28 | ConditionOperatorF astb astl astr -> parens $ hsep [astb, text "?", astl, text ":", astr] 29 | BoolAndsF list -> parens $ cat $ punctuate (text " && ") list 30 | StmtListF list -> vcat list 31 | ParensF x -> parens x 32 | 33 | func params body = hcat [text "->", parens $ cat $ punctuate comma (params <&> text) ] <+> text "do" <> nested body <$> end 34 | 35 | lit = createLit (('?':) . (:[])) "nil" ("true", "false") 36 | 37 | keywords = setFromList ["__ENCODING__", "def", "in", "self", "__LINE__", "defined?", "module", "super", "__FILE__", "do", "next", "then", "BEGIN", "else", "nil", "true", "END", "elsif", "not", "undef", "alias", "end", "or", "unless", "and", "ensure", "redo", "until", "begin", "false", "rescue", "when", "break", "for", "retry", "while", "case", "if", "return", "yield", "class"] 38 | 39 | ident = createIdent keywords 40 | 41 | field ast name = ast <> brackets (text ":" <> ident name) 42 | 43 | nested l = nest 2 (empty <$> vcat l) 44 | 45 | end = text "end" 46 | -------------------------------------------------------------------------------- /src/Oczor/CodeGen/Utl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | module Oczor.CodeGen.Utl (module Oczor.CodeGen.Utl, module X, (<&>), cata, (&)) where 3 | import Oczor.Converter.CodeGenAst as X 4 | import ClassyPrelude as X hiding ((<>), empty, (<$>), (), bool, group) 5 | import Text.PrettyPrint.Leijen as X 6 | import Oczor.Utl 7 | 8 | deriving instance Show (AstF Doc) 9 | 10 | createIdent :: Set String -> String -> Doc 11 | createIdent keywords x = text $ if member x keywords then "_" ++ x else x 12 | 13 | createLit charFunc null (t,f) = \case 14 | LitInt value -> int value 15 | LitDouble value -> double value 16 | LitChar value -> text $ charFunc value 17 | LitString value -> text $ show value 18 | LitBool value -> text $ if value then t else f 19 | LitNull -> text null 20 | 21 | jsArray = brackets . hcat . punctuate comma 22 | 23 | bracesNest [] = braces empty 24 | bracesNest l = nest 2 (lbrace <$> vcat l) <$> rbrace 25 | -------------------------------------------------------------------------------- /src/Oczor/Compiler/CommandLine.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Compiler.CommandLine where 2 | import ClassyPrelude 3 | import Data.Version (showVersion) 4 | import Options.Applicative 5 | import Oczor.Compiler.Compiler 6 | import Oczor.Compiler.State 7 | import Oczor.Utl hiding (argument) 8 | import Paths_oczor (version) 9 | 10 | data Options = Options 11 | { lng :: String 12 | , output :: String 13 | , showMdl :: Bool 14 | , srcDirList :: [String] 15 | , moduleName :: String} 16 | 17 | options :: Parser Options 18 | options = Options 19 | <$> strOption ( long "lang" <> short 'l' <> value "js" <> showDefault <> metavar "LANGUAGE" <> help "target language (js, lua, rb, el)") 20 | <*> strOption ( long "output" <> short 'o' <> value "output" <> showDefault <> metavar "DIRECTORY" <> help "output directory" ) 21 | <*> switch ( long "browse" <> short 'b' <> help "display the names defined by module" ) 22 | <*> many (strOption ( long "src" <> short 's' <> metavar "DIRECTORIES..." <> help "source file directories" )) 23 | <*> argument str (metavar "FILE") 24 | 25 | optionsToState (Options lng output showMdl srcDirList moduleName) = initState 26 | & outputDir .~ output 27 | & srcDirs .~ srcDirList 28 | & showModule .~ showMdl 29 | & combine .~ True 30 | & lang .~ lng 31 | 32 | runWith :: Options -> IO () 33 | runWith x@Options {} = runCompilerPrint (optionsToState x) $ compileAndWrite (fileToModuleName (moduleName x)) 34 | 35 | desc = unwords ["Oczor compiler", showVersion version] 36 | 37 | run :: IO () 38 | run = execParser opts >>= runWith 39 | where 40 | opts = info (helper <*> options) 41 | ( fullDesc 42 | <> progDesc desc 43 | <> header desc ) 44 | -------------------------------------------------------------------------------- /src/Oczor/Compiler/Files.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Compiler.Files where 2 | 3 | import ClassyPrelude as C 4 | import Control.Monad.Except 5 | import Oczor.Syntax.Syntax 6 | import qualified System.FilePath as Fp 7 | import qualified System.IO.Strict as S 8 | import System.Directory 9 | import Oczor.Compiler.State 10 | import Oczor.Infer.Module 11 | import Oczor.Compiler.Utl 12 | import Oczor.Utl hiding (rewrite) 13 | 14 | read x = io $ S.readFile x 15 | 16 | ocExt = ".oc" 17 | 18 | combinePath :: [String] -> String 19 | combinePath = intercalate "/" 20 | 21 | 22 | fixModuleNameIfDir moduleName = do 23 | let rootName = rootModuleName moduleName 24 | let fileName = combinePath rootName ++ ocExt 25 | maybe moduleName (const rootName) <$> findFilePathInDirs fileName 26 | 27 | findFilePathInDirs fileName = do 28 | dirs <- use srcDirs 29 | cd <- io getCurrentDirectory 30 | let paths = fileName : (dirs <&> (++ fileName)) 31 | headMay <$> io (C.filterM doesFileExist paths) 32 | 33 | filePathOc :: ModuleName -> Compiler FilePath 34 | filePathOc moduleName = do 35 | let fileName = combinePath moduleName ++ ocExt 36 | path <- findFilePathInDirs fileName 37 | maybe (throwError (ModuleNotExists moduleName, (1,1,""))) return path 38 | 39 | ocPathToLangPath :: FilePath -> Compiler FilePath 40 | ocPathToLangPath ocPath = Fp.replaceExtension ocPath <$> use lang 41 | 42 | ocPathToPrePath :: FilePath -> Compiler FilePath 43 | ocPathToPrePath ocPath = Fp.replaceExtension ocPath <$> (use lang <&> ("pre." ++)) 44 | 45 | filePathLangOut :: ModuleName -> Compiler FilePath 46 | filePathLangOut x = langOutputFilePath <$> use outputDir <*> use lang <*> use combine <*> pure x 47 | 48 | langOutputFilePath outputDir lang combine x = 49 | Fp.combine outputDir $ combinePath x ++ bool ".module" "" combine ++ "." ++ lang 50 | 51 | readFileMay file = do 52 | exists <- io $ doesFileExist file 53 | if exists then Just <$> read file 54 | else return Nothing 55 | 56 | readWithFfi :: ModuleName -> Compiler OcWithFfi 57 | readWithFfi file = liftA2 (,) (readLangMay file) (readOc file) 58 | 59 | readOc = filePathOc >=> read 60 | 61 | readLangMay = filePathOc >=> ocPathToLangPath >=> readFileMay 62 | 63 | readPreMay = filePathOc >=> ocPathToPrePath >=> readFileMay 64 | 65 | 66 | readLangOut = filePathLangOut >=> read 67 | -------------------------------------------------------------------------------- /src/Oczor/Compiler/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Oczor.Compiler.State where 3 | 4 | import ClassyPrelude 5 | import Oczor.Infer.InferContext 6 | import Control.Monad.State 7 | import Control.Monad.Except 8 | import Oczor.Syntax.Syntax 9 | 10 | import Oczor.Utl 11 | 12 | type Lang = String 13 | type LangSrc = String 14 | type OcSrc = String 15 | type OcWithFfi = (Maybe String, OcSrc) 16 | 17 | data CompState = CompState { 18 | _lang :: String, 19 | _combine :: Bool, 20 | _loadModules :: Modules, 21 | _modulesLangSrc :: Map ModuleName LangSrc, 22 | _modulesOrder :: [ModuleName], 23 | _srcDirs :: [FilePath], 24 | _outputDir :: FilePath, 25 | _showModule :: Bool, 26 | _compilingModules :: [ModuleName] 27 | } 28 | 29 | makeLenses ''CompState 30 | 31 | initState = CompState { 32 | _lang = "js", 33 | _combine = False, 34 | _loadModules = mempty, 35 | _modulesLangSrc = mempty, 36 | _modulesOrder = mempty, 37 | _srcDirs = ["src/"], 38 | _showModule = False, 39 | _outputDir = "output", 40 | _compilingModules = mempty 41 | } 42 | 43 | 44 | type Compiler a = StateT CompState (ExceptT Error IO) a 45 | 46 | -------------------------------------------------------------------------------- /src/Oczor/Compiler/Utl.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-partial-type-signatures #-} 2 | module Oczor.Compiler.Utl where 3 | 4 | import Oczor.Infer.InferContext 5 | import qualified Oczor.Parser.Parser as Parser 6 | import Oczor.Pretty.Pretty 7 | import Oczor.Syntax.Syntax 8 | import Oczor.Utl 9 | 10 | import ClassyPrelude 11 | import Oczor.Infer.Infer 12 | import Oczor.Converter.Converter 13 | import qualified Oczor.CodeGen.CodeGenJs as Js 14 | import qualified System.FilePath as Fp 15 | import System.Directory 16 | import Control.Monad.Except 17 | import Oczor.Compiler.State 18 | import Data.List.Split (splitOn) 19 | 20 | replace old new = intercalate new . splitOn old 21 | 22 | fileToModuleName = replace ".oc" "" >>> splitOn "." 23 | 24 | liftE :: Either Error t -> Compiler t 25 | liftE = lift . ExceptT . return 26 | 27 | io :: IO a -> Compiler a 28 | io = liftIO 29 | 30 | writeFileCreateDir path txt = createDirectoryIfMissing True (Fp.takeDirectory path) >> writeFileUtf8 path (pack txt) 31 | 32 | inferAllTxtWith :: InferContext -> ModuleName -> String -> Either Error (InferContext, InferExpr) 33 | inferAllTxtWith context fileName x = do 34 | (ast, ops) <- Parser.parseAll Parser.parser x fileName (context & allOperators) 35 | inferAllExpr (context & cmodule . operators .~ ops & cmodule . moduleName .~ fileName) ast 36 | 37 | compileJsPartTxt x = Js.codeGen . uncurry convert2 <$> inferAllTxt x 38 | 39 | inferTxt2 x = putStrLn . pack . either show prettyShow $ inferTxt x 40 | 41 | inferType :: Expr -> Either Error TypeExpr 42 | inferType = fmap (attrType . snd) . inferAllExpr baseTypeContext 43 | 44 | inferTxt :: String -> Either Error TypeExpr 45 | inferTxt = Parser.parseExpr >=> fmap normalizeType . inferType 46 | 47 | inferAstTxt2 :: String -> Either Error InferExpr 48 | inferAstTxt2 = Parser.parseExpr >=> fmap snd . inferAllExpr emptyContext 49 | 50 | inferContext :: InferContext -> ModuleName -> String -> Either Error InferContext 51 | inferContext context fileName x = fst <$> inferAllTxtWith context fileName x 52 | 53 | 54 | inferAllTxt :: String -> Either Error (InferContext, InferExpr) 55 | -- inferAllTxt x | traceArgs ["inferAllTxt", x] = undefined 56 | inferAllTxt = inferAllExpr baseTypeContext <=< Parser.parseExpr 57 | 58 | inferAllTxt2 x = do 59 | let Right (_, ast) = Parser.parseExpr x >>= inferAllExpr emptyContext 60 | putStrLn $ pack (unlines ["ast", show ast]) 61 | return "" 62 | -------------------------------------------------------------------------------- /src/Oczor/Converter/CodeGenAst.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Oczor.Converter.CodeGenAst (module Oczor.Converter.CodeGenAst) where 5 | 6 | import Data.Functor.Foldable.TH 7 | import Data.Functor.Foldable 8 | import ClassyPrelude 9 | import Oczor.Utl 10 | 11 | type Name = String 12 | 13 | data Lits = 14 | LitNull | 15 | LitBool Bool | 16 | LitChar Char | 17 | LitDouble Double | 18 | LitInt Int | 19 | LitString String 20 | deriving (Eq, Ord, Show) 21 | 22 | data Ast = 23 | None | 24 | Lit Lits | 25 | UniqObject String | 26 | Ident Name | 27 | NotEqual Ast Ast | 28 | Operator String [Ast] | 29 | Equal Ast Ast | 30 | Var Name Ast | 31 | Set Ast Ast | 32 | Throw String | 33 | Scope [Ast] Ast | 34 | StmtList [Ast] | 35 | BoolAnds [Ast] | 36 | Array [Ast] | 37 | Return Ast | 38 | HasField Ast Name | 39 | Label Name Ast | 40 | Field Ast Name | 41 | ConditionOperator Ast Ast Ast | 42 | Code String | 43 | Call Ast [Ast] | 44 | Parens Ast | 45 | If Ast [Ast] [Ast] | 46 | Object [(Name, Ast)] | 47 | Function [String] [Ast] 48 | deriving (Show, Eq, Ord) 49 | 50 | makeBaseFunctor ''Ast 51 | 52 | scopeToFunc (ScopeF [] y) = y 53 | scopeToFunc (ScopeF x y) = CallF (Parens (Function [] (embed <$> x <> [ReturnF $ embed y]))) [] 54 | 55 | -- pattern Scope x <- Function _ x 56 | 57 | getVarName (Var x _) = Just x 58 | getVarName _ = Nothing 59 | 60 | isFunction Function{} = True 61 | isFunction _ = False 62 | 63 | astToList (StmtList x) = x 64 | astToList x = [x] 65 | 66 | litString = Lit . LitString 67 | 68 | setField obj label expr = Set (Field obj label) expr 69 | 70 | emptyObject = Object [] 71 | 72 | containsIdents :: [String] -> Ast -> [String] 73 | containsIdents list = cata $ \case 74 | IdentF x | oelem x list -> [x] 75 | x -> ffold x 76 | -------------------------------------------------------------------------------- /src/Oczor/Converter/Rewriter.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Converter.Rewriter where 2 | import Oczor.Utl 3 | import ClassyPrelude 4 | import Oczor.Converter.CodeGenAst 5 | 6 | ffSymbols :: Map String String 7 | ffSymbols = mapFromList [ 8 | ("andBool", "&&"), 9 | ("orBool", "||"), 10 | ("not", "!") 11 | ] 12 | 13 | ffNames :: Map String String 14 | ffNames = mapFromList [ 15 | ("andBool", "and"), 16 | ("orBool", "or"), 17 | ("not", "not") 18 | ] 19 | 20 | ffRules :: Map String (Map String String) 21 | ffRules = (["js", "rb"] <&> (,ffSymbols)) ++ (["lua", "el"] <&> (,ffNames)) & mapFromList 22 | 23 | commonInstancRules = [ 24 | (("Int", "add"), "+"), 25 | (("Int", "mul"), "*"), 26 | (("Int", "sub"), "-"), 27 | (("Double", "add"), "+"), 28 | (("Double", "mul"), "*"), 29 | (("Double", "sub"), "-"), 30 | (("Double", "div"), "/") 31 | ] 32 | intDivRule = [(("Int", "div"), "/")] 33 | 34 | instanceSymbols :: String -> Bool -> Map (String, String) String 35 | instanceSymbols eqOp hasIntDiv = mapFromList $ commonInstancRules ++ bool [] intDivRule hasIntDiv ++ (allTypes <&> (\x -> ((x,"eq"), eqOp))) where 36 | allTypes = ["Int", "Double", "Char", "Bool", "String"] 37 | 38 | instanceNames :: Map (String, String) String 39 | instanceNames = mapFromList $ commonInstancRules ++ intDivRule ++ [ 40 | (("Int", "eq"), "eql"), 41 | (("Double", "eq"), "eql"), 42 | (("Bool", "eq"), "eql"), 43 | (("Char", "eq"), "char-equal"), 44 | (("String", "eq"), "string=") 45 | ] 46 | 47 | instanceRules :: Map String (Map (String, String) String) 48 | instanceRules = [ 49 | ("js", instanceSymbols "===" False), 50 | ("lua", instanceSymbols "==" False), 51 | ("rb", instanceSymbols "==" True), 52 | ("el", instanceNames)] & mapFromList 53 | 54 | rewrite :: String -> Ast -> Ast 55 | rewrite lang = cata $ \case 56 | -- x | traceArgs ["rewrite", show x] -> undefined 57 | FunctionF params [Return (Call expr args)] | (params <&> Ident) == args -> expr -- eta reduction 58 | CallF (Field (Field (Field (Ident "oc") "instances") func) tp) param 59 | | Just operator <- instanceRules & lookup lang >>= lookup (tp, func) -> Parens $ Operator operator param 60 | CallF (Field (Field (Field (Ident "oc") "std") "ff") x) param | Just operator <- ffRules & lookup lang >>= lookup x -> Parens $ Operator operator param 61 | CallF x@Function {} y -> Call (Parens x) y 62 | x -> embed x 63 | -------------------------------------------------------------------------------- /src/Oczor/Infer/InferAst.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Infer.InferAst where 2 | 3 | import ClassyPrelude 4 | import Data.Functor.Foldable 5 | import Oczor.Syntax.Syntax 6 | import Oczor.Infer.Substitutable 7 | import Oczor.Infer.InferContext 8 | import Oczor.Utl 9 | 10 | 11 | type InferExprF = AnnF ExprF (TypeExpr, InferContext) 12 | type InferExpr = Ann ExprF (TypeExpr, InferContext) 13 | 14 | attrType :: Ann a (x, y) -> x 15 | attrType = view (attr . _1) 16 | 17 | annType x y = Ann x (y, emptyContext) 18 | 19 | changeType newTp (Ann x (tp,ctx)) = Ann x (newTp, ctx) 20 | changeContext newCtx (Ann x (tp,ctx)) = Ann x (tp, newCtx) 21 | 22 | removeContext :: InferExpr -> Ann ExprF TypeExpr 23 | removeContext = cata $ \case 24 | (AnnF x y) -> Ann x (fst y) 25 | 26 | instance Substitutable InferExpr where 27 | -- apply s | traceArgs ["apply inferExpr", show s] = undefined 28 | apply s = cata $ \case (AnnF ast (tp,ctx)) -> Ann (apply s ast) (apply s tp, apply s ctx) -- TODO FF (apply ast) 29 | -- ftv = cata $ \case (AnnF ast tp) -> ftv tp 30 | -------------------------------------------------------------------------------- /src/Oczor/Infer/Module.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Oczor.Infer.Module where 3 | import ClassyPrelude 4 | import Oczor.Syntax.Syntax 5 | import Oczor.Utl 6 | 7 | type TypeName = String 8 | type TypeClasses = Map String (String, TypeExpr) 9 | type IsFfi = Bool 10 | 11 | type Instances = Map TypeExpr [ClassName] 12 | 13 | data Module = Module { 14 | _moduleName :: ModuleName, 15 | _idents :: Map String Scheme, 16 | _identsNs :: Map String ModuleName, 17 | _typeIdents :: Map String (TypeExpr, IsFfi), 18 | _instances :: Instances, 19 | _instancesType :: Map (TypeName, ClassName) TypeExpr, 20 | _classes :: TypeClasses, 21 | _operators :: OperatorGroups 22 | } deriving (Eq, Show, Read) 23 | makeLenses ''Module 24 | 25 | rootModuleName :: ModuleName -> ModuleName 26 | rootModuleName moduleName = moduleName ++ [lastEx moduleName] 27 | 28 | 29 | getIdentNs ident mdl = mdl ^. identsNs & lookup ident & fromMaybe (mdl ^. moduleName) 30 | 31 | mergeModules newMdl mdl = 32 | mdl 33 | & idents %~ (\x -> unionMaps [x, newMdl ^. idents]) 34 | & typeIdents %~ (\x -> unionMaps [x, newMdl ^. typeIdents]) 35 | & instancesType %~ (\x -> unionMaps [x, newMdl ^. instancesType]) 36 | & instances %~ (\x -> unionMaps [x, newMdl ^. instances]) 37 | & classes %~ (\x -> unionMaps [x, newMdl ^. classes]) 38 | & operators %~ (\x -> unionOperatorGroups x (newMdl ^. operators)) 39 | & identsNs %~ (\x -> unionMaps [x, (newMdl ^. idents & keys) & map (\x -> (x, newMdl & getIdentNs x)) & mapFromList]) 40 | 41 | 42 | newModule name = Module { 43 | _moduleName = name, 44 | _idents = mempty, 45 | _identsNs = mempty, 46 | _classes = mempty, 47 | _typeIdents = mempty, 48 | _operators = mempty, 49 | _instances = mempty, 50 | _instancesType = mempty 51 | } 52 | -------------------------------------------------------------------------------- /src/Oczor/Infer/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Oczor.Infer.State (Infer(..), freshVar, addSubst, applySubst, emptySubst, letters, renameVarsInType, instantiate, runInfer, fresh) where 3 | 4 | import Oczor.Syntax.Syntax 5 | import Oczor.Utl 6 | import Control.Monad.Except 7 | import Control.Monad.Reader 8 | import Control.Monad.State.Strict 9 | import ClassyPrelude as C 10 | 11 | import Oczor.Infer.InferContext 12 | 13 | import Oczor.Infer.Substitutable 14 | import Oczor.Infer.InferAst 15 | 16 | data InferState = InferState { 17 | _count :: Int, 18 | _inferSubst :: Subst 19 | } 20 | 21 | makeLenses ''InferState 22 | 23 | initInfer :: InferState 24 | initInfer = InferState { 25 | _count = 0, 26 | _inferSubst = emptySubst 27 | } 28 | 29 | addSubst :: Subst -> Infer () 30 | addSubst s = inferSubst %= composeSubst s 31 | 32 | applySubst :: Substitutable a => a -> Infer a 33 | applySubst t = do 34 | subst <- use inferSubst 35 | return $ apply subst t 36 | 37 | letters :: [String] 38 | letters = [1..] >>= flip C.replicateM ['a'..'z'] 39 | 40 | 41 | type Infer = ReaderT InferContext (StateT InferState (Except Error)) 42 | 43 | runInfer :: InferContext -> Infer (InferContext, InferExpr) -> Either Error (InferContext, InferExpr) 44 | runInfer context m = evalStateT (runReaderT m context) initInfer & runExcept 45 | -- runInfer context m = (runReader m context) initInfer & runExcept <&> fst 46 | 47 | -- runInfer :: InferContext -> Infer (InferContext, InferExpr) -> _ 48 | -- runInfer context m = evalStateT (runReaderT m context) initInfer & runExcept 49 | 50 | freshVar :: Infer String 51 | freshVar = do 52 | c <- use count 53 | count += 1 54 | return (unsafeIndex letters c) 55 | 56 | fresh :: Infer TypeExpr 57 | fresh = TypeVar <$> freshVar 58 | 59 | instantiate :: Scheme -> Infer TypeExpr 60 | instantiate (Forall as t) = renameVars as t 61 | 62 | renameVars :: [String] -> TypeExpr -> Infer TypeExpr 63 | renameVars vars tp = do 64 | m <- freshMapping vars 65 | return $ renameTypeVars m tp 66 | 67 | freshMapping :: [String] -> Infer (Map String String) 68 | freshMapping vars = mapFromList <$> mapM (\x -> (x,) <$> freshVar) vars 69 | 70 | renameVarsInType :: TypeExpr -> Infer TypeExpr 71 | -- renameVarsInType tp | traceArgs ["renameVarsInType", show tp]= undefined 72 | renameVarsInType tp = do 73 | let vars = setToList $ ftv tp 74 | renameVars vars tp 75 | -------------------------------------------------------------------------------- /src/Oczor/Infer/Substitutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Oczor.Infer.Substitutable where 3 | 4 | import ClassyPrelude 5 | import Oczor.Syntax.Syntax 6 | import Oczor.Utl 7 | 8 | newtype Subst = Subst (Map String TypeExpr) 9 | deriving (Eq, Ord, Show, Monoid) 10 | 11 | emptySubst :: Subst 12 | emptySubst = mempty 13 | 14 | composeSubst :: Subst -> Subst -> Subst 15 | composeSubst s@(Subst s1) (Subst s2) = Subst $ union (map (apply s) s2) s1 16 | 17 | composeSubstList :: [Subst] -> Subst 18 | composeSubstList = foldr (flip composeSubst) emptySubst 19 | 20 | class Substitutable a where 21 | {-# MINIMAL apply #-} 22 | apply :: Subst -> a -> a 23 | ftv :: a -> Set String 24 | ftv = mempty 25 | 26 | 27 | instance (Substitutable a) => Substitutable (ExprF a) where 28 | apply = map . apply 29 | 30 | makeType :: TypeExpr -> [TypeExpr] -> TypeExpr 31 | -- makeType x y | traceArgs ["makeType", show x, show y] = undefined 32 | makeType (TypePoly param body) arg 33 | | al > pl = error "makeType la > pl" 34 | | al == pl = r 35 | | otherwise = TypePoly (param & drop al) r 36 | where 37 | pl = length param 38 | al = length arg 39 | x = zip param arg & map (\(TypeVar x, y) -> (x,y)) 40 | subst = Subst (x & mapFromList) 41 | r = apply subst body 42 | makeType x arg = error $ unwords ["makeType", show x, show arg] 43 | 44 | normalizeTypeRow t@(TypeRowF x y) = 45 | case x of 46 | TypeVar {} -> TypeRow x (ordNub y) 47 | _ -> x 48 | 49 | normalizeTypeConstraints x@(TypeConstraints clist t) = 50 | if onull newClist then t else TypeConstraints newClist t 51 | where 52 | vars = ftv t & setToList <&> TypeVar 53 | newClist = clist & filter (\(var,_) -> oelem var vars) 54 | 55 | instance Substitutable TypeExpr where 56 | 57 | -- apply x y | traceArgs ["apply typeExpr", show x, show y] = undefined 58 | apply (Subst s) x = cata alg x -- TODO add typepoly case 59 | where 60 | alg = \case 61 | x@TypeConstraintsF {} -> normalizeTypeConstraints $ moveConstraintsOnTop (embed x) 62 | TypeApplyF (TypeApply body param1) param2 -> TypeApply body (param1 ++ param2) 63 | t@TypeRowF {} -> normalizeTypeRow t 64 | t@(TypeVarF x) -> findWithDefault (embed t) x s 65 | x -> embed x 66 | 67 | ftv = setFromList . getTypeVars 68 | 69 | instance Substitutable Scheme where 70 | apply (Subst s) (Forall as t) = Forall as $ apply s' t 71 | where s' = Subst $ foldr deleteMap s as 72 | ftv (Forall as t) = difference (ftv t) (setFromList as) 73 | 74 | instance Substitutable a => Substitutable [a] where 75 | apply = map . apply 76 | ftv = foldMap ftv 77 | 78 | -------------------------------------------------------------------------------- /src/Oczor/Infer/UnifyState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Oczor.Infer.UnifyState where 3 | 4 | import Oczor.Syntax.Syntax 5 | import Oczor.Utl 6 | import ClassyPrelude as C 7 | 8 | import Oczor.Infer.State 9 | 10 | data UnifyState = UnifyState { 11 | _constraints :: ConstraintSet, 12 | _openTypes :: Set String 13 | } deriving (Eq, Show) 14 | 15 | makeLenses ''UnifyState 16 | 17 | initState = UnifyState { 18 | _constraints = mempty, 19 | _openTypes = mempty 20 | } 21 | 22 | type Unify = ReaderT UnifyState Infer 23 | 24 | setGetConstraints :: String -> ConstraintSet -> [String] 25 | setGetConstraints var x = x & filter (\(x,y) -> x == TypeVar var) & map snd 26 | 27 | getConstraints :: String -> UnifyState -> [String] 28 | getConstraints var state = state ^. constraints & setGetConstraints var 29 | 30 | addConstraints list state = state & constraints %~ concatNub list 31 | 32 | removeConstraints :: String -> UnifyState -> UnifyState 33 | removeConstraints var state = state & constraints %~ filter (\(x,y) -> x /= TypeVar var) 34 | -------------------------------------------------------------------------------- /src/Oczor/Parser/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Parser.Lexer where 2 | 3 | import Text.Megaparsec 4 | import qualified Text.Megaparsec.Lexer as L 5 | import ClassyPrelude hiding (try) 6 | import Oczor.Parser.ParserState 7 | 8 | lineComment :: Parser () 9 | lineComment = L.skipLineComment "--" 10 | 11 | blockComment :: Parser () 12 | blockComment = L.skipBlockComment "/*" "*/" 13 | 14 | scn :: Parser () 15 | scn = L.space (void spaceChar) lineComment blockComment 16 | 17 | sc :: Parser () 18 | sc = L.space (void $ oneOf " ") lineComment empty 19 | 20 | lexeme :: Parser a -> Parser a 21 | lexeme = L.lexeme sc 22 | 23 | symbol = L.symbol sc 24 | 25 | identOut :: Parser String 26 | identOut = lexeme $ char '^' *> some identChar 27 | 28 | someIndent :: Parser a -> Parser [a] 29 | someIndent p = do 30 | let sc' = scn 31 | level <- sc' *> L.indentLevel 32 | x <- p 33 | xs <- many (try $ L.indentGuard sc' EQ level *> p) <* sc' 34 | return (x:xs) 35 | 36 | indentOrComma :: Parser a -> Parser [a] 37 | indentOrComma p = try ( someIndent p) <|> commaSep1 p 38 | 39 | litInt = lexeme L.integer 40 | litFloat = lexeme L.float 41 | 42 | litStr :: Parser String 43 | litStr = lexeme $ char '"' *> manyTill L.charLiteral (char '"') 44 | 45 | litChar :: Parser Char 46 | litChar = lexeme $ char '\'' *> L.charLiteral <* char '\'' 47 | 48 | parens = between (symbol "(") (symbol ")") 49 | 50 | brackets = between (symbol "[") (symbol "]") 51 | 52 | rword :: String -> Parser () 53 | rword w = string w *> notFollowedBy identChar *> sc 54 | 55 | rop :: String -> Parser () 56 | rop w = string w *> notFollowedBy opChar *> sc 57 | 58 | rws = ["if", "then", "else", "let", "with", "true", "false", "for", "include", "as", "in", "where", "infix", "infixl", "infixr", "prefix", "postfix", "type", "open", "import", "forall", "case", "class", "ffi", "match", "with"] 59 | 60 | ros = ["=>", "@", "\\", ":", ":=", "<:", "|", "_", "=", "^"] 61 | 62 | ident :: Parser String 63 | ident = identWith lowerChar 64 | 65 | opChar :: Parser Char 66 | opChar = oneOf "!#$%&*+./<=>?@\\^|-~" 67 | 68 | identChar :: Parser Char 69 | identChar = alphaNumChar 70 | 71 | identOp :: Parser String 72 | identOp = lexeme $ some opChar 73 | 74 | identType :: Parser String 75 | identType = identWith upperChar 76 | 77 | identWith x = identWith2 x identChar rws 78 | 79 | identWith2 :: Parser Char -> Parser Char -> [String] -> Parser String 80 | identWith2 x y z = (lexeme . try) (p >>= check) 81 | where 82 | p = liftA2 (:) x (many y) 83 | check x = if x `elem` z 84 | then fail $ "keyword " ++ show x ++ " cannot be an identifier" 85 | else return x 86 | 87 | comma = symbol "," 88 | semi = symbol ";" 89 | 90 | commaSep1 p = p `sepBy1` comma 91 | commaSep0 p = p `sepBy` comma 92 | 93 | semiSep2 p = p `sepBy2` semi 94 | semiSep1 p = p `sepBy1` semi 95 | 96 | sepBy2 p sep = do 97 | x <- p 98 | _ <- sep 99 | y <- p 100 | xs <- many (sep >> p) 101 | return (x:y:xs) 102 | -------------------------------------------------------------------------------- /src/Oczor/Parser/Parser.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Parser.Parser where 2 | 3 | import Text.Megaparsec hiding (label) 4 | import qualified Oczor.Parser.Lexer as L 5 | import ClassyPrelude as C hiding (try) 6 | import Oczor.Syntax.Syntax 7 | import Control.Monad.State 8 | import Oczor.Parser.ParserState 9 | import Oczor.Parser.Utl 10 | import Oczor.Parser.Expr 11 | import Oczor.Parser.Statements 12 | import Oczor.Parser.Types 13 | import Oczor.Utl 14 | 15 | recordItemTopLevel = stmt <|> recordItem 16 | 17 | topLevelRecord :: Parser Expr 18 | topLevelRecord = recordIndentWith recordItemTopLevel 19 | 20 | parser :: Parser Expr 21 | parser = topLevelRecord <* eof 22 | 23 | parseAll :: Parser Expr -> String -> ModuleName -> OperatorGroups -> Either Error (Expr, OperatorGroups) 24 | parseAll parser txt file opGroups = 25 | bimap 26 | ((ParserError . parseErrorPretty) &&& getPosFromError) 27 | (exprListToRecord `bimap` (^. ops)) $ 28 | parse (runStateT parser (emptyState & addOperators opGroups)) (moduleNameToIdent file) txt 29 | 30 | parseExpr :: String -> Either Error Expr 31 | parseExpr x = right fst $ parseAll parser x [] [] 32 | 33 | parset :: String -> IO () 34 | parset x = putStrLn . pack . either show (pshow . removeMD . fst) $ parseAll parser x [] [] 35 | 36 | parseType = parsew $ ExprType <$> typeRecord <* eof 37 | 38 | parsew :: Parser Expr -> String -> Either Error Expr 39 | parsew p x = removeMD . fst <$> parseAll p x [] [] 40 | 41 | getImports :: String -> Either Error [ModuleName] 42 | getImports = map (map (\(Stmt (StmtImport x Nothing)) -> x) . recordToList) . parsew (recordIfSome <$> many (stmtImport <* L.scn)) 43 | -------------------------------------------------------------------------------- /src/Oczor/Parser/ParserState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Oczor.Parser.ParserState where 3 | import Oczor.Syntax.Operators 4 | import Control.Lens 5 | import Text.Megaparsec.Expr 6 | import Control.Monad.State 7 | import ClassyPrelude as C hiding (try) 8 | import Oczor.Syntax.Syntax 9 | import qualified Text.Megaparsec.String as Megaparsec 10 | 11 | type Parser = StateT ParserState Megaparsec.Parser 12 | 13 | data ParserState = ParserState { 14 | _count :: Int, 15 | _asName :: Maybe String, 16 | _ops :: OperatorGroups, 17 | _opTable :: [[Operator Parser Expr]] 18 | } 19 | 20 | makeLenses ''ParserState 21 | 22 | emptyState = ParserState { 23 | _count = 0, 24 | _asName = Nothing, 25 | _ops = [], 26 | _opTable = [] 27 | } 28 | 29 | cleanAsName :: Parser () 30 | cleanAsName = asName .= Nothing 31 | 32 | asNameOrFresh :: Parser String 33 | asNameOrFresh = use asName >>= maybe freshName return 34 | 35 | letters :: [String] 36 | letters = [1..] >>= flip C.replicateM ['a'..'z'] 37 | 38 | freshName :: Parser String 39 | freshName = do 40 | c <- use count 41 | count += 1 42 | return $ sysPrefix ++ unsafeIndex letters c 43 | -------------------------------------------------------------------------------- /src/Oczor/Parser/Statements.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Parser.Statements where 2 | 3 | import Text.Megaparsec hiding (label) 4 | 5 | 6 | 7 | import qualified Oczor.Parser.Lexer as L 8 | import ClassyPrelude as C hiding (try) 9 | import Oczor.Syntax.Syntax 10 | 11 | import Control.Monad.State 12 | 13 | import Oczor.Parser.ParserState 14 | import Oczor.Parser.Utl 15 | import Oczor.Parser.Types 16 | import Oczor.Parser.Expr 17 | 18 | 19 | 20 | stmts = Stmt <$> (stmtOperator <|> stmtOpen) <|> stmtInclude <|> stmtImport 21 | 22 | stmt = md $ choice [stmtSet, stmts, typeDecl, ffiType, ffi, classFn, instanceFn, labelWithType, typeDef] 23 | 24 | moduleName = sepBy1 L.ident (string ".") 25 | 26 | stmtInclude :: Parser Expr 27 | stmtInclude = keywordList "include" includeBody where 28 | includeBody = Stmt . StmtInclude <$> moduleName 29 | 30 | stmtImport = keywordList "import" importBody where 31 | importBody :: Parser Expr 32 | importBody = Stmt <$> liftA2 StmtImport moduleName asName 33 | asName = optional (try $ L.rword "as" *> L.ident) 34 | 35 | stmtOperator :: Parser Stmts 36 | stmtOperator = do 37 | ac <- 38 | (try ( L.rword "infixl") *> return OpInfixL) <|> 39 | (try ( L.rword "infixr") *> return OpInfixR) <|> 40 | (try ( L.rword "infix") *> return OpInfixN) <|> 41 | (try ( L.rword "prefix") *> return OpPrefix) <|> 42 | (try ( L.rword "postfix") *> return OpPostfix) 43 | ident <- L.identOp 44 | prec <- L.litInt 45 | func <- L.ident 46 | let info = newOperatorInfo ac (fromInteger prec) ident func 47 | modify (addOperators [[info]]) 48 | return StmtOperator 49 | 50 | 51 | stmtOpen :: Parser Stmts 52 | stmtOpen = StmtOpen <$> (try (L.rword "open") *> L.ident) 53 | 54 | typeDef :: Parser Expr 55 | typeDef = do 56 | typeLbl <- typeLabel 57 | next <- optional (L.scn *> (try func <|> label)) 58 | maybe (return $ ExprType typeLbl) (`applyWithType` typeLbl) next 59 | 60 | -- class 61 | 62 | keywordList keyword line = try (L.rword keyword) *> (listIfSome <$> L.someIndent line) 63 | 64 | 65 | 66 | classFn :: Parser Expr 67 | classFn = keywordList "class" classBody where 68 | classBody :: Parser Expr 69 | classBody = do 70 | name <- L.ident 71 | var <- L.ident 72 | L.rop ":" 73 | body <- typeRecord 74 | return $ ClassFn name (TypePoly [TypeVar var] body) 75 | 76 | instanceFn :: Parser Expr 77 | instanceFn = keywordList "instance" instanceBody where 78 | instanceBody :: Parser Expr 79 | instanceBody = do 80 | tp <- L.parens typeItem <|> typeIdent 81 | MD _ (RecordLabel name fn) <- record 82 | return $ InstanceFn tp name fn 83 | 84 | ffi :: Parser Expr 85 | ffi = liftA2 Ffi (try ( L.rword "ffi") *> L.ident <* L.rop ":") typeRecord 86 | 87 | ffiType :: Parser Expr 88 | ffiType = do 89 | name <- try (L.rword "ffi" *> L.rword "type") *> L.identType 90 | param <- many typeParam 91 | let body = TypeIdent name 92 | return $ FfiType name (if onull param then body else TypePoly param body) 93 | 94 | -------------------------------------------------------------------------------- /src/Oczor/Parser/Types.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Parser.Types where 2 | 3 | import Text.Megaparsec hiding (label) 4 | import qualified Oczor.Parser.Lexer as L 5 | import ClassyPrelude as C hiding (try) 6 | import Oczor.Syntax.Syntax 7 | import qualified Oczor.Desugar.Desugar as Desugar 8 | import Oczor.Parser.ParserState 9 | import Oczor.Utl 10 | 11 | typeDecl :: Parser Expr 12 | typeDecl = do 13 | name <- try (L.rword "type") *> L.identType 14 | param <- many typeParam <* L.rop "=" 15 | body <- typeRecordIdent 16 | return $ Desugar.typeDecl name param body 17 | 18 | typeUnion :: Parser TypeExpr 19 | typeUnion = TypeUnion <$> try (L.sepBy2 typeUnionItem (L.rop "|")) 20 | 21 | typeConstrain :: Parser (String, [String]) 22 | typeConstrain = unsafeHead . C.uncons <$> try (some L.ident) 23 | 24 | typeConstraints :: Parser TypeExpr 25 | typeConstraints = do 26 | list <- try (L.commaSep1 typeConstrain <* L.rop "<:") 27 | tp <- typeItem 28 | return $ TypeConstraints (separateVarConstraints list) tp 29 | where 30 | separateVarConstraints list = list >>= (\(x, y) -> y &map (\y -> (TypeVar x,y))) 31 | 32 | typeVar :: Parser TypeExpr 33 | typeVar = TypeVar <$> L.ident 34 | 35 | typeFunc :: Parser TypeExpr 36 | typeFunc = do 37 | var <- try (typeRecordComma <* L.rop "=>") 38 | body <- typeItem 39 | return $ TypeFunc var body 40 | 41 | typeApplyParam :: Parser TypeExpr 42 | typeApplyParam = do 43 | name <- typeIdent <|> typeVar 44 | args <- some typeArg 45 | return $ TypeApply name args 46 | 47 | typeUnionItem = choice 48 | [L.parens typeRecord, 49 | typeConstraints, 50 | try typeApplyParam, 51 | typeLabel, 52 | typeVar, 53 | typeIdent] 54 | 55 | typeItem = typeUnion <|> typeUnionItem 56 | 57 | typeArg = choice 58 | [L.parens typeRecord, 59 | typeConstraints, 60 | typeLabel, 61 | typeVar, 62 | typeIdent] 63 | 64 | typeIdent :: Parser TypeExpr 65 | typeIdent = TypeIdent <$> L.identType 66 | 67 | typeIdentWithConstains :: Parser TypeExpr 68 | typeIdentWithConstains = TypeIdent <$> L.identType 69 | 70 | typeLabelWith :: Parser String -> Parser TypeExpr 71 | typeLabelWith x = liftA2 TypeLabel 72 | (try (x <* L.rop ":" <* notFollowedBy (L.rop "="))) 73 | (typeFunc <|> typeUnionItem) 74 | 75 | typeLabel :: Parser TypeExpr 76 | typeLabel = typeLabelWith L.ident 77 | 78 | typeRecord = newTypeRecord <$> L.commaSep1 (typeFunc <|> typeItem) 79 | 80 | typeRecordComma = newTypeRecord <$> L.commaSep1 typeItem 81 | 82 | typeRecordIdent = newTypeRecord <$> L.indentOrComma typeItem 83 | 84 | typeParam :: Parser TypeExpr 85 | typeParam = TypeVar <$> L.ident 86 | -------------------------------------------------------------------------------- /src/Oczor/Parser/Utl.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Parser.Utl where 2 | 3 | import Text.Megaparsec hiding (label) 4 | import qualified Oczor.Parser.Lexer as L 5 | import ClassyPrelude as C hiding (try) 6 | import Oczor.Syntax.Syntax 7 | import Text.Megaparsec.Expr as Ex 8 | import Oczor.Parser.ParserState 9 | import Oczor.Utl 10 | 11 | toAstPosition p = (unPos $ sourceLine p, unPos $ sourceColumn p, sourceName p) 12 | 13 | getAstPosition :: Parser AstPosition 14 | getAstPosition = toAstPosition <$> getPosition 15 | 16 | getPosFromError x = errorPos x & headEx & toAstPosition 17 | 18 | md = liftA2 newMD getAstPosition 19 | 20 | opGroupsToTable :: OperatorGroups -> [[Operator Parser Expr]] 21 | opGroupsToTable ops = ops & map (map infoToOperator) 22 | 23 | infixToCall op = try (L.rop (op ^. opIdent)) *> return (\x y -> Call (Ident $ op ^. opFunc) (Record [x,y])) 24 | opToCall op = try (L.rop (op ^. opIdent)) *> return (Call (Ident $ op ^. opFunc)) 25 | infoToOperator op = 26 | case op ^. assoc of 27 | OpInfixL -> InfixL $ infixToCall op 28 | OpInfixR -> InfixR $ infixToCall op 29 | OpInfixN -> InfixN $ infixToCall op 30 | OpPrefix -> Prefix $ opToCall op 31 | OpPostfix -> Postfix $ opToCall op 32 | 33 | addOperators opGroups state = state & ops .~ operators & opTable .~ table 34 | where 35 | operators = unionOperatorGroups opGroups (state ^. ops) 36 | table = opGroupsToTable operators 37 | 38 | anyOperatorParser = do 39 | L.ros & traverse_ (notFollowedBy . L.rop) 40 | x <- L.identOp 41 | fail $ "operator (" ++ x ++ ") is not defined" 42 | 43 | defOperators :: [[Operator Parser Expr]] 44 | defOperators = 45 | [ 46 | -- [Ex.InfixL ((\x (ExprType y) -> WithType x y) <$ L.rop "::")], 47 | [Ex.InfixL (flip Call <$ L.rop "#")], 48 | [Ex.InfixR (Call <$ L.rop "$")], 49 | [Ex.InfixN anyOperatorParser] 50 | ] 51 | 52 | recordIndentWith :: Parser Expr -> Parser Expr 53 | recordIndentWith x = listToLetOrRecord <$> L.someIndent x 54 | 55 | recordCommaWith item = listToLetOrRecord <$> L.commaSep1 item 56 | 57 | applyWithType (RecordLabel rl body) (TypeLabel tl tp) | rl == tl = return $ RecordLabel rl (WithType body tp) 58 | -- applyWithType (Record l) (TypeRecord tl) = Record (zip l tl & map (uncurry applyWithType)) 59 | -- applyWithType (Function p g b) (TypeFunc tp tb) = Function (applyWithType p tp) g (applyWithType b tb) 60 | -- applyWithType (Let x y) tp = Let x (WithType y tp) 61 | -- applyWithType x t = (WithType x t) 62 | applyWithType x y = fail $ "cannot apply type " ++ show y ++ " to " ++ show x 63 | -------------------------------------------------------------------------------- /src/Oczor/Pretty/Errors.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Pretty.Errors where 2 | import Text.PrettyPrint.Leijen as PP 3 | import ClassyPrelude hiding ((<>), empty, (<$>)) 4 | import Oczor.Syntax.Syntax 5 | import Oczor.Utl hiding ((<+>)) 6 | import Oczor.Pretty.Types 7 | 8 | instance Pretty ErrorType where 9 | pretty = \case 10 | ParserError x -> text x 11 | UnificationFail x y -> hsep [text "cannot unify", pretty x, text "and", pretty y] 12 | InfiniteType x y -> hsep [text "infinite type", text x, pretty y] 13 | TextError x -> text x 14 | CircularDependency x -> hsep [text "circular dependency", commaSep (x <&> (text . moduleNameToIdent))] 15 | NoInstance t cls -> hsep [text "type", pretty t, text "doesn't have instance", text cls] 16 | UnboundVariable x -> hsep [text "unbound variable", text x] 17 | UnboundModule x -> hsep [text "unbound module", text $ moduleNameToIdent x] 18 | ModuleNotExists x -> hsep [text "module", text $ moduleNameToIdent x, text "doesn't exist"] 19 | UnboundType x -> hsep [text "unbound type", text x] 20 | UnboundClass x -> hsep [text "unbound class", text x] 21 | TypeUnionWithUnion x -> hsep [text "union type with union", text x] 22 | UnificationMismatch x y -> hsep [text "unification mismatch", commaSep (x <&> pretty), text "and", commaSep (x <&> pretty)] 23 | 24 | -------------------------------------------------------------------------------- /src/Oczor/Pretty/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Pretty.Pretty ( 2 | module Oczor.Pretty.Pretty, 3 | module X) where 4 | import Text.PrettyPrint.Leijen as PP 5 | import ClassyPrelude 6 | import Oczor.Pretty.Types as X 7 | import Oczor.Pretty.Errors () 8 | 9 | prettyShow x = show $ pretty x 10 | -------------------------------------------------------------------------------- /src/Oczor/Pretty/Types.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Pretty.Types where 2 | import Text.PrettyPrint.Leijen as PP 3 | import ClassyPrelude hiding ((<>), empty, (<$>)) 4 | import Oczor.Syntax.Syntax 5 | import Oczor.Infer.Infer 6 | import Oczor.Utl hiding ((<+>)) 7 | 8 | commaSep list = hcat (punctuate (text ", ") list) 9 | 10 | instance Pretty TypeExpr where 11 | pretty x = cata alg x 0 where 12 | alg ast parentPrec = par $ case ast of 13 | (TypeIdentF name) -> text name 14 | (TypeVarF name) -> text name 15 | (TypeLabelF name eType) -> hsep [text name, char ':', eType prec] 16 | (TypeRecordF list) -> commaSep (list <&> ($ prec) & filter (\x -> show x /= "")) 17 | (TypeRowF x list) -> x prec <> text "@" <> commaSep (list <&> ($ prec)) 18 | (TypeUnionF list) -> hcat (punctuate (text " | ") (list <&> ($ prec))) 19 | (TypeFuncF inType outType) -> hsep [inType prec, text "=>", outType prec] 20 | (TypeApplyF expr arg) -> hsep $ expr prec : (arg <&> ($ prec)) 21 | (TypeConstraintsF list expr) -> hsep [commaSep (list &map (\(x,y) -> x prec <+> text y)), text "<:", expr prec ] 22 | (TypePolyF x y ) -> y prec 23 | NoTypeF -> empty 24 | where 25 | prec = getPrec ast 26 | par = if prec < parentPrec then parens else id 27 | 28 | getPrec = \case 29 | TypeFuncF {} -> 50 30 | TypeRecordF {} -> 60 31 | TypeUnionF {} -> 70 32 | TypeLabelF {} -> 80 33 | TypeConstraintsF {} -> 90 34 | _ -> 100 35 | 36 | 37 | moduleIdents mdl = mdl ^. idents & mapToList <&> (\(ident, Forall _ tp) -> hsep [text ident, char ':', pretty tp]) & vcat 38 | 39 | -------------------------------------------------------------------------------- /src/Oczor/Syntax/Ast.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | 6 | module Oczor.Syntax.Ast (module Oczor.Syntax.Ast, module Oczor.Syntax.Types, Lits(..), Stmts(..)) where 7 | 8 | import ClassyPrelude 9 | import Control.Lens 10 | import Data.Functor.Foldable 11 | import Data.Functor.Foldable.TH 12 | import Oczor.Syntax.Types 13 | 14 | type ModuleName = [String] 15 | 16 | data Lits = 17 | LitChar Char | 18 | LitBool Bool | 19 | LitDouble Double | 20 | LitInt Int | 21 | LitString String 22 | deriving (Eq, Ord, Show, Read) 23 | 24 | data Stmts = 25 | StmtImport ModuleName (Maybe String) | 26 | StmtOpen String | 27 | StmtInclude ModuleName | 28 | StmtOperator 29 | deriving (Eq, Ord, Show, Read) 30 | 31 | type AstPosition = (Word, Word, FilePath) 32 | 33 | type Name = String 34 | 35 | data Expr = 36 | Lit Lits | 37 | UniqObject String | 38 | WildCard | 39 | Ident Name | 40 | ParamIdent Name | 41 | As (Maybe Name) Expr | 42 | Cases [Expr] | 43 | Let Expr Expr | 44 | SetStmt Expr Expr | 45 | RecordLabel Name Expr | 46 | Destruct Expr Expr | 47 | LabelAccess Name | 48 | Call Expr Expr | 49 | Update Expr [Expr] | 50 | ExprList [Expr] | 51 | Record [Expr] | 52 | Function Expr (Maybe Expr) Expr | 53 | TypeDecl Name TypeExpr | 54 | ClassFn Name TypeExpr | 55 | InstanceFn TypeExpr String Expr | 56 | Ffi Name TypeExpr | 57 | FfiType Name TypeExpr | 58 | ExprType TypeExpr | 59 | GetInstance Name TypeExpr | 60 | Array [Expr] | 61 | WithType Expr TypeExpr | 62 | In Bool Expr | 63 | Stmt Stmts | 64 | If Expr Expr Expr | 65 | MD AstPosition Expr 66 | deriving (Eq, Ord, Show, Read) 67 | 68 | makeBaseFunctor ''Expr 69 | 70 | deriving instance Show a => Show (ExprF a) 71 | 72 | data Ann f a = Ann { _unAnn :: f (Ann f a), _attr :: a } deriving (Functor, Foldable, Traversable) 73 | data AnnF f a r = AnnF { _unAnnF :: f r, _attrF :: a } deriving (Functor, Foldable, Traversable) 74 | 75 | makeLenses ''Ann 76 | makeLenses ''AnnF 77 | 78 | type instance Base (Ann f a) = AnnF f a 79 | 80 | instance Functor f => Recursive (Ann f a) where 81 | project = \case Ann f a -> AnnF f a 82 | 83 | instance Functor f => Corecursive (Ann f a) where 84 | embed = \case AnnF f a -> Ann f a 85 | 86 | instance Show a => Show (Ann ExprF a) where 87 | show (Ann x y) = "(" ++ show x ++ " ANN " ++ show y ++ ")" 88 | 89 | stripAnns :: Ann ExprF a -> Expr 90 | stripAnns = cata $ embed . view unAnnF 91 | 92 | pattern UnAnn x <- Ann x y 93 | 94 | pattern ExprListMD x <- MD y (ExprList x) 95 | pattern LabelAccessCall label e = Call (LabelAccess label) e 96 | 97 | -------------------------------------------------------------------------------- /src/Oczor/Syntax/Errors.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Syntax.Errors where 2 | import Oczor.Syntax.Ast 3 | import ClassyPrelude hiding (TVar) 4 | 5 | type Error = (ErrorType, AstPosition) 6 | 7 | data ErrorType = 8 | ParserError String | 9 | UnificationFail TypeExpr TypeExpr | 10 | InfiniteType String TypeExpr | 11 | TextError String | 12 | CircularDependency [ModuleName] | 13 | NoInstance TypeExpr String | 14 | UnboundVariable String | 15 | UnboundModule ModuleName | 16 | ModuleNotExists ModuleName | 17 | UnboundType String | 18 | UnboundClass String | 19 | TypeUnionWithUnion String | 20 | UnificationMismatch [TypeExpr] [TypeExpr] 21 | deriving (Eq, Ord, Show) 22 | 23 | isNoInstance = \case 24 | NoInstance {} -> True 25 | _ -> False 26 | -------------------------------------------------------------------------------- /src/Oczor/Syntax/Operators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Oczor.Syntax.Operators where 3 | import ClassyPrelude 4 | import Control.Lens 5 | 6 | data Assoc 7 | = OpInfixL 8 | | OpInfixR 9 | | OpInfixN 10 | | OpPrefix 11 | | OpPostfix 12 | deriving (Show, Eq, Read) 13 | 14 | data OperatorInfo = OperatorInfo { 15 | _assoc :: Assoc, 16 | _precedence :: Int, 17 | _opIdent :: String, 18 | _opFunc :: String 19 | } deriving (Eq, Show, Read) 20 | newOperatorInfo a p op opf = OperatorInfo {_assoc = a, _precedence = p, _opIdent = op, _opFunc = opf} 21 | makeLenses ''OperatorInfo 22 | 23 | type OperatorGroups = [[OperatorInfo]] 24 | 25 | unionOperatorGroups :: OperatorGroups -> OperatorGroups -> OperatorGroups 26 | unionOperatorGroups l1 l2 = l1 ++ l2 & concat & sortOn (negate . view precedence) & groupAllOn (view precedence) 27 | -------------------------------------------------------------------------------- /src/Oczor/Syntax/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeFamilies, StandaloneDeriving #-} 2 | 3 | module Oczor.Syntax.Types where 4 | 5 | import ClassyPrelude hiding (TVar) 6 | import Data.Functor.Foldable.TH 7 | 8 | data TypeExpr = 9 | TypeIdent String | 10 | TypeVar String | 11 | TypeUnion [TypeExpr] | 12 | TypePoly [TypeExpr] TypeExpr | 13 | TypeConstraints [(TypeExpr, String)] TypeExpr | 14 | TypeFunc TypeExpr TypeExpr | 15 | TypeLabel String TypeExpr | 16 | TypeApply TypeExpr [TypeExpr] | 17 | NoType | 18 | TypeRecord [TypeExpr] | 19 | TypeRow TypeExpr [TypeExpr] 20 | deriving (Eq, Ord, Show, Read) 21 | 22 | makeBaseFunctor ''TypeExpr 23 | 24 | deriving instance Show a => (Show (TypeExprF a)) 25 | 26 | typeBool = TypeIdent "Bool" 27 | typeUnit = TypeIdent "Unit" 28 | typeArray x = TypeApply (TypeIdent "Array") [x] 29 | 30 | type ClassName = String 31 | type ConstraintSet = [(TypeExpr, ClassName)] 32 | 33 | type TVar = String 34 | data Scheme = Forall [TVar] TypeExpr 35 | deriving (Show, Eq, Ord, Read) 36 | -------------------------------------------------------------------------------- /src/Oczor/Test/Files.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Test.Files where 2 | 3 | import System.Directory 4 | import Data.List.Split 5 | import ClassyPrelude hiding (try) 6 | import Oczor.Utl 7 | 8 | import qualified System.FilePath as Fp 9 | import qualified System.IO.Strict as S 10 | 11 | type Test = (Int,(String, String)) 12 | type TestSet = (String, [Test]) 13 | type CheckFunc = String -> Either String String 14 | 15 | root = "tests/" 16 | testsFileExt = ".txt" 17 | 18 | strip :: Char -> String -> String 19 | strip x = stripL x . stripR x where 20 | stripL :: Char -> String -> String 21 | stripL x = dropWhile (==x) 22 | 23 | stripR :: Char -> String -> String 24 | stripR x = reverse . stripL x . reverse 25 | 26 | parseTestTexts txt = (strip '\n' $ unsafeIndex l2 0, strip '\n' $ unsafeIndex l2 1) 27 | where 28 | l = splitOn "\n-" txt 29 | len = length l 30 | l2 = case len of 31 | 1 -> l ++ ["???"] 32 | 2 -> l 33 | _ -> error $ unlines ["wrong format", txt] 34 | 35 | parseTests txt = splitOn "\n=" txt <&> (parseTestTexts . strip '\n') & zip [1..] 36 | 37 | readTestSet :: FilePath -> IO TestSet 38 | readTestSet file = do 39 | txt <- S.readFile file 40 | return (file, parseTests txt) 41 | 42 | newTestSetText f (input, output) = (input, f input & (\(Right x) -> x)) 43 | 44 | dirTestSets d = do 45 | let dir = root ++ d 46 | files <- getTestFiles dir 47 | traverse (\x -> readTestSet (dir ++ "/" ++ x)) files 48 | 49 | findTestSetFilePath dir testsName = do 50 | let dirPath = root ++ dir ++ "/" 51 | let file = dirPath ++ testsName ++ testsFileExt 52 | doesFileExist file >>= \case 53 | True -> return file 54 | False -> do 55 | files <- getTestFiles dirPath <&> filter (isPrefixOf testsName) 56 | case files of 57 | [] -> error $ unwords ["file", testsName, "doesn't exist"] 58 | [x] -> return $ dirPath ++ x 59 | _ -> error $ unwords ["many files", files & intercalate ", "] 60 | 61 | getTestFiles dir = do 62 | files <- getDirectoryContents dir 63 | return (files & filter (not . isPrefixOf ".") & filter (isSuffixOf testsFileExt)) 64 | 65 | createTestFileTxt :: [(String, String)] -> String 66 | createTestFileTxt list = list &map (\(input, output) -> [input, "-", output] & intercalate "\n") &intercalate "\n=\n" 67 | 68 | writeTestFile fileName list = writeFileUtf8 fileName (pack $ createTestFileTxt list) 69 | 70 | refreshFile (d,f) testsName = do 71 | file <- findTestSetFilePath d testsName 72 | (_, tests) <- readTestSet file 73 | let results = tests & map (newTestSetText f . snd) 74 | writeTestFile file results 75 | 76 | refreshDir m@(d,f) = do 77 | let dir = root ++ d 78 | files <- getTestFiles dir 79 | traverse (refreshFile m) (files <&> Fp.dropExtension) 80 | -------------------------------------------------------------------------------- /src/Oczor/Test/Simple.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Test.Simple where 2 | 3 | import Test.Hspec 4 | import Oczor.Syntax.Syntax 5 | import ClassyPrelude 6 | import Oczor.Infer.Substitutable 7 | 8 | o = hspec $ 9 | describe "lit" $ do 10 | it "constraints" $ do 11 | collectConstrainFromTypeExpr (TypeConstraints (singleton ("a", "show")) (TypeVar "a")) `shouldBe` singleton ("a", "show") 12 | collectConstrainFromTypeExpr (TypeConstraints (singleton ("a", "show")) (TypeConstraints (singleton ("b", "eq")) (TypeVar "b"))) `shouldBe` [("b","eq"),("a","show")] 13 | it "composeSubst substs" $ 14 | composeSubstList [Subst (mapFromList [("c",TypeVar "e"),("d",TypeVar "e"),("f",TypeVar "e")]),Subst (mapFromList [("e",TypeIdent "Int"),("g",TypeIdent "Int")])] `shouldBe` Subst (mapFromList [("c",TypeIdent "Int"),("d",TypeIdent "Int"),("e",TypeIdent "Int"),("f",TypeIdent "Int"),("g",TypeIdent "Int")]) 15 | -------------------------------------------------------------------------------- /src/Oczor/Test/TestCompiler.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Test.TestCompiler where 2 | 3 | import Test.Hspec 4 | import Oczor.Syntax.Syntax 5 | import ClassyPrelude 6 | import Oczor.Compiler.Compiler 7 | import qualified System.IO.Strict as S 8 | import Oczor.Compiler.State 9 | import Oczor.Utl 10 | 11 | libs = "libs/" 12 | root = "tests/compiler/" 13 | output = root ++ "output/" 14 | 15 | tests = ["code", "prelude", "import", "numbers", "syntax", "maybe", "foldable", "array", "either", "list"] <&> ("test_" ++) 16 | 17 | tests2 = ["code", "prelude", "numbers", "syntax", "maybe"] <&> ("test_" ++) 18 | 19 | std = ["prelude", "foldable", "maybes", "eithers", "lists"] <&> ("std." ++) 20 | 21 | files = ["testModule", "testing"] ++ std ++ tests 22 | 23 | files2 = do {mdl <- tests2; lang <- ["lua", "rb", "el"]; return (lang, mdl)} 24 | 25 | state lng comb = initState 26 | & outputDir .~ output 27 | & srcDirs .~ [root, libs] 28 | & combine .~ comb 29 | & lang .~ lng 30 | 31 | compileModulesJs :: [ModuleName] -> IO (Either Error (Map ModuleName String)) 32 | compileModulesJs names = runCompiler (state "js" False) $ do 33 | names & traverse_ loadModule 34 | use modulesLangSrc 35 | 36 | 37 | compileSrcJsModule :: ModuleName -> IO (Either Error String) 38 | compileSrcJsModule name = runCompiler (state "js" False) (compileSrc name) 39 | 40 | compilem name = runCompilerPrint (state "js" False) (compileAndWrite $ fileToModuleName name) 41 | 42 | compileLang lang file = runCompilerPrint (state lang True) $ compileAndWrite (fileToModuleName file) 43 | 44 | compile = compileLang "js" 45 | compileLua = compileLang "lua" 46 | compileRb = compileLang "rb" 47 | compileEl = compileLang "el" 48 | 49 | browse file = runCompilerPrint (state "js" False & showModule .~ True) $ compileAndWrite (fileToModuleName file) 50 | 51 | readLangOutSimple outputDir x = S.readFile (langOutputFilePath outputDir "js" False x) 52 | 53 | refreshTests2 = traverse_ (uncurry compileLang) files2 54 | 55 | refreshTests = traverse_ compile tests 56 | 57 | refreshFiles = traverse_ compilem files 58 | 59 | file :: String -> IO (SpecWith ()) 60 | file file = do 61 | let x = fileToModuleName file 62 | input <- compileSrcJsModule x 63 | output <- readLangOutSimple output x 64 | return $ it (moduleNameToIdent x) $ input `shouldBe` Right output 65 | 66 | checkFiles :: [String] -> IO () 67 | checkFiles x = do 68 | l <- traverse file x 69 | hspec $ describe "js" (sequence_ l) 70 | 71 | f = checkFiles files 72 | 73 | 74 | -- ff = checkFilesFast files 75 | -- fileFast :: Map ModuleName String -> String -> _ 76 | -- fileFast modulesJs file = do 77 | -- let x = fileToModuleName file 78 | -- let input = modulesJs & lookupEx x 79 | -- output <- readLangOutSimple output x 80 | -- return $ it file $ do 81 | -- input `shouldBe` output 82 | 83 | -- checkFilesFast :: [String] -> IO () 84 | -- checkFilesFast x = do 85 | -- modulesJs <- either (error . show) id <$> compileModulesJs (x <&> fileToModuleName) 86 | -- l <- traverse (fileFast modulesJs) x 87 | -- hspec $ describe "files" (sequence_ l) 88 | 89 | 90 | -- spec = hspec $ parallel $ do 91 | -- describe "expensiveOperation" $ do 92 | -- replicateM_ 20 $ do 93 | -- it "is expensive" $ do 94 | -- sum [1..100000000] `shouldBe` 5000000050000000 95 | -------------------------------------------------------------------------------- /src/Oczor/Test/TestEngine.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Test.TestEngine where 2 | 3 | import ClassyPrelude hiding (try) 4 | import Test.Hspec 5 | 6 | import Oczor.Test.Files 7 | 8 | checkDir (d,f) = do 9 | testSets <- dirTestSets d 10 | hspec $ describe d $ traverse_ (checkTestSet f) testSets 11 | 12 | checkTestSet :: CheckFunc -> TestSet -> SpecWith () 13 | checkTestSet f (name, list) = describe name $ traverse_ (checkTest f) list 14 | 15 | checkTest :: CheckFunc -> Test -> SpecWith () 16 | checkTest f (id, (l,r)) = it (show id ++ ": " ++ show l) $ 17 | either expectationFailure (\x -> expectTrue (r ++ "\n-\n" ++ x) (x == r)) (f l) 18 | 19 | expectTrue msg b = unless b (expectationFailure msg) 20 | 21 | -------------------------------------------------------------------------------- /src/Oczor/Test/Tests.hs: -------------------------------------------------------------------------------- 1 | module Oczor.Test.Tests where 2 | 3 | import Oczor.Parser.Parser 4 | import Oczor.Syntax.Syntax 5 | import ClassyPrelude 6 | import Oczor.Test.TestEngine 7 | import Oczor.Test.Files 8 | import Oczor.Infer.Infer 9 | import Oczor.Converter.Converter 10 | import Oczor.Converter.Rewriter as Rewriter 11 | import Oczor.CodeGen.CodeGenJs 12 | import Oczor.Test.TestCompiler 13 | import Control.Arrow 14 | import Oczor.Utl 15 | import Oczor.Compiler.Compiler 16 | import Oczor.Pretty.Pretty 17 | 18 | a = p >> i >> t >> c >> cc >> g 19 | 20 | af = a >> f 21 | 22 | mp = ("parser", (show +++ show) . fmap removeMD . parseExpr) 23 | mi = ("infer", Right . either show id . map show . fmap lastType . inferTxt) 24 | my = ("pretty", Right . either show id . map prettyShow . inferTxt) 25 | mt = ("inferast", (show +++ show) . fmap (removeContext . snd) . inferAllTxt) 26 | mc = ("converter", (show +++ show) . convertTxt2) 27 | mcc = ("converter-class", Right . either show show . compileJsPartTxt . pack) 28 | mr = ("rewriter", (show +++ (pshow . Rewriter.rewrite "js")) . convertTxt2) 29 | mg = ("codegen", Right . either show show . compileJsPartTxt . pack) 30 | 31 | p = checkDir mp 32 | refreshp = refreshFile mp 33 | refreshpDir = refreshDir mp 34 | 35 | i = checkDir mi 36 | refreshi = refreshFile mi 37 | refreshiDir = refreshDir mi 38 | 39 | y = checkDir my 40 | refreshy = refreshFile my 41 | refreshyDir = refreshDir my 42 | 43 | t = checkDir mt 44 | refresht = refreshFile mt 45 | refreshtDir = refreshDir mt 46 | 47 | c = checkDir mc 48 | refreshc = refreshFile mc 49 | refreshcDir = refreshDir mc 50 | 51 | cc = checkDir mcc 52 | refreshcc = refreshFile mcc 53 | refreshccDir = refreshDir mcc 54 | 55 | r = checkDir mr 56 | refreshr = refreshFile mr 57 | refreshrDir = refreshDir mr 58 | 59 | g = checkDir mg 60 | refreshg = refreshFile mg 61 | refreshgDir = refreshDir mg 62 | 63 | convertTxt2 = inferAllTxt >=> return . uncurry convert2 64 | 65 | convertTxt = putStrLn . pack . either show pshow . convertTxt2 66 | inferAstTxt = putStrLn . pack . either show pshow . inferAstTxt2 67 | 68 | codegenTxt2 x = do 69 | (context, tast) <- inferAllTxt x 70 | return $ codeGen $ convert2 context tast 71 | 72 | codegenTxt, convertTxt, inferAstTxt :: String -> IO () 73 | codegenTxt = putStrLn . pack . either show show . codegenTxt2 74 | -------------------------------------------------------------------------------- /src/Oczor/Utl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | module Oczor.Utl (module Oczor.Utl, module Control.Arrow, module Control.Lens, Fix(..), ana, refix, cata, embed, project, para, (&)) where 5 | import ClassyPrelude as C 6 | import Control.Arrow 7 | import Data.Function ((&), on) 8 | import qualified Data.Map as M 9 | import Text.Show.Pretty as PP 10 | import Data.Functor.Foldable 11 | import Data.Char as Char 12 | import Control.Monad.Reader 13 | import qualified Data.Foldable as F 14 | import Control.Lens hiding (para, (&)) 15 | 16 | cataM 17 | :: (Monad f, Traversable (Base a), Recursive a) => 18 | (Base a b -> f b) -> a -> f b 19 | cataM f = (>>= f) . cata (traverse (>>= f)) 20 | 21 | eqLength = (==) `on` olength 22 | 23 | groupMapBy :: (Ord b) => (a -> b) -> [a] -> [(b, [a])] 24 | groupMapBy f = M.toList . M.fromListWith (\b [a]-> a : b) . map (f &&& (:[])) 25 | 26 | concatNub x y = x ++ y & ordNub 27 | 28 | toTitleCase :: String -> String 29 | toTitleCase [] = [] 30 | toTitleCase (x : xs) = Char.toUpper x : xs 31 | 32 | notNull = not . onull 33 | 34 | -- trace2 x y = C.trace x y 35 | trace2 x y = y 36 | 37 | ffold = F.fold 38 | 39 | trac y x = trace2 ("\n\n" ++ y ++ ":\n " ++ show x ++ "\n") x 40 | tracep y x = trace2 ("\n\n" ++ y ++ ":\n " ++ pshow x ++ "\n") x 41 | 42 | traceArgs list = trace2 ("\n\n" ++ unlines (zip [0..] list &map (\(i,x) -> ((if i > 0 then " " ++ show i ++ ": " else "") ++ x)))) False 43 | traceResult list = trace2 ("\n\n" ++ unlines (zip [0..] list &map (\(i,x) -> ((if i > 0 then " " ++ show i ++ ": " else "") ++ x)))) True 44 | joinLines :: [String] -> String 45 | joinLines = intercalate "\n" 46 | 47 | pshow :: Show a => a -> String 48 | pshow = PP.ppShow 49 | 50 | unionMaps = unions . reverse 51 | 52 | unsafeUnconsLast = unsafeInit &&& unsafeLast 53 | 54 | lookupEx key = headEx . lookup key 55 | 56 | t31 (x, _, _) = x 57 | t32 (_, x, _) = x 58 | t33 (_, _, x) = x 59 | 60 | localPut x = local (const x) 61 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-9.10 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: 12 | # Override default flag values for local packages and extra-deps 13 | flags: {} 14 | 15 | # Extra package databases containing global packages 16 | extra-package-dbs: [] 17 | 18 | # Control whether we use the GHC we find on the path 19 | # system-ghc: true 20 | 21 | # Require a specific version of stack, using version ranges 22 | # require-stack-version: -any # Default 23 | # require-stack-version: >= 1.0.0 24 | 25 | # Override the architecture used by stack, especially useful on Windows 26 | # arch: i386 27 | # arch: x86_64 28 | 29 | # Extra directories used by stack for building 30 | # extra-include-dirs: [/path/to/dir] 31 | # extra-lib-dirs: [/path/to/dir] 32 | 33 | # Allow a newer minor version of GHC than the snapshot specifies 34 | # compiler-check: newer-minor 35 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Oczor.Test.Tests 2 | import Prelude 3 | 4 | main :: IO () 5 | main = af 6 | -------------------------------------------------------------------------------- /tests/codegen/01 access.txt: -------------------------------------------------------------------------------- 1 | _.foo 2 | - 3 | function(_a){ 4 | return _a.foo; 5 | } 6 | = 7 | x = y = 1 8 | z = x.y 9 | - 10 | (function(){ 11 | var x = { 12 | y : 1 13 | }; 14 | return { 15 | x : x, 16 | z : x.y 17 | } 18 | })() -------------------------------------------------------------------------------- /tests/codegen/02 array.txt: -------------------------------------------------------------------------------- 1 | [1 2 3] 2 | - 3 | [1,2,3] -------------------------------------------------------------------------------- /tests/codegen/03 class eq.txt: -------------------------------------------------------------------------------- 1 | class eq a : (a,a) => Bool 2 | ffi eqInt : (Int,Int) => Bool 3 | ffi eqDouble : (Double, Double) => Bool 4 | instance Int eq = eqInt 5 | result = eq 1 2 6 | - 7 | (function(){ 8 | oc.instances.eq = {}; 9 | var eq = function(x,p1,p2){ 10 | return x(p1,p2); 11 | }; 12 | oc.instances.eq.Int = eqInt; 13 | return { 14 | eq : eq, 15 | eqInt : eqInt, 16 | eqDouble : eqDouble, 17 | result : oc.instances.eq.Int(1,2) 18 | } 19 | })() -------------------------------------------------------------------------------- /tests/codegen/04 classes.txt: -------------------------------------------------------------------------------- 1 | class mempty a: a 2 | instance Int mempty = 0 3 | test : Int 4 | test = mempty 5 | - 6 | (function(){ 7 | oc.instances.mempty = {}; 8 | var mempty = function(x){ 9 | return x; 10 | }; 11 | oc.instances.mempty.Int = 0; 12 | return { 13 | mempty : mempty, 14 | test : mempty(oc.instances.mempty.Int) 15 | } 16 | })() 17 | = 18 | class mempty a: a 19 | instance Int mempty = 0 20 | ffi foo : Int => Int 21 | foo mempty 22 | - 23 | (function(){ 24 | oc.instances.mempty = {}; 25 | var mempty = function(x){ 26 | return x; 27 | }; 28 | oc.instances.mempty.Int = 0; 29 | return { 30 | mempty : mempty, 31 | foo : foo, 32 | item1 : foo(mempty(oc.instances.mempty.Int)) 33 | } 34 | })() 35 | = 36 | class mempty a: a 37 | instance Int mempty = 0 38 | ffi foo : Int => Int 39 | x : Int 40 | x = mempty 41 | foo x 42 | - 43 | (function(){ 44 | oc.instances.mempty = {}; 45 | var mempty = function(x){ 46 | return x; 47 | }; 48 | oc.instances.mempty.Int = 0; 49 | var x = mempty(oc.instances.mempty.Int); 50 | return { 51 | mempty : mempty, 52 | foo : foo, 53 | x : x, 54 | item1 : foo(x) 55 | } 56 | })() 57 | = 58 | class show a: a => String 59 | instance Int show x = "test" 60 | y = show 1 61 | - 62 | (function(){ 63 | oc.instances.show = {}; 64 | var show = function(x,p1){ 65 | return x(p1); 66 | }; 67 | oc.instances.show.Int = function(x){ 68 | return "test"; 69 | }; 70 | return { 71 | show : show, 72 | y : oc.instances.show.Int(1) 73 | } 74 | })() -------------------------------------------------------------------------------- /tests/codegen/05 class show41.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | instance Int show x = "test" 3 | foo x = show x 4 | bar = foo 1 5 | - 6 | (function(){ 7 | oc.instances.show = {}; 8 | var show = function(x,p1){ 9 | return x(p1); 10 | }; 11 | oc.instances.show.Int = function(x){ 12 | return "test"; 13 | }; 14 | var foo = function(_gshow,x){ 15 | return _gshow(x); 16 | }; 17 | return { 18 | show : show, 19 | foo : foo, 20 | bar : foo(oc.instances.show.Int,1) 21 | } 22 | })() -------------------------------------------------------------------------------- /tests/codegen/06 classes2.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | instance Int show x = "test" 3 | foo y = show y 4 | bar = foo 1 5 | - 6 | (function(){ 7 | oc.instances.show = {}; 8 | var show = function(x,p1){ 9 | return x(p1); 10 | }; 11 | oc.instances.show.Int = function(x){ 12 | return "test"; 13 | }; 14 | var foo = function(_gshow,y){ 15 | return _gshow(y); 16 | }; 17 | return { 18 | show : show, 19 | foo : foo, 20 | bar : foo(oc.instances.show.Int,1) 21 | } 22 | })() -------------------------------------------------------------------------------- /tests/codegen/07 classes3.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | ffi astr : (String, String) => String 3 | foo x y = astr (show x) (show y) 4 | - 5 | (function(){ 6 | oc.instances.show = {}; 7 | var show = function(x,p1){ 8 | return x(p1); 9 | }; 10 | var foo = function(_gshow,_jshow,x,y){ 11 | return astr(_gshow(x),_jshow(y)); 12 | }; 13 | return { 14 | show : show, 15 | astr : astr, 16 | foo : foo 17 | } 18 | })() -------------------------------------------------------------------------------- /tests/codegen/08 function.txt: -------------------------------------------------------------------------------- 1 | fst x = x 2 | - 3 | { 4 | fst : function(x){ 5 | return x; 6 | } 7 | } 8 | = 9 | fst x y = x 10 | z = fst 1 2 11 | - 12 | (function(){ 13 | var fst = function(x,y){ 14 | return x; 15 | }; 16 | return { 17 | fst : fst, 18 | z : fst(1,2) 19 | } 20 | })() 21 | = 22 | fst x = y = x 23 | - 24 | { 25 | fst : function(x){ 26 | return { 27 | y : x 28 | }; 29 | } 30 | } -------------------------------------------------------------------------------- /tests/codegen/09 lit.txt: -------------------------------------------------------------------------------- 1 | 1 2 | - 3 | 1 4 | = 5 | 1.1 6 | - 7 | 1.1 8 | = 9 | "test" 10 | - 11 | "test" 12 | = 13 | 'x' 14 | - 15 | 'x' -------------------------------------------------------------------------------- /tests/codegen/10 match.txt: -------------------------------------------------------------------------------- 1 | case (x => x) 2 | - 3 | function(_a1){ 4 | return function(x){ 5 | return x; 6 | }(_a1); 7 | } 8 | = 9 | ffi eq : (a,a) => Bool 10 | bar = case (x | (eq x 1) => 2) 11 | foo = bar 12 | - 13 | (function(){ 14 | var bar = function(_a1){ 15 | if(function(x){ 16 | return eq(x,1); 17 | }(_a1)){ 18 | return function(x){ 19 | return 2; 20 | }(_a1); 21 | }else{ 22 | throw "cases error"; 23 | } 24 | }; 25 | return { 26 | eq : eq, 27 | bar : bar, 28 | foo : bar 29 | } 30 | })() 31 | = 32 | ffi eq : (a,a) => Bool 33 | bar = case 34 | x | (eq x 1) => 2 35 | x | (eq x 2) => 3 36 | foo = bar 37 | - 38 | (function(){ 39 | var bar = function(_a1){ 40 | if(function(x){ 41 | return eq(x,1); 42 | }(_a1)){ 43 | return function(x){ 44 | return 2; 45 | }(_a1); 46 | }else{ 47 | if(function(x){ 48 | return eq(x,2); 49 | }(_a1)){ 50 | return function(x){ 51 | return 3; 52 | }(_a1); 53 | }else{ 54 | throw "cases error"; 55 | } 56 | } 57 | }; 58 | return { 59 | eq : eq, 60 | bar : bar, 61 | foo : bar 62 | } 63 | })() 64 | = 65 | ffi eq : (a,a) => Bool 66 | bar = case (x | (eq x (1,2)) => 3) 67 | foo = bar 68 | - 69 | (function(){ 70 | var bar = function(_a1){ 71 | if(function(x){ 72 | return eq(x,{ 73 | item1 : 1, 74 | item2 : 2 75 | }); 76 | }(_a1)){ 77 | return function(x){ 78 | return 3; 79 | }(_a1); 80 | }else{ 81 | throw "cases error"; 82 | } 83 | }; 84 | return { 85 | eq : eq, 86 | bar : bar, 87 | foo : bar 88 | } 89 | })() 90 | = 91 | ffi eqInt : (Int, Int) => Bool 92 | foo = case 93 | x y | (eqInt x 1) => 2 94 | z => 1 95 | bar = foo 96 | - 97 | (function(){ 98 | var foo = function(_a1){ 99 | if(function(_a){ 100 | return (_a.item1 101 | !== 102 | undefined && _a.item2 103 | !== 104 | undefined && (function(){ 105 | var x = _a.item1; 106 | var y = _a.item2; 107 | return eqInt(x,1) 108 | })()); 109 | }(_a1)){ 110 | return function(_a){ 111 | var x = _a.item1; 112 | var y = _a.item2; 113 | return 2; 114 | }(_a1); 115 | }else{ 116 | return function(z){ 117 | return 1; 118 | }(_a1); 119 | } 120 | }; 121 | return { 122 | eqInt : eqInt, 123 | foo : foo, 124 | bar : foo 125 | } 126 | })() -------------------------------------------------------------------------------- /tests/codegen/11 maybe.txt: -------------------------------------------------------------------------------- 1 | ffi unit : Unit 2 | type None = Unit 3 | none : None 4 | none = unit 5 | type Maybe a = None | just : a 6 | 7 | pureMaybe : a => Maybe a 8 | pureMaybe x = just = x 9 | 10 | class pure f : a => f a 11 | 12 | instance Maybe pure x = pureMaybe x 13 | 14 | foo : Maybe Int 15 | foo = pure 1 16 | - 17 | (function(){ 18 | var pureMaybe = function(x){ 19 | return { 20 | just : x 21 | }; 22 | }; 23 | oc.instances.pure = {}; 24 | var pure = function(x,p1){ 25 | return x(p1); 26 | }; 27 | oc.instances.pure.Maybe = function(x){ 28 | return pureMaybe(x); 29 | }; 30 | return { 31 | unit : unit, 32 | none : unit, 33 | pureMaybe : pureMaybe, 34 | pure : pure, 35 | foo : oc.instances.pure.Maybe(1) 36 | } 37 | })() -------------------------------------------------------------------------------- /tests/codegen/12 record.txt: -------------------------------------------------------------------------------- 1 | x = 1 2 | y = x 3 | - 4 | (function(){ 5 | var x = 1; 6 | return { 7 | x : x, 8 | y : x 9 | } 10 | })() -------------------------------------------------------------------------------- /tests/codegen/13 test.txt: -------------------------------------------------------------------------------- 1 | type Foo = 2 | foo : Int 3 | bar : Int 4 | z : Foo 5 | z = 6 | foo = 1 7 | bar = 1 8 | ffi add : (Int, Int) => Int 9 | func1 x y = add x y 10 | t = z 11 | - 12 | (function(){ 13 | var z = { 14 | foo : 1, 15 | bar : 1 16 | }; 17 | var func1 = function(x,y){ 18 | return add(x,y); 19 | }; 20 | return { 21 | z : z, 22 | add : add, 23 | func1 : func1, 24 | t : z 25 | } 26 | })() -------------------------------------------------------------------------------- /tests/codegen/14 typechange.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | foo : Foo 3 | foo = 1 4 | bar = foo 5 | - 6 | (function(){ 7 | var foo = 1; 8 | return { 9 | foo : foo, 10 | bar : foo 11 | } 12 | })() -------------------------------------------------------------------------------- /tests/codegen/15 types.txt: -------------------------------------------------------------------------------- 1 | ffi type Int 2 | x : Int 3 | x = 1 4 | - 5 | { 6 | x : 1 7 | } -------------------------------------------------------------------------------- /tests/codegen/class-map: -------------------------------------------------------------------------------- 1 | id : a => a 2 | id x = x 3 | 4 | class map f : ((a => b), (f a)) => f b 5 | 6 | type Foo a = foo : a 7 | 8 | fooMap : ((a => b), Foo a) => Foo b 9 | fooMap f y = foo = f y.foo 10 | instance Foo map = fooMap 11 | 12 | y : Foo Int 13 | y = foo = 1 14 | 15 | test = map id y 16 | - 17 | (function () { 18 | var id = function (x) { 19 | return x; 20 | }; 21 | instances.map = {}; 22 | var map = function (x) { 23 | return x; 24 | }; 25 | var fooMap = function (f,y) { 26 | return {foo: f(y.foo)}; 27 | }; 28 | instances.map.Foo = fooMap; 29 | var y = {foo: 1}; 30 | var test = 31 | map(instances.map.Foo)(id,y); 32 | return {id: id 33 | ,map: map 34 | ,fooMap: fooMap 35 | ,y: y 36 | ,test: test}; 37 | }()); -------------------------------------------------------------------------------- /tests/compiler/dirModule/dirFoo.oc: -------------------------------------------------------------------------------- 1 | foo = 1 2 | -------------------------------------------------------------------------------- /tests/compiler/output/std/foldable.module.js: -------------------------------------------------------------------------------- 1 | if(oc.std == null){ 2 | oc.std = {}; 3 | } 4 | oc.std.foldable = (function(){ 5 | oc.instances.foldl = {}; 6 | var foldl = function(x,p1,p2,p3){ 7 | return x(p1,p2,p3); 8 | }; 9 | var any = function(_qfoldl,f,l){ 10 | return _qfoldl(function(a,e){ 11 | return (a || f(e)); 12 | },false,l); 13 | }; 14 | var all = function(_aefoldl,f,l){ 15 | return _aefoldl(function(a,e){ 16 | return (a && f(e)); 17 | },true,l); 18 | }; 19 | var or = function(_amfoldl,l){ 20 | return any(_amfoldl,oc.std.prelude.id,l); 21 | }; 22 | var and = function(_aufoldl,l){ 23 | return all(_aufoldl,oc.std.prelude.id,l); 24 | }; 25 | var sum = function(_azfoldl,_bmzero,_bmadd,l){ 26 | return _azfoldl(_bmadd,oc.std.numbers.zero(_bmzero),l); 27 | }; 28 | var product = function(_brfoldl,_ceone,_cemul,l){ 29 | return _brfoldl(_cemul,oc.std.numbers.one(_ceone),l); 30 | }; 31 | var contains = function(_cteq,_cufoldl,x,l){ 32 | return any(_cufoldl,function(y){ 33 | return _cteq(x,y); 34 | },l); 35 | }; 36 | var count = function(_czfoldl,l){ 37 | return _czfoldl(function(a,e){ 38 | return (a + 1); 39 | },0,l); 40 | }; 41 | var foldMap = function(_dymempty,_dyappend,_dlfoldl,f,l){ 42 | return _dlfoldl(function(a,e){ 43 | return _dyappend(a,f(e)); 44 | },oc.std.prelude.mempty(_dymempty),l); 45 | }; 46 | var concat = function(_ecfoldl,_ehmempty,_ehappend,l){ 47 | return foldMap(_ehmempty,_ehappend,_ecfoldl,oc.std.prelude.id,l); 48 | }; 49 | return { 50 | foldl : foldl, 51 | any : any, 52 | all : all, 53 | or : or, 54 | and : and, 55 | sum : sum, 56 | product : product, 57 | contains : contains, 58 | count : count, 59 | foldMap : foldMap, 60 | concat : concat 61 | } 62 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/std/prelude.module.js: -------------------------------------------------------------------------------- 1 | if(oc.std == null){ 2 | oc.std = {}; 3 | } 4 | oc.std.prelude = (function(){ 5 | var flip = function(f){ 6 | return function(a,b){ 7 | return f(b,a); 8 | }; 9 | }; 10 | var cnst = function(x){ 11 | return function(y){ 12 | return x; 13 | }; 14 | }; 15 | var id = function(x){ 16 | return x; 17 | }; 18 | var fst = function(x,y){ 19 | return x; 20 | }; 21 | var snd = function(x,y){ 22 | return y; 23 | }; 24 | oc.instances.show = {}; 25 | var show = function(x,p1){ 26 | return x(p1); 27 | }; 28 | oc.instances.eq = {}; 29 | var eq = function(x,p1,p2){ 30 | return x(p1,p2); 31 | }; 32 | oc.instances.mempty = {}; 33 | var mempty = function(x){ 34 | return x; 35 | }; 36 | oc.instances.append = {}; 37 | var append = function(x,p1,p2){ 38 | return x(p1,p2); 39 | }; 40 | oc.instances.map = {}; 41 | var map = function(x,p1,p2){ 42 | return x(p1,p2); 43 | }; 44 | oc.instances.apply = {}; 45 | var apply = function(x,p1,p2){ 46 | return x(p1,p2); 47 | }; 48 | oc.instances.pure = {}; 49 | var pure = function(x,p1){ 50 | return x(p1); 51 | }; 52 | oc.instances.bind = {}; 53 | var bind = function(x,p1,p2){ 54 | return x(p1,p2); 55 | }; 56 | oc.instances.traverse = {}; 57 | var traverse = function(x,p1,p2){ 58 | return x(p1,p2); 59 | }; 60 | oc.instances.show.Int = oc.std.ff.showInt; 61 | oc.instances.show.Double = oc.std.ff.showDouble; 62 | oc.instances.show.String = oc.std.ff.showString; 63 | oc.instances.show.Char = oc.std.ff.showChar; 64 | oc.instances.show.Bool = oc.std.ff.showBool; 65 | oc.instances.eq.Int = oc.std.ff.eqInt; 66 | oc.instances.eq.Double = oc.std.ff.eqDouble; 67 | oc.instances.eq.String = oc.std.ff.eqString; 68 | oc.instances.eq.Char = oc.std.ff.eqChar; 69 | oc.instances.eq.Bool = oc.std.ff.eqBool; 70 | oc.instances.mempty.String = ""; 71 | oc.instances.append.String = oc.std.ff.appendString; 72 | return { 73 | flip : flip, 74 | cnst : cnst, 75 | id : id, 76 | fst : fst, 77 | snd : snd, 78 | show : show, 79 | eq : eq, 80 | mempty : mempty, 81 | append : append, 82 | map : map, 83 | apply : apply, 84 | pure : pure, 85 | bind : bind, 86 | traverse : traverse 87 | } 88 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/testModule.module.js: -------------------------------------------------------------------------------- 1 | oc.testModule = (function(){ 2 | oc.instances.zero = {}; 3 | var zero = function(x){ 4 | return x; 5 | }; 6 | var x = 1; 7 | return { 8 | zero : zero, 9 | x : x 10 | } 11 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/test_array.module.js: -------------------------------------------------------------------------------- 1 | oc.test_array = (function(){ 2 | var arr = [1,2,3]; 3 | return { 4 | arr : arr, 5 | item1 : oc.testing.checkEq(function(p1,p2){ 6 | return oc.instances.eq.Array(oc.instances.eq.Int,p1,p2); 7 | },arr,[1,2,3]), 8 | item2 : oc.testing.checkEq(function(p1,p2){ 9 | return oc.instances.eq.Array(oc.instances.eq.Int,p1,p2); 10 | },oc.instances.pure.Array(1),[1]), 11 | item3 : oc.testing.checkEq(function(p1,p2){ 12 | return oc.instances.eq.Array(oc.instances.eq.Int,p1,p2); 13 | },oc.instances.append.Array([1,2],[3,4]),[1,2,3,4]), 14 | item4 : oc.testing.checkEq(function(p1,p2){ 15 | return oc.instances.eq.Array(oc.instances.eq.Int,p1,p2); 16 | },oc.instances.map.Array(function(x){ 17 | return (x + 1); 18 | },arr),[2,3,4]), 19 | item5 : oc.testing.checkEq(oc.instances.eq.Int,oc.instances.foldl.Array(function(a,e){ 20 | return (a + e); 21 | },0,arr),6), 22 | item6 : oc.testing.checkEq(oc.instances.eq.Int,oc.std.arrays.arrayLength(arr),3) 23 | } 24 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/test_code.module.js: -------------------------------------------------------------------------------- 1 | oc.test_code = (function(){ 2 | var x1 = 1; 3 | var x2 = { 4 | foo : 1, 5 | bar : 1 6 | }; 7 | var func = function(x,y){ 8 | return ((x + y) + 1); 9 | }; 10 | var x3 = func(1,2); 11 | var func2 = function(x){ 12 | var temp = (x === 1); 13 | return (! (temp && false)); 14 | }; 15 | return { 16 | x1 : x1, 17 | x2 : x2, 18 | func : func, 19 | x3 : x3, 20 | func2 : func2, 21 | temp1 : x1, 22 | temp2 : x2, 23 | temp3 : x3 24 | } 25 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/test_either.module.js: -------------------------------------------------------------------------------- 1 | oc.test_either = (function(){ 2 | var m = oc.instances.pure.Either(2); 3 | var m2 = oc.instances.pure.Either(3); 4 | var ml = { 5 | left : "foo" 6 | }; 7 | return { 8 | m : m, 9 | m2 : m2, 10 | ml : ml, 11 | item1 : oc.testing.checkEq(oc.instances.eq.Int,oc.std.eithers.fromEither(3,m),2), 12 | item2 : oc.testing.checkEq(oc.instances.eq.Int,oc.std.eithers.fromEither(3,ml),3), 13 | item3 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.eithers.isLeft(ml),true), 14 | item4 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.eithers.isRight(m),true), 15 | item5 : oc.testing.checkEq(function(p1,p2){ 16 | return oc.instances.eq.Either(oc.instances.eq.String,oc.instances.eq.Int,p1,p2); 17 | },oc.instances.map.Either(function(x){ 18 | return (x + 1); 19 | },m),m2), 20 | item6 : oc.testing.checkEq(function(p1,p2){ 21 | return oc.instances.eq.Either(oc.instances.eq.String,oc.instances.eq.Int,p1,p2); 22 | },m,m), 23 | item7 : oc.testing.checkEq(function(p1,p2){ 24 | return oc.instances.eq.Either(oc.instances.eq.String,oc.instances.eq.Int,p1,p2); 25 | },ml,ml), 26 | item8 : oc.testing.checkEq(oc.instances.eq.Bool,(function(p1,p2){ 27 | return oc.instances.eq.Either(oc.instances.eq.String,oc.instances.eq.Int,p1,p2); 28 | })(m,m2),false), 29 | item9 : oc.testing.checkEq(oc.instances.eq.String,(function(p1){ 30 | return oc.instances.show.Either(oc.instances.show.String,oc.instances.show.Int,p1); 31 | })(ml),"foo") 32 | } 33 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/test_foldable.module.js: -------------------------------------------------------------------------------- 1 | oc.test_foldable = { 2 | item1 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.foldable.and(oc.instances.foldl.Array,[true,false]),false), 3 | item2 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.foldable.or(oc.instances.foldl.Array,[true,false]),true), 4 | item3 : oc.testing.checkEq(oc.instances.eq.Int,oc.std.foldable.sum(oc.instances.foldl.Array,oc.instances.zero.Int,oc.instances.add.Int,[1,2,3,4]),10), 5 | item4 : oc.testing.checkEq(oc.instances.eq.Int,oc.std.foldable.product(oc.instances.foldl.Array,oc.instances.one.Int,oc.instances.mul.Int,[1,2,3,4]),24), 6 | item5 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.foldable.contains(oc.instances.eq.Int,oc.instances.foldl.Array,3,[1,2,3,4]),true), 7 | item6 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.foldable.contains(oc.instances.eq.Int,oc.instances.foldl.Array,5,[1,2,3,4]),false), 8 | item7 : oc.testing.checkEq(oc.instances.eq.Int,oc.std.foldable.count(oc.instances.foldl.Array,[1,4,5]),3), 9 | item8 : oc.testing.checkEq(oc.instances.eq.String,oc.std.foldable.concat(oc.instances.foldl.Array,oc.instances.mempty.String,oc.instances.append.String,["123","456","789"]),"123456789") 10 | }; -------------------------------------------------------------------------------- /tests/compiler/output/test_import.module.js: -------------------------------------------------------------------------------- 1 | oc.test_import = (function(){ 2 | oc.instances.zero.Int = 0; 3 | return {} 4 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/test_list.module.js: -------------------------------------------------------------------------------- 1 | oc.test_list = (function(){ 2 | var l = oc.std.lists.range(1,3); 3 | return { 4 | l : l, 5 | item1 : oc.testing.checkEq(oc.instances.eq.Int,oc.std.lists.length(l),3), 6 | item2 : oc.testing.checkEq(function(p1,p2){ 7 | return oc.instances.eq.List(oc.instances.eq.Int,p1,p2); 8 | },l,l) 9 | } 10 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/test_maybe.module.js: -------------------------------------------------------------------------------- 1 | oc.test_maybe = (function(){ 2 | var m = oc.instances.pure.Maybe(2); 3 | var m2 = oc.instances.pure.Maybe(3); 4 | var testNone = oc.std.maybes.none; 5 | var maybeBindFunc = function(_a1){ 6 | if((function(x){ 7 | return oc.std.ff.eqInt(x,1); 8 | })(_a1)){ 9 | return (function(x){ 10 | return oc.std.maybes.none; 11 | })(_a1); 12 | }else{ 13 | if((function(x){ 14 | return oc.std.ff.eqInt(x,2); 15 | })(_a1)){ 16 | return (function(x){ 17 | return { 18 | just : 3 19 | }; 20 | })(_a1); 21 | }else{ 22 | throw "cases error"; 23 | } 24 | } 25 | }; 26 | return { 27 | m : m, 28 | m2 : m2, 29 | testNone : testNone, 30 | maybeBindFunc : maybeBindFunc, 31 | item1 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.maybes.isJust(m),true), 32 | item2 : oc.testing.checkEq(oc.instances.eq.Bool,oc.std.maybes.isNone(testNone),true), 33 | item3 : oc.testing.check((oc.std.maybes.maybe(1,oc.std.prelude.cnst(2),oc.std.maybes.none) === 1)), 34 | item4 : oc.testing.check((oc.std.maybes.maybe(1,function(x){ 35 | return (x + 1); 36 | },m2) === 4)), 37 | item5 : oc.testing.check((oc.std.maybes.fromMaybe(0,oc.std.maybes.none) === 0)), 38 | item6 : oc.testing.check((oc.std.maybes.fromMaybe(0,oc.std.maybes.pureMaybe(2)) === 2)), 39 | item7 : oc.testing.check((oc.std.maybes.fromMaybe(0,m) === 2)), 40 | item8 : oc.testing.check((oc.std.maybes.fromMaybe(0,oc.instances.map.Maybe(function(x){ 41 | return (x + 1); 42 | },m)) === 3)), 43 | item9 : oc.testing.check((oc.std.maybes.fromMaybe(0,oc.instances.bind.Maybe(maybeBindFunc,m)) === 3)), 44 | item10 : oc.testing.check((oc.instances.foldl.Maybe(function(a,e){ 45 | return (a + e); 46 | },1,m) === 3)), 47 | item11 : oc.testing.check((oc.std.maybes.showMaybe(oc.instances.show.Int,testNone) === "none")), 48 | item12 : oc.testing.check(((function(p1){ 49 | return oc.instances.show.Maybe(oc.instances.show.Int,p1); 50 | })(m) === "2")), 51 | item13 : oc.testing.check((function(p1,p2){ 52 | return oc.instances.eq.Maybe(oc.instances.eq.Int,p1,p2); 53 | })(m,m)) 54 | } 55 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/test_numbers.module.js: -------------------------------------------------------------------------------- 1 | oc.test_numbers = { 2 | item1 : oc.testing.checkEq(oc.instances.eq.Bool,(1 === 2),false), 3 | item2 : oc.testing.checkEq(oc.instances.eq.Int,((1 + 2) * 3),9), 4 | item3 : oc.testing.checkEq(oc.instances.eq.Int,(1 + 2),3), 5 | item4 : oc.testing.checkEq(oc.instances.eq.Int,(2 * 3),6), 6 | item5 : oc.testing.checkEq(oc.instances.eq.Int,(9 - 5),4), 7 | item6 : oc.testing.checkEq(oc.instances.eq.Int,oc.instances.div.Int(12,4),3), 8 | item7 : oc.testing.checkEq(oc.instances.eq.Double,(1.0 + 2.0),3.0), 9 | item8 : oc.testing.checkEq(oc.instances.eq.Double,(2.0 * 3.0),6.0), 10 | item9 : oc.testing.checkEq(oc.instances.eq.Double,(9.0 - 5.0),4.0), 11 | item10 : oc.testing.checkEq(oc.instances.eq.Double,(12.0 / 4.0),3.0) 12 | }; -------------------------------------------------------------------------------- /tests/compiler/output/test_prelude.module.js: -------------------------------------------------------------------------------- 1 | oc.test_prelude = { 2 | item1 : oc.testing.checkEq(oc.instances.eq.Bool,(! false),true), 3 | item2 : oc.testing.checkEq(oc.instances.eq.Bool,(true && false),false), 4 | item3 : oc.testing.checkEq(oc.instances.eq.Bool,(true || false),true), 5 | item4 : oc.testing.checkEq(oc.instances.eq.String,oc.instances.show.Int(1),"1"), 6 | item5 : oc.testing.checkEq(oc.instances.eq.String,oc.instances.append.String("123","456"),"123456") 7 | }; -------------------------------------------------------------------------------- /tests/compiler/output/test_syntax.module.js: -------------------------------------------------------------------------------- 1 | oc.test_syntax = (function(){ 2 | var testCases = function(_a1){ 3 | if((function(x){ 4 | return oc.std.ff.eqInt(x,1); 5 | })(_a1)){ 6 | return (function(x){ 7 | return 2; 8 | })(_a1); 9 | }else{ 10 | if((function(x){ 11 | return oc.std.ff.eqInt(x,2); 12 | })(_a1)){ 13 | return (function(x){ 14 | return 3; 15 | })(_a1); 16 | }else{ 17 | if((function(x){ 18 | return oc.std.ff.eqInt(x,3); 19 | })(_a1)){ 20 | return (function(x){ 21 | return 4; 22 | })(_a1); 23 | }else{ 24 | throw "cases error"; 25 | } 26 | } 27 | } 28 | }; 29 | var x = { 30 | foo : 1 31 | }; 32 | var y = (function(){ 33 | var _obj = x; 34 | var _clone = oc.cloneObject(_obj); 35 | _clone.foo = 2; 36 | return _clone 37 | })(); 38 | return { 39 | testCases : testCases, 40 | item1 : oc.testing.checkEq(oc.instances.eq.Int,testCases(2),3), 41 | x : x, 42 | y : y, 43 | item2 : oc.testing.checkEq(oc.instances.eq.Int,y.foo,2) 44 | } 45 | })(); -------------------------------------------------------------------------------- /tests/compiler/output/testing.module.js: -------------------------------------------------------------------------------- 1 | oc.testing = (function(){ 2 | var check = function(b){ 3 | return oc.std.ff.print((b ? "Pass" : "FAIL!!!")); 4 | }; 5 | var checkEq = function(_neq,x,y){ 6 | return check(_neq(x,y)); 7 | }; 8 | return { 9 | check : check, 10 | checkEq : checkEq 11 | } 12 | })(); -------------------------------------------------------------------------------- /tests/compiler/testModule.oc: -------------------------------------------------------------------------------- 1 | import std.numbers 2 | 3 | class zero a : a 4 | x = 1 5 | include std.numbers 6 | 7 | -------------------------------------------------------------------------------- /tests/compiler/test_array.oc: -------------------------------------------------------------------------------- 1 | import 2 | std.prelude 3 | std.foldable 4 | std.maybes 5 | std.arrays 6 | testing 7 | 8 | arr = [1 2 3] 9 | 10 | arr ?= [1 2 3] 11 | 12 | pure 1 ?= [1] 13 | 14 | [1 2] ++ [3 4] ?= [1 2 3 4] 15 | 16 | map (x => x + 1) arr ?= [2 3 4] 17 | 18 | foldl (\a e => a + e) 0 arr ?= 6 19 | 20 | arrayLength arr ?= 3 21 | 22 | /* check $ arrayIsEmpty arrEmpty */ 23 | -------------------------------------------------------------------------------- /tests/compiler/test_code.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | 3 | x1 = 1 4 | x2 = 5 | foo = 1 6 | bar = 1 7 | 8 | func x y = x + y + 1 9 | 10 | x3 = func 1 2 11 | 12 | func2 x = 13 | temp = x == 1 14 | in not (temp && false) 15 | 16 | temp1 = x1 17 | temp2 = x2 18 | temp3 = x3 19 | -------------------------------------------------------------------------------- /tests/compiler/test_either.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import std.eithers 3 | import testing 4 | 5 | 6 | m : Either String Int 7 | m = pure 2 8 | 9 | m2 : Either String Int 10 | m2 = pure 3 11 | 12 | ml : Either String Int 13 | ml = left = "foo" 14 | 15 | fromEither 3 m ?= 2 16 | fromEither 3 ml ?= 3 17 | 18 | isLeft ml ?= true 19 | isRight m ?= true 20 | 21 | map (x => x + 1) m ?= m2 22 | 23 | m ?= m 24 | ml ?= ml 25 | eq m m2 ?= false 26 | 27 | show ml ?= "foo" 28 | -------------------------------------------------------------------------------- /tests/compiler/test_empty.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import testing 3 | 4 | type Maybe a = none | just : a 5 | 6 | maybe : b, (a => b), (Maybe a) => b 7 | maybe x f m = m # case 8 | ^none => x 9 | z => f z.just 10 | 11 | maybe 2 (x => 3) none ?= 2 12 | maybe 2 (x => 3) (just = 1) ?= 3 13 | -------------------------------------------------------------------------------- /tests/compiler/test_foldable.oc: -------------------------------------------------------------------------------- 1 | import std 2 | import testing 3 | 4 | and [true false] ?= false 5 | or [true false] ?= true 6 | 7 | sum [1 2 3 4] ?= 10 8 | product [1 2 3 4] ?= 24 9 | 10 | contains 3 [1 2 3 4] ?= true 11 | contains 5 [1 2 3 4] ?= false 12 | 13 | count [1 4 5] ?= 3 14 | 15 | concat ["123" "456" "789"] ?= "123456789" 16 | 17 | -------------------------------------------------------------------------------- /tests/compiler/test_import.oc: -------------------------------------------------------------------------------- 1 | import testModule 2 | 3 | instance Int zero = 0 4 | -------------------------------------------------------------------------------- /tests/compiler/test_importDir.oc: -------------------------------------------------------------------------------- 1 | import dirModule.dirFoo 2 | 3 | bar = foo 4 | -------------------------------------------------------------------------------- /tests/compiler/test_list.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import std.maybes 3 | import std.lists 4 | import testing 5 | 6 | l = range 1 3 7 | 8 | length l ?= 3 9 | l ?= l 10 | 11 | /* check ((fromMaybe 0 (head l)) == 1) */ 12 | -------------------------------------------------------------------------------- /tests/compiler/test_maybe.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import testing 3 | import std.foldable 4 | import std.maybes 5 | 6 | 7 | m : Maybe Int 8 | m = pure 2 9 | 10 | m2 : Maybe Int 11 | m2 = pure 3 12 | 13 | testNone : Maybe Int 14 | testNone = none 15 | 16 | maybeBindFunc : Int => Maybe Int 17 | maybeBindFunc = case 18 | x | (eqInt x 1) => none 19 | x | (eqInt x 2) => just = 3 20 | 21 | isJust m ?= true 22 | isNone testNone ?= true 23 | 24 | check ((maybe 1 (cnst 2) none) == 1) 25 | check ((maybe 1 (x => x + 1) m2) == 4) 26 | 27 | check ((fromMaybe 0 none) == 0) 28 | check ((fromMaybe 0 (pureMaybe 2)) == 2) 29 | 30 | check ((fromMaybe 0 m) == 2) 31 | check ((fromMaybe 0 (map (x => x + 1) m)) == 3) 32 | 33 | check ((fromMaybe 0 (bind maybeBindFunc m)) == 3) 34 | check ((foldl (\a e => a + e) 1 m) == 3) 35 | 36 | check ((showMaybe testNone) == "none") 37 | check ((show m) == "2") 38 | 39 | check (eq m m) 40 | 41 | -------------------------------------------------------------------------------- /tests/compiler/test_numbers.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import testing 3 | 4 | 1 == 2 ?= false 5 | 6 | (1 + 2) * 3 ?= 9 7 | 8 | 1 + 2 ?= 3 9 | 2 * 3 ?= 6 10 | 9 - 5 ?= 4 11 | 12 / 4 ?= 3 12 | 13 | 1.0 + 2.0 ?= 3.0 14 | 2.0 * 3.0 ?= 6.0 15 | 9.0 - 5.0 ?= 4.0 16 | 12.0 / 4.0 ?= 3.0 17 | -------------------------------------------------------------------------------- /tests/compiler/test_prelude.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import testing 3 | 4 | not false ?= true 5 | true && false ?= false 6 | true || false ?= true 7 | 8 | show 1 ?= "1" 9 | 10 | "123" ++ "456" ?= "123456" 11 | 12 | -------------------------------------------------------------------------------- /tests/compiler/test_syntax.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | import testing 3 | 4 | testCases = case 5 | x | (eqInt x 1) => 2 6 | x | (eqInt x 2) => 3 7 | x | (eqInt x 3) => 4 8 | 9 | testCases 2 ?= 3 10 | 11 | x = foo = 1 12 | y = x with foo = 2 13 | y.foo ?= 2 14 | -------------------------------------------------------------------------------- /tests/compiler/testing.oc: -------------------------------------------------------------------------------- 1 | import std.prelude 2 | 3 | check b = print (if b then "Pass" else "FAIL!!!") 4 | 5 | checkEq : (a eq <: (a,a)) => Unit 6 | checkEq x y = check (x == y) 7 | 8 | infix ?= 0 checkEq 9 | -------------------------------------------------------------------------------- /tests/compiler/tests.bat: -------------------------------------------------------------------------------- 1 | node output/test_prelude 2 | node output/test_numbers 3 | node output/test_syntax 4 | node output/test_array 5 | node output/test_maybe 6 | node output/test_foldable 7 | node output/test_either 8 | node output/test_list 9 | -------------------------------------------------------------------------------- /tests/compiler/tests2.bat: -------------------------------------------------------------------------------- 1 | lua output/test_prelude.lua 2 | lua output/test_numbers.lua 3 | lua output/test_syntax.lua 4 | lua output/test_maybe.lua 5 | 6 | ruby output/test_prelude.rb 7 | ruby output/test_numbers.rb 8 | ruby output/test_syntax.rb 9 | ruby output/test_maybe.rb 10 | 11 | call elisp output/test_prelude.el 12 | call elisp output/test_numbers.el 13 | call elisp output/test_syntax.el 14 | call elisp output/test_maybe.el 15 | -------------------------------------------------------------------------------- /tests/converter-class/01 class-body.txt: -------------------------------------------------------------------------------- 1 | class zero a: a 2 | - 3 | oc.instances.zero = {}; 4 | var zero = function(x){ 5 | return x; 6 | }; 7 | = 8 | class show a: a => String 9 | - 10 | oc.instances.show = {}; 11 | var show = function(x,p1){ 12 | return x(p1); 13 | }; 14 | = 15 | class eq a: a, a => Bool 16 | - 17 | oc.instances.eq = {}; 18 | var eq = function(x,p1,p2){ 19 | return x(p1,p2); 20 | }; -------------------------------------------------------------------------------- /tests/converter-class/02 class-show.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | - 3 | oc.instances.show = {}; 4 | var show = function(x,p1){ 5 | return x(p1); 6 | }; 7 | = 8 | class show a: a => String 9 | instance Int show x = "test" 10 | - 11 | (function(){ 12 | oc.instances.show = {}; 13 | var show = function(x,p1){ 14 | return x(p1); 15 | }; 16 | oc.instances.show.Int = function(x){ 17 | return "test"; 18 | }; 19 | return { 20 | show : show 21 | } 22 | })() 23 | = 24 | class show a: a => String 25 | instance Int show x = "test" 26 | y = show 1 27 | - 28 | (function(){ 29 | oc.instances.show = {}; 30 | var show = function(x,p1){ 31 | return x(p1); 32 | }; 33 | oc.instances.show.Int = function(x){ 34 | return "test"; 35 | }; 36 | return { 37 | show : show, 38 | y : oc.instances.show.Int(1) 39 | } 40 | })() 41 | = 42 | class show a: a => String 43 | foo = show 44 | - 45 | (function(){ 46 | oc.instances.show = {}; 47 | var show = function(x,p1){ 48 | return x(p1); 49 | }; 50 | var foo = function(_cshow,p1){ 51 | return show(_cshow,p1); 52 | }; 53 | return { 54 | show : show, 55 | foo : foo 56 | } 57 | })() -------------------------------------------------------------------------------- /tests/converter-class/03 class-call.txt: -------------------------------------------------------------------------------- 1 | class zero a: a 2 | foo = zero 3 | - 4 | (function(){ 5 | oc.instances.zero = {}; 6 | var zero = function(x){ 7 | return x; 8 | }; 9 | var foo = function(_dzero){ 10 | return zero(_dzero); 11 | }; 12 | return { 13 | zero : zero, 14 | foo : foo 15 | } 16 | })() 17 | = 18 | class show a: a => String 19 | foo x = show x 20 | - 21 | (function(){ 22 | oc.instances.show = {}; 23 | var show = function(x,p1){ 24 | return x(p1); 25 | }; 26 | var foo = function(_fshow,x){ 27 | return _fshow(x); 28 | }; 29 | return { 30 | show : show, 31 | foo : foo 32 | } 33 | })() 34 | = 35 | class eq a: a, a => Bool 36 | foo x y = eq x y 37 | - 38 | (function(){ 39 | oc.instances.eq = {}; 40 | var eq = function(x,p1,p2){ 41 | return x(p1,p2); 42 | }; 43 | var foo = function(_heq,x,y){ 44 | return _heq(x,y); 45 | }; 46 | return { 47 | eq : eq, 48 | foo : foo 49 | } 50 | })() -------------------------------------------------------------------------------- /tests/converter-class/04 class-show.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | foo = show 3 | - 4 | (function(){ 5 | oc.instances.show = {}; 6 | var show = function(x,p1){ 7 | return x(p1); 8 | }; 9 | var foo = function(_cshow,p1){ 10 | return show(_cshow,p1); 11 | }; 12 | return { 13 | show : show, 14 | foo : foo 15 | } 16 | })() -------------------------------------------------------------------------------- /tests/converter-class/05 class-show.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | foo = show 3 | - 4 | (function(){ 5 | oc.instances.show = {}; 6 | var show = function(x,p1){ 7 | return x(p1); 8 | }; 9 | var foo = function(_cshow,p1){ 10 | return show(_cshow,p1); 11 | }; 12 | return { 13 | show : show, 14 | foo : foo 15 | } 16 | })() 17 | = 18 | class show a: a => String 19 | ffi astr : (String, String) => String 20 | foo x y = astr (show x) (show y) 21 | - 22 | (function(){ 23 | oc.instances.show = {}; 24 | var show = function(x,p1){ 25 | return x(p1); 26 | }; 27 | var foo = function(_gshow,_jshow,x,y){ 28 | return astr(_gshow(x),_jshow(y)); 29 | }; 30 | return { 31 | show : show, 32 | astr : astr, 33 | foo : foo 34 | } 35 | })() -------------------------------------------------------------------------------- /tests/converter-class/06 class-show.txt: -------------------------------------------------------------------------------- 1 | class show1 a: a => String 2 | class show2 a: a => String 3 | instance Int show1 x = "test" 4 | instance Double show2 x = "test" 5 | ffi astr : (String, String) => String 6 | foo x y = astr (show1 x) (show2 y) 7 | bar = foo 1 2.0 8 | - 9 | (function(){ 10 | oc.instances.show1 = {}; 11 | var show1 = function(x,p1){ 12 | return x(p1); 13 | }; 14 | oc.instances.show2 = {}; 15 | var show2 = function(x,p1){ 16 | return x(p1); 17 | }; 18 | oc.instances.show1.Int = function(x){ 19 | return "test"; 20 | }; 21 | oc.instances.show2.Double = function(x){ 22 | return "test"; 23 | }; 24 | var foo = function(_jshow1,_mshow2,x,y){ 25 | return astr(_jshow1(x),_mshow2(y)); 26 | }; 27 | return { 28 | show1 : show1, 29 | show2 : show2, 30 | astr : astr, 31 | foo : foo, 32 | bar : foo(oc.instances.show1.Int,oc.instances.show2.Double,1,2.0) 33 | } 34 | })() -------------------------------------------------------------------------------- /tests/converter-class/07 class-show.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | instance Int show x = "test" 3 | foo x = show x 4 | bar = foo 1 5 | - 6 | (function(){ 7 | oc.instances.show = {}; 8 | var show = function(x,p1){ 9 | return x(p1); 10 | }; 11 | oc.instances.show.Int = function(x){ 12 | return "test"; 13 | }; 14 | var foo = function(_gshow,x){ 15 | return _gshow(x); 16 | }; 17 | return { 18 | show : show, 19 | foo : foo, 20 | bar : foo(oc.instances.show.Int,1) 21 | } 22 | })() -------------------------------------------------------------------------------- /tests/converter-class/08 class-show.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | instance Int show x = "test" 3 | ffi astr : (String, String) => String 4 | foo x y = astr (show x) (show y) 5 | bar = foo 1 2 6 | - 7 | (function(){ 8 | oc.instances.show = {}; 9 | var show = function(x,p1){ 10 | return x(p1); 11 | }; 12 | oc.instances.show.Int = function(x){ 13 | return "test"; 14 | }; 15 | var foo = function(_hshow,_kshow,x,y){ 16 | return astr(_hshow(x),_kshow(y)); 17 | }; 18 | return { 19 | show : show, 20 | astr : astr, 21 | foo : foo, 22 | bar : foo(oc.instances.show.Int,oc.instances.show.Int,1,2) 23 | } 24 | })() -------------------------------------------------------------------------------- /tests/converter-class/09 cases-show.txt: -------------------------------------------------------------------------------- 1 | class show a : a => String 2 | foo = case 3 | x => show x 4 | - 5 | (function(){ 6 | oc.instances.show = {}; 7 | var show = function(x,p1){ 8 | return x(p1); 9 | }; 10 | var foo = function(_fshow,_a1){ 11 | return function(x){ 12 | return _fshow(x); 13 | }(_a1); 14 | }; 15 | return { 16 | show : show, 17 | foo : foo 18 | } 19 | })() -------------------------------------------------------------------------------- /tests/converter-class/10 class-show-foo.txt: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | class show a: a => String 3 | showFoo : Foo ((a show <: a)) => String 4 | showFoo x = show x.foo 5 | - 6 | (function(){ 7 | oc.instances.show = {}; 8 | var show = function(x,p1){ 9 | return x(p1); 10 | }; 11 | var showFoo = function(_lshow,x){ 12 | return _lshow(x.foo); 13 | }; 14 | return { 15 | show : show, 16 | showFoo : showFoo 17 | } 18 | })() 19 | = 20 | type Foo a = foo : a 21 | class show a: a => String 22 | instance Int show x = "int" 23 | showFoo : Foo ((a show <: a)) => String 24 | showFoo x = show x.foo 25 | bar = showFoo (foo = 1) 26 | - 27 | (function(){ 28 | oc.instances.show = {}; 29 | var show = function(x,p1){ 30 | return x(p1); 31 | }; 32 | oc.instances.show.Int = function(x){ 33 | return "int"; 34 | }; 35 | var showFoo = function(_mshow,x){ 36 | return _mshow(x.foo); 37 | }; 38 | return { 39 | show : show, 40 | showFoo : showFoo, 41 | bar : showFoo(oc.instances.show.Int,{ 42 | foo : 1 43 | }) 44 | } 45 | })() 46 | = 47 | type Foo a = foo : a 48 | class show a: a => String 49 | showFoo : Foo ((a show <: a)) => String 50 | showFoo x = show x.foo 51 | instance (Foo (a show <: a)) show x = showFoo x 52 | - 53 | (function(){ 54 | oc.instances.show = {}; 55 | var show = function(x,p1){ 56 | return x(p1); 57 | }; 58 | var showFoo = function(_lshow,x){ 59 | return _lshow(x.foo); 60 | }; 61 | oc.instances.show.Foo = function(_nshow,x){ 62 | return showFoo(_nshow,x); 63 | }; 64 | return { 65 | show : show, 66 | showFoo : showFoo 67 | } 68 | })() 69 | = 70 | type Foo a = foo : a 71 | class show a: a => String 72 | showFoo : Foo ((a show <: a)) => String 73 | showFoo x = show x.foo 74 | instance (Foo (a show <: a)) show x = showFoo x 75 | instance Int show x = "int" 76 | foo : Foo Int 77 | foo = foo = 2 78 | 79 | bar = show foo 80 | - 81 | (function(){ 82 | oc.instances.show = {}; 83 | var show = function(x,p1){ 84 | return x(p1); 85 | }; 86 | var showFoo = function(_lshow,x){ 87 | return _lshow(x.foo); 88 | }; 89 | oc.instances.show.Foo = function(_nshow,x){ 90 | return showFoo(_nshow,x); 91 | }; 92 | oc.instances.show.Int = function(x){ 93 | return "int"; 94 | }; 95 | var foo = { 96 | foo : 2 97 | }; 98 | return { 99 | show : show, 100 | showFoo : showFoo, 101 | foo : foo, 102 | bar : function(p1){ 103 | return oc.instances.show.Foo(oc.instances.show.Int,p1); 104 | }(foo) 105 | } 106 | })() -------------------------------------------------------------------------------- /tests/converter-class/11 class-mempty.txt: -------------------------------------------------------------------------------- 1 | class mempty a: a 2 | - 3 | oc.instances.mempty = {}; 4 | var mempty = function(x){ 5 | return x; 6 | }; 7 | = 8 | class mempty a: a 9 | instance Int mempty = 0 10 | foo : Int 11 | foo = mempty 12 | - 13 | (function(){ 14 | oc.instances.mempty = {}; 15 | var mempty = function(x){ 16 | return x; 17 | }; 18 | oc.instances.mempty.Int = 0; 19 | return { 20 | mempty : mempty, 21 | foo : mempty(oc.instances.mempty.Int) 22 | } 23 | })() 24 | = 25 | class mempty a: a 26 | instance Int mempty = 0 27 | ffi foo : Int => Int 28 | foo mempty 29 | - 30 | (function(){ 31 | oc.instances.mempty = {}; 32 | var mempty = function(x){ 33 | return x; 34 | }; 35 | oc.instances.mempty.Int = 0; 36 | return { 37 | mempty : mempty, 38 | foo : foo, 39 | item1 : foo(mempty(oc.instances.mempty.Int)) 40 | } 41 | })() 42 | = 43 | class mempty a: a 44 | instance Int mempty = 0 45 | foo = mempty 46 | bar : Int 47 | bar = foo 48 | - 49 | (function(){ 50 | oc.instances.mempty = {}; 51 | var mempty = function(x){ 52 | return x; 53 | }; 54 | oc.instances.mempty.Int = 0; 55 | var foo = function(_dmempty){ 56 | return mempty(_dmempty); 57 | }; 58 | return { 59 | mempty : mempty, 60 | foo : foo, 61 | bar : foo(oc.instances.mempty.Int) 62 | } 63 | })() 64 | = 65 | class mempty a: a 66 | instance Int mempty = 0 67 | ffi foo : Int => Int 68 | x : Int 69 | x = mempty 70 | foo x 71 | - 72 | (function(){ 73 | oc.instances.mempty = {}; 74 | var mempty = function(x){ 75 | return x; 76 | }; 77 | oc.instances.mempty.Int = 0; 78 | var x = mempty(oc.instances.mempty.Int); 79 | return { 80 | mempty : mempty, 81 | foo : foo, 82 | x : x, 83 | item1 : foo(x) 84 | } 85 | })() 86 | = 87 | class mempty a: a 88 | instance Int mempty = 0 89 | ffi foo : Int => Int 90 | x = mempty 91 | foo x 92 | - 93 | (function(){ 94 | oc.instances.mempty = {}; 95 | var mempty = function(x){ 96 | return x; 97 | }; 98 | oc.instances.mempty.Int = 0; 99 | var x = function(_dmempty){ 100 | return mempty(_dmempty); 101 | }; 102 | return { 103 | mempty : mempty, 104 | foo : foo, 105 | x : x, 106 | item1 : foo(x(oc.instances.mempty.Int)) 107 | } 108 | })() 109 | = 110 | /* class mempty a: a */ 111 | /* instance Int mempty = 0 */ 112 | /* foo = bar = mempty */ 113 | 1 114 | - 115 | 1 -------------------------------------------------------------------------------- /tests/converter-class/12 class-eq.txt: -------------------------------------------------------------------------------- 1 | class eq a : (a,a) => Bool 2 | ffi eqInt : (Int,Int) => Bool 3 | instance Int eq = eqInt 4 | result = eq 1 2 5 | - 6 | (function(){ 7 | oc.instances.eq = {}; 8 | var eq = function(x,p1,p2){ 9 | return x(p1,p2); 10 | }; 11 | oc.instances.eq.Int = eqInt; 12 | return { 13 | eq : eq, 14 | eqInt : eqInt, 15 | result : oc.instances.eq.Int(1,2) 16 | } 17 | })() -------------------------------------------------------------------------------- /tests/converter-class/12 class-pure: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | 3 | pureFoo : a => Foo a 4 | pureFoo x = foo = x 5 | 6 | class pure f : a => f a 7 | 8 | instance Foo pure x = pureFoo x 9 | x : Foo Int 10 | x = pure 1 11 | - 12 | Scope [Var "pureFoo" (Function ["x"] [Return (Object [("foo",Call (Ident "cloneWithNewType") [Ident "x",Lit (LitString "e")])])]),StmtList [Set (Field (Ident "instances") "pure") (Object []),Var "pure" (Function ["x"] [Return (Ident "x")])],Set (Field (Field (Ident "instances") "pure") "Foo") (Function ["x"] [Return (Call (Ident "pureFoo") [Call (Ident "cloneWithNewType") [Ident "x",Lit (LitString "j")]])]),Var "x" (Call (Call (Ident "pure") [Field (Field (Ident "instances") "pure") "Foo"]) [Lit (LitInt 1)]),Return (Object [("pureFoo",Ident "pureFoo"),("pure",Ident "pure"),("x",Ident "x")])] -------------------------------------------------------------------------------- /tests/converter-class/13 class-eq-maybe: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | 3 | class eq a : (a, a) => Int 4 | 5 | eqFoo : (a eq <: ((Foo a), (Foo a))) => Int 6 | eqFoo x y = eq x.foo y .foo 7 | 8 | m : Foo Int 9 | m = foo = 2 10 | 11 | instance Int eq x y = 1 12 | 13 | instance (Foo (a eq <: a)) eq x y = eqFoo x y 14 | 15 | bar = eq m m 16 | - 17 | = 18 | ffi unit : Unit 19 | ffi true : Bool 20 | ffi false : Bool 21 | 22 | type None = Unit 23 | none : None 24 | none = unit 25 | type Maybe a = None | just : a 26 | 27 | class eq a : (a, a) => Bool 28 | 29 | eqMaybe : (a eq <: ((Maybe a), (Maybe a))) => Bool 30 | eqMaybe = cases 31 | \(x : None) (y : None) => true 32 | \(x : None) y => false 33 | \x (y : None) => false 34 | \x y => eq x.just y.just 35 | 36 | m : Maybe Int 37 | m = just = 2 38 | 39 | instance Int eq x y = true 40 | 41 | instance (Maybe (a eq <: a)) eq x y = eqMaybe x y 42 | 43 | foo = eq m m 44 | - 45 | 46 | -------------------------------------------------------------------------------- /tests/converter-class/13 class-show-maybe.txt: -------------------------------------------------------------------------------- 1 | ffi unit : Unit 2 | 3 | type None = Unit 4 | none : None 5 | none = unit 6 | type Maybe a = None | just : a 7 | 8 | class show a : a => String 9 | 10 | showMaybe : Maybe ((a show <: a)) => String 11 | showMaybe = case 12 | (z : None) => "none" 13 | z => show z.just 14 | 15 | instance Int show x = "int" 16 | instance (Maybe (a show <: a)) show x = showMaybe x 17 | foo : Maybe Int 18 | foo = just = 1 19 | bar = show foo 20 | - 21 | (function(){ 22 | oc.instances.show = {}; 23 | var show = function(x,p1){ 24 | return x(p1); 25 | }; 26 | var showMaybe = function(_mshow,_a1){ 27 | return function(z){ 28 | return "none"; 29 | }(_a1); 30 | }; 31 | oc.instances.show.Int = function(x){ 32 | return "int"; 33 | }; 34 | oc.instances.show.Maybe = function(_pshow,x){ 35 | return showMaybe(_pshow,x); 36 | }; 37 | var foo = { 38 | just : 1 39 | }; 40 | return { 41 | unit : unit, 42 | none : unit, 43 | show : show, 44 | showMaybe : showMaybe, 45 | foo : foo, 46 | bar : function(p1){ 47 | return oc.instances.show.Maybe(oc.instances.show.Int,p1); 48 | }(foo) 49 | } 50 | })() 51 | = 52 | ffi emptyObject : a 53 | ffi eqAny : a, a => Bool 54 | class eq a : a, a => Bool 55 | type Maybe a = none | just : a 56 | 57 | class show a : a => String 58 | 59 | maybe : b, (a => b), Maybe a => b 60 | maybe x f m = m # case 61 | ^none => x 62 | z => f z.just 63 | 64 | showMaybe : Maybe ((a show <: a)) => String 65 | showMaybe x = maybe ("none", show, x) 66 | - 67 | (function(){ 68 | oc.instances.eq = {}; 69 | var eq = function(x,p1,p2){ 70 | return x(p1,p2); 71 | }; 72 | var none = {}; 73 | oc.instances.eq.None = eqAny; 74 | oc.instances.show = {}; 75 | var show = function(x,p1){ 76 | return x(p1); 77 | }; 78 | var maybe = function(x,f,m){ 79 | return function(_a1){ 80 | if(function(_a){ 81 | return oc.instances.eq.None(_a,none); 82 | }(_a1)){ 83 | return function(_a){ 84 | return x; 85 | }(_a1); 86 | }else{ 87 | if(function(z){ 88 | return z.just !== undefined; 89 | }(_a1)){ 90 | return function(z){ 91 | return f(z.just); 92 | }(_a1); 93 | }else{ 94 | throw "cases error"; 95 | } 96 | } 97 | }(m); 98 | }; 99 | var showMaybe = function(_agshow,x){ 100 | return maybe("none",function(p1){ 101 | return show(_agshow,p1); 102 | },x); 103 | }; 104 | return { 105 | emptyObject : emptyObject, 106 | eqAny : eqAny, 107 | eq : eq, 108 | none : none, 109 | show : show, 110 | maybe : maybe, 111 | showMaybe : showMaybe 112 | } 113 | })() 114 | -------------------------------------------------------------------------------- /tests/converter-class/14 class-show6: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | 3 | class show a : a => String 4 | instance Int show x = "test" 5 | 6 | showFoo : (Foo a) => String 7 | showFoo x = show x.foo 8 | 9 | instance (Foo forall (a show) a) show x = showFoo x 10 | 11 | test : Foo Int 12 | test = foo = 1 13 | 14 | bar = show test 15 | - 16 | Scope [StmtList [Set (Field (Ident "instances") "show") (Object []),Var "show" (Function ["x"] [Return (Ident "x")])],Set (Field (Field (Ident "instances") "show") "Int") (Function ["x"] [Return (Lit (LitString "test"))]),Var "showFoo" (Function ["$hInstanceshow"] [Return (Function ["x"] [Return (Call (Call (Ident "show") [Ident "$hInstanceshow"]) [Field (Ident "x") "foo"])])]),Set (Field (Field (Ident "instances") "show") "Foo") (Function ["x"] [Return (Call (Call (Ident "showFoo") [Ident "$nInstanceshow"]) [Ident "x"])]),Var "test" (Object [("foo",Lit (LitInt 1))]),Var "bar" (Call (Call (Ident "show") [Field (Field (Ident "instances") "show") "Foo"]) [Ident "test"]),Return (Object [("show",Ident "show"),("showFoo",Ident "showFoo"),("test",Ident "test"),("bar",Ident "bar")])] -------------------------------------------------------------------------------- /tests/converter-class/14 triple.txt: -------------------------------------------------------------------------------- 1 | class eq a : a,a => Int 2 | 3 | ffi arrayEq : a eq <: (Array a, Array a) => Int 4 | 5 | instance (Array (a eq <: a)) eq x y = arrayEq x y 6 | 7 | instance Int eq x y = 0 8 | 9 | ffi unit : Unit 10 | 11 | checkEq : (a eq <: (a,a)) => Unit 12 | checkEq x y = unit 13 | 14 | 15 | arr = [1 2 3] 16 | 17 | checkEq arr arr 18 | - 19 | (function(){ 20 | oc.instances.eq = {}; 21 | var eq = function(x,p1,p2){ 22 | return x(p1,p2); 23 | }; 24 | oc.instances.eq.Array = function(_eeq,x,y){ 25 | return arrayEq(_eeq,x,y); 26 | }; 27 | oc.instances.eq.Int = function(x,y){ 28 | return 0; 29 | }; 30 | var checkEq = function(_oeq,x,y){ 31 | return unit; 32 | }; 33 | var arr = [1,2,3]; 34 | return { 35 | eq : eq, 36 | arrayEq : arrayEq, 37 | unit : unit, 38 | checkEq : checkEq, 39 | arr : arr, 40 | item1 : checkEq(function(p1,p2){ 41 | return oc.instances.eq.Array(oc.instances.eq.Int,p1,p2); 42 | },arr,arr) 43 | } 44 | })() -------------------------------------------------------------------------------- /tests/converter-class/15 class-in-record: -------------------------------------------------------------------------------- 1 | class mempty a: a 2 | instance Int mempty = 0 3 | foo = bar = mempty 4 | - 5 | Scope [StmtList [Set (Field (Ident "instances") "mempty") (Object []),Var "mempty" (Function ["x"] [Return (Ident "x")])],Set (Field (Field (Ident "instances") "mempty") "Int") (Lit (LitInt 0)),Var "foo" (Object [("bar",Function ["$eInstancemempty"] [Return (Call (Ident "mempty") [Ident "$eInstancemempty"])])]),Return (Object [("mempty",Ident "mempty"),("foo",Ident "foo")])] 6 | = 7 | ffi test : Int => Int 8 | class mempty a: a 9 | instance Int mempty = 0 10 | foo = bar = mempty 11 | t = test foo.bar 12 | - 13 | ??? 14 | -------------------------------------------------------------------------------- /tests/converter-class/15 show-label.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | 3 | bar x = 4 | y = x.foo 5 | show y 6 | - 7 | (function(){ 8 | oc.instances.show = {}; 9 | var show = function(x,p1){ 10 | return x(p1); 11 | }; 12 | var bar = function(_jshow,x){ 13 | var y = x.foo; 14 | return { 15 | y : y, 16 | item1 : _jshow(y) 17 | }; 18 | }; 19 | return { 20 | show : show, 21 | bar : bar 22 | } 23 | })() -------------------------------------------------------------------------------- /tests/converter-class/16 class-map: -------------------------------------------------------------------------------- 1 | id : a => a 2 | id x = x 3 | 4 | class map f : ((a => b), (f a)) => f b 5 | 6 | type Foo a = foo : a 7 | 8 | fooMap : ((a => b), Foo a) => Foo b 9 | fooMap f y = foo = f y.foo 10 | instance Foo map = fooMap 11 | 12 | y : Foo Int 13 | y = foo = 1 14 | 15 | test = map id y 16 | - 17 | (function () { 18 | var id = function (x) { 19 | return x; 20 | }; 21 | instances.map = {}; 22 | var map = function (x) { 23 | return x; 24 | }; 25 | var fooMap = function (f,y) { 26 | return {foo: f(y.foo)}; 27 | }; 28 | instances.map.Foo = fooMap; 29 | var y = {foo: 1}; 30 | var test = 31 | map(instances.map.Foo)(id,y); 32 | return {id: id 33 | ,map: map 34 | ,fooMap: fooMap 35 | ,y: y 36 | ,test: test}; 37 | }()); -------------------------------------------------------------------------------- /tests/converter-class/16 two-classes.txt: -------------------------------------------------------------------------------- 1 | class add a : a, a => a 2 | class zero a : a 3 | 4 | foo = add zero zero 5 | - 6 | (function(){ 7 | oc.instances.add = {}; 8 | var add = function(x,p1,p2){ 9 | return x(p1,p2); 10 | }; 11 | oc.instances.zero = {}; 12 | var zero = function(x){ 13 | return x; 14 | }; 15 | var foo = function(_kzero,_kadd){ 16 | return _kadd(zero(_kzero),zero(_kzero)); 17 | }; 18 | return { 19 | add : add, 20 | zero : zero, 21 | foo : foo 22 | } 23 | })() 24 | = 25 | class add a : a, a => a 26 | class zero a : a 27 | instance Int add x y = 0 28 | instance Int zero = 0 29 | 30 | foo = add zero zero 31 | 32 | bar : Int 33 | bar = foo 34 | - 35 | (function(){ 36 | oc.instances.add = {}; 37 | var add = function(x,p1,p2){ 38 | return x(p1,p2); 39 | }; 40 | oc.instances.zero = {}; 41 | var zero = function(x){ 42 | return x; 43 | }; 44 | oc.instances.add.Int = function(x,y){ 45 | return 0; 46 | }; 47 | oc.instances.zero.Int = 0; 48 | var foo = function(_mzero,_madd){ 49 | return _madd(zero(_mzero),zero(_mzero)); 50 | }; 51 | return { 52 | add : add, 53 | zero : zero, 54 | foo : foo, 55 | bar : foo(oc.instances.zero.Int,oc.instances.add.Int) 56 | } 57 | })() -------------------------------------------------------------------------------- /tests/converter-class/17 label.txt: -------------------------------------------------------------------------------- 1 | class add a : a, a => a 2 | class zero a : a 3 | 4 | foo = bar = zero 5 | qwe = add foo.bar foo.bar 6 | - 7 | (function(){ 8 | oc.instances.add = {}; 9 | var add = function(x,p1,p2){ 10 | return x(p1,p2); 11 | }; 12 | oc.instances.zero = {}; 13 | var zero = function(x){ 14 | return x; 15 | }; 16 | var foo = { 17 | bar : function(_fzero){ 18 | return zero(_fzero); 19 | } 20 | }; 21 | var qwe = function(_yzero,_yadd){ 22 | return _yadd(foo.bar(_yzero),foo.bar(_yzero)); 23 | }; 24 | return { 25 | add : add, 26 | zero : zero, 27 | foo : foo, 28 | qwe : qwe 29 | } 30 | })() -------------------------------------------------------------------------------- /tests/converter-class/18 show-rec.txt: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | class show a: a => String 3 | 4 | showFoo : a show <: Foo a => String 5 | showFoo = case 6 | x => showFoo x 7 | - 8 | (function(){ 9 | oc.instances.show = {}; 10 | var show = function(x,p1){ 11 | return x(p1); 12 | }; 13 | var showFoo = function(_fshow,_a1){ 14 | return function(x){ 15 | return showFoo(_fshow,x); 16 | }(_a1); 17 | }; 18 | return { 19 | show : show, 20 | showFoo : showFoo 21 | } 22 | })() 23 | = 24 | ffi emptyObject : a 25 | ffi eqAny : a, a => Bool 26 | class eq a : a, a => Bool 27 | type NonEmptyList a = (a, List a) 28 | type List a = emptyList | NonEmptyList a 29 | 30 | 31 | eqList : a eq <: (List a, List a) => Bool 32 | eqList = case 33 | \(h1,t1) (h2,t2) => eqList t1 t2 34 | - 35 | (function(){ 36 | oc.instances.eq = {}; 37 | var eq = function(x,p1,p2){ 38 | return x(p1,p2); 39 | }; 40 | oc.instances.eq.EmptyList = eqAny; 41 | var eqList = function(_ageq,_a1,_a2){ 42 | if(function(_a,_b){ 43 | return (_a.item1 44 | !== 45 | undefined && _a.item2 46 | !== 47 | undefined && _b.item1 48 | !== 49 | undefined && _b.item2 50 | !== 51 | undefined); 52 | }(_a1,_a2)){ 53 | return function(_a,_b){ 54 | var h1 = _a.item1; 55 | var t1 = _a.item2; 56 | var h2 = _b.item1; 57 | var t2 = _b.item2; 58 | return eqList(_ageq,t1,t2); 59 | }(_a1,_a2); 60 | }else{ 61 | throw "cases error"; 62 | } 63 | }; 64 | return { 65 | emptyObject : emptyObject, 66 | eqAny : eqAny, 67 | eq : eq, 68 | emptyList : {}, 69 | eqList : eqList 70 | } 71 | })() -------------------------------------------------------------------------------- /tests/converter-class/19 order: -------------------------------------------------------------------------------- 1 | class add a : a, b, c => Int 2 | class zero1 a : a 3 | class zero2 a : a 4 | class zero3 a : a 5 | 6 | foo = add zero1 zero2 zero3 7 | bar = add zero1 zero2 zero3 8 | -------------------------------------------------------------------------------- /tests/converter-class/20 params.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | 3 | foo : a show <: a => a 4 | foo x = x 5 | - 6 | (function(){ 7 | oc.instances.show = {}; 8 | var show = function(x,p1){ 9 | return x(p1); 10 | }; 11 | var foo = function(_eshow,x){ 12 | return x; 13 | }; 14 | return { 15 | show : show, 16 | foo : foo 17 | } 18 | })() -------------------------------------------------------------------------------- /tests/converter/01 lit.txt: -------------------------------------------------------------------------------- 1 | 1 2 | - 3 | Lit (LitInt 1) 4 | = 5 | 1.1 6 | - 7 | Lit (LitDouble 1.1) 8 | = 9 | "test" 10 | - 11 | Lit (LitString "test") 12 | = 13 | 'x' 14 | - 15 | Lit (LitChar 'x') -------------------------------------------------------------------------------- /tests/converter/02 record.txt: -------------------------------------------------------------------------------- 1 | x = 1 2 | - 3 | Object [("x",Lit (LitInt 1))] 4 | = 5 | x = y = 1 6 | - 7 | Object [("x",Object [("y",Lit (LitInt 1))])] 8 | = 9 | x = 1 10 | y = 1 11 | - 12 | Object [("x",Lit (LitInt 1)),("y",Lit (LitInt 1))] 13 | = 14 | x = 1 15 | y = x 16 | - 17 | Scope [Var "x" (Lit (LitInt 1))] (Object [("x",Ident "x"),("y",Ident "x")]) -------------------------------------------------------------------------------- /tests/converter/03 removetype.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | foo : Foo => Int 3 | foo x = x 4 | - 5 | Object [("foo",Function ["x"] [Return (Ident "x")])] 6 | = 7 | type Foo a = foo : a 8 | runFoo : Foo x => x 9 | runFoo x = x.foo 10 | - 11 | Object [("runFoo",Function ["x"] [Return (Field (Ident "x") "foo")])] -------------------------------------------------------------------------------- /tests/converter/04 open: -------------------------------------------------------------------------------- 1 | foo = x = 1 2 | open foo 3 | bar = x 4 | - 5 | ScopeF [VarF "foo" (ObjectF [("x",LitF (LitInt 1))])] (ObjectF [("foo",IdentF "foo"),("bar",FieldF (IdentF "foo") "x")]) 6 | = 7 | foo = (qwe x = x) 8 | open foo 9 | bar = qwe 1 10 | - 11 | ScopeF [VarF "foo" (ObjectF [("qwe",FunctionF ["x"] [ReturnF (IdentF "x")])])] (ObjectF [("foo",IdentF "foo"),("bar",CallF (FieldF (IdentF "foo") "qwe") [LitF (LitInt 1)])]) -------------------------------------------------------------------------------- /tests/converter/05 match.txt: -------------------------------------------------------------------------------- 1 | \(x,y) z => x 2 | - 3 | Function ["_a","z"] [Var "x" (Field (Ident "_a") "item1"),Var "y" (Field (Ident "_a") "item2"),Return (Ident "x")] -------------------------------------------------------------------------------- /tests/converter/06 tuple.txt: -------------------------------------------------------------------------------- 1 | x = (1,2) 2 | - 3 | Object [("x",Object [("item1",Lit (LitInt 1)),("item2",Lit (LitInt 2))])] 4 | = 5 | foo x = (x,x) 6 | - 7 | Object [("foo",Function ["x"] [Return (Object [("item1",Ident "x"),("item2",Ident "x")])])] 8 | = 9 | ffi foo : (Int, Int) => Int 10 | 11 | bar = foo 1 2 12 | - 13 | Object [("foo",Ident "foo"),("bar",Call (Ident "foo") [Lit (LitInt 1),Lit (LitInt 2)])] 14 | = 15 | ffi foo : Int => Int 16 | 17 | bar = (1, foo 1) 18 | - 19 | Object [("foo",Ident "foo"),("bar",Object [("item1",Lit (LitInt 1)),("item2",Call (Ident "foo") [Lit (LitInt 1)])])] -------------------------------------------------------------------------------- /tests/converter/07 cases.txt: -------------------------------------------------------------------------------- 1 | case (x => x) 2 | - 3 | Function ["_a1"] [Return (Call (Function ["x"] [Return (Ident "x")]) [Ident "_a1"])] 4 | = 5 | case ((x : Int) => x) 6 | - 7 | Function ["_a1"] [Return (Call (Function ["x"] [Return (Ident "x")]) [Ident "_a1"])] 8 | = 9 | foo = case 10 | z => 2 11 | x y => 2 12 | - 13 | Object [("foo",Function ["_a1"] [Return (Call (Function ["z"] [Return (Lit (LitInt 2))]) [Ident "_a1"])])] 14 | = 15 | foo = case 16 | x y => 2 17 | z => 2 18 | - 19 | Object [("foo",Function ["_a1"] [If (Call (Function ["_a"] [Return (BoolAnds [HasField (Ident "_a") "item1",HasField (Ident "_a") "item2"])]) [Ident "_a1"]) [Return (Call (Function ["_a"] [Var "x" (Field (Ident "_a") "item1"),Var "y" (Field (Ident "_a") "item2"),Return (Lit (LitInt 2))]) [Ident "_a1"])] [Return (Call (Function ["z"] [Return (Lit (LitInt 2))]) [Ident "_a1"])]])] -------------------------------------------------------------------------------- /tests/converter/08 either.txt: -------------------------------------------------------------------------------- 1 | foo = case 2 | (left = x) => x 3 | (right = x) => x 4 | - 5 | Object [("foo",Function ["_a1"] [If (Call (Function ["_a"] [Return (HasField (Ident "_a") "left")]) [Ident "_a1"]) [Return (Call (Function ["_a"] [Var "x" (Field (Ident "_a") "left"),Return (Ident "x")]) [Ident "_a1"])] [If (Call (Function ["_b"] [Return (HasField (Ident "_b") "right")]) [Ident "_a1"]) [Return (Call (Function ["_b"] [Var "x" (Field (Ident "_b") "right"),Return (Ident "x")]) [Ident "_a1"])] [Throw "cases error"]]])] -------------------------------------------------------------------------------- /tests/converter/09 ffi-class: -------------------------------------------------------------------------------- 1 | class show a : a => String 2 | ffi foo : (a show <: a) => Int 3 | instance Int show x = "int" 4 | bar = foo 1 5 | - 6 | CallF (ParensF (FunctionF [] [SetF (FieldF (IdentF "instances") "show") (ObjectF []),VarF "show" (FunctionF ["x"] [ReturnF (IdentF "x")]),SetF (FieldF (FieldF (IdentF "instances") "show") "Int") (FunctionF ["x"] [ReturnF (LitF (LitString "int"))]),ReturnF (ObjectF [("show",IdentF "show"),("foo",IdentF "foo"),("bar",CallF (CallF (IdentF "foo") [FieldF (FieldF (IdentF "instances") "show") "Int"]) [LitF (LitInt 1)])])])) [] -------------------------------------------------------------------------------- /tests/converter/10 typechange.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | foo : Foo 3 | foo = 1 4 | bar = foo 5 | - 6 | Scope [Var "foo" (Lit (LitInt 1))] (Object [("foo",Ident "foo"),("bar",Ident "foo")]) 7 | = 8 | type Foo a = a 9 | foo : Foo Int 10 | foo = 1 11 | - 12 | Object [("foo",Lit (LitInt 1))] 13 | = 14 | type Foo = Int 15 | pureFoo : Int => Foo 16 | pureFoo x = x 17 | - 18 | Object [("pureFoo",Function ["x"] [Return (Ident "x")])] -------------------------------------------------------------------------------- /tests/converter/11 typechange-union.txt: -------------------------------------------------------------------------------- 1 | type Bar = Int 2 | type Foo = Bar | Double 3 | bar : Bar 4 | bar = 1 5 | foo : Foo 6 | foo = bar 7 | - 8 | Scope [Var "bar" (Lit (LitInt 1))] (Object [("bar",Ident "bar"),("foo",Ident "bar")]) -------------------------------------------------------------------------------- /tests/converter/12 lazy.txt: -------------------------------------------------------------------------------- 1 | type Lazy a = a 2 | foo : Lazy Int 3 | foo = 1 4 | - 5 | Object [("foo",Function [] [Return (Lit (LitInt 1))])] 6 | = 7 | type Lazy a = a 8 | foo : Lazy Int 9 | foo = 1 10 | bar = foo 11 | - 12 | Scope [Var "foo" (Function [] [Return (Lit (LitInt 1))])] (Object [("foo",Ident "foo"),("bar",Ident "foo")]) 13 | = 14 | type Lazy a = a 15 | foo : Lazy Int 16 | foo = 1 17 | bar : Int 18 | bar = foo 19 | - 20 | Scope [Var "foo" (Function [] [Return (Lit (LitInt 1))])] (Object [("foo",Ident "foo"),("bar",Call (Ident "foo") [])]) 21 | = 22 | type Lazy a = a 23 | foo : Int => Lazy Int 24 | foo x = x 25 | - 26 | Object [("foo",Function ["x"] [Return (Function [] [Return (Ident "x")])])] -------------------------------------------------------------------------------- /tests/converter/13 union.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | x : Foo 3 | x = 1 4 | - 5 | Object [("x",Lit (LitInt 1))] 6 | = 7 | type Foo = Int 8 | type Bar = Int 9 | type FooBar = Foo | Bar 10 | foo : Foo 11 | foo = 1 12 | x : FooBar 13 | x = foo 14 | - 15 | Scope [Var "foo" (Lit (LitInt 1))] (Object [("foo",Ident "foo"),("x",Ident "foo")]) -------------------------------------------------------------------------------- /tests/converter/14 union-maker.txt: -------------------------------------------------------------------------------- 1 | type Foo a = Int | foo : a 2 | foo : Foo Int 3 | foo = 1 4 | - 5 | Object [("foo",Lit (LitInt 1))] -------------------------------------------------------------------------------- /tests/converter/15 if.txt: -------------------------------------------------------------------------------- 1 | if true then 1 else 2 2 | - 3 | ConditionOperator (Lit (LitBool True)) (Lit (LitInt 1)) (Lit (LitInt 2)) -------------------------------------------------------------------------------- /tests/converter/16 set.txt: -------------------------------------------------------------------------------- 1 | x = 1 2 | x := 2 3 | - 4 | Scope [Var "x" (Lit (LitInt 1)),Set (Ident "x") (Lit (LitInt 2))] (Object [("x",Ident "x")]) 5 | = 6 | foo = bar = 1 7 | foo.bar := 2 8 | - 9 | Scope [Var "foo" (Object [("bar",Lit (LitInt 1))]),Set (Field (Ident "foo") "bar") (Lit (LitInt 2))] (Object [("foo",Ident "foo")]) -------------------------------------------------------------------------------- /tests/converter/17 let.txt: -------------------------------------------------------------------------------- 1 | foo x = 2 | y = 1 3 | in y 4 | - 5 | Object [("foo",Function ["x"] [Var "y" (Lit (LitInt 1)),Return (Ident "y")])] -------------------------------------------------------------------------------- /tests/converter/18 with.txt: -------------------------------------------------------------------------------- 1 | x = foo = 1 2 | y = x with foo = 2 3 | - 4 | Scope [Var "x" (Object [("foo",Lit (LitInt 1))])] (Object [("x",Ident "x"),("y",Scope [Var "_obj" (Ident "x"),Var "_clone" (Call (Field (Ident "oc") "cloneObject") [Ident "_obj"]),Set (Field (Ident "_clone") "foo") (Lit (LitInt 2))] (Ident "_clone"))]) -------------------------------------------------------------------------------- /tests/converter/instance: -------------------------------------------------------------------------------- 1 | ffi foo : Int 2 | class show a : a => Int 3 | bar = 1 4 | instance Int show x = bar 5 | -------------------------------------------------------------------------------- /tests/converter/removetype-cases: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | pureFoo : Foo => Int 3 | pureFoo = cases 4 | x => x 5 | - 6 | Object [("pureFoo",Call (Ident "cases") [Array [Object [("cond",Function ["x"] [Return (Lit (LitBool True))]),("func",Function ["x"] [Return (Field (Ident "x") "value")])]]])] 7 | -------------------------------------------------------------------------------- /tests/converter/tuple2: -------------------------------------------------------------------------------- 1 | ffi foo : (Int, Int) => Int 2 | x = (1,1) 3 | foo x 4 | - 5 | Scope [Object [("foo",Ident "foo")],Var "x" (Object [("item1",Lit (LitInt 1)),("item2",Lit (LitInt 1))]),Call (Ident "foo") [Field (Ident "x") "item1",Field (Ident "x") "item2"],Return (Object [("foo",Ident "foo"),("x",Ident "x")])] 6 | = 7 | foo = cases 8 | x y => 2 9 | z => 2 10 | 11 | foo 1 2 12 | - 13 | Scope [Var "foo" (Function ["_a"] [Return (Call (Function ["_a1"] [Var "result" (Lit LitNull),Var "func" (Lit LitNull),Set (Ident "func") (Function ["_b"] [If (BoolAnds [HasField (Ident "_b") "item1",HasField (Ident "_b") "item2"]) [Return (Scope [Var "x" (Field (Ident "_b") "item1"),Var "y" (Field (Ident "_b") "item2"),Return (Lit (LitInt 2))])] [Return (Lit LitNull)]]),Set (Ident "result") (Call (Ident "func") [Ident "_a1"]),If (NotEqual (Ident "result") (Lit LitNull)) [Return (Ident "result")] [],Set (Ident "func") (Function ["z"] [Return (Lit (LitInt 2))]),Set (Ident "result") (Call (Ident "func") [Ident "_a1"]),If (NotEqual (Ident "result") (Lit LitNull)) [Return (Ident "result")] []]) [Ident "_a"])]),Call (Ident "foo") [Object [("item1",Lit (LitInt 1)),("item2",Lit (LitInt 2))]],Return (Object [("foo",Ident "foo")])] 14 | -------------------------------------------------------------------------------- /tests/infer/01 let.txt: -------------------------------------------------------------------------------- 1 | x = 1 2 | in x 3 | - 4 | TypeIdent "Int" -------------------------------------------------------------------------------- /tests/infer/02 list.txt: -------------------------------------------------------------------------------- 1 | ffi unit : Unit 2 | type EmptyList = Unit 3 | type NonEmptyList a = (a, List a) 4 | emptyList : EmptyList 5 | emptyList = unit 6 | type List a = EmptyList | NonEmptyList a 7 | 8 | foo : List Int 9 | foo = emptyList 10 | 11 | range : Int => List Int 12 | range = case 13 | \x => foo 14 | \y => (y, (range y)) 15 | - 16 | TypeLabel "range" (TypeFunc (TypeIdent "Int") (TypeApply (TypeIdent "List") [TypeIdent "Int"])) -------------------------------------------------------------------------------- /tests/infer/03 access.txt: -------------------------------------------------------------------------------- 1 | _.foo 2 | - 3 | TypeFunc (TypeRow (TypeVar "b") [TypeLabel "foo" (TypeVar "a")]) (TypeVar "a") 4 | = 5 | \x => (x.foo) 6 | - 7 | TypeFunc (TypeRow (TypeVar "b") [TypeLabel "foo" (TypeVar "a")]) (TypeVar "a") 8 | = 9 | \x => (x.foo.bar) 10 | - 11 | TypeFunc (TypeRow (TypeVar "c") [TypeLabel "foo" (TypeRow (TypeVar "b") [TypeLabel "bar" (TypeVar "a")])]) (TypeVar "a") 12 | = 13 | ffi foo : Int => Unit 14 | \x => foo(x.bar) 15 | - 16 | TypeFunc (TypeRow (TypeVar "a") [TypeLabel "bar" (TypeIdent "Int")]) (TypeIdent "Unit") 17 | = 18 | x = 1 19 | y = (x.foo) 20 | - 21 | (UnificationFail (TypeLabel "foo" (TypeVar "c")) (TypeIdent "Int"),(2,6,"")) 22 | = 23 | x = bar = 1 24 | y = (x.foo) 25 | - 26 | (UnificationFail (TypeLabel "foo" (TypeVar "d")) (TypeLabel "bar" (TypeIdent "Int")),(2,6,"")) 27 | = 28 | x = foo = 1 29 | y = x.foo 30 | - 31 | TypeLabel "y" (TypeIdent "Int") 32 | = 33 | ffi bar : Int => Int 34 | x => ((y = x.foo), bar y) 35 | - 36 | TypeFunc (TypeRow (TypeVar "a") [TypeLabel "foo" (TypeIdent "Int")]) (TypeRecord [TypeLabel "y" (TypeIdent "Int"),TypeIdent "Int"]) 37 | = 38 | ffi bar : Int => Int 39 | id z = z 40 | x => ((y = id x), bar y) 41 | - 42 | TypeFunc (TypeIdent "Int") (TypeRecord [TypeLabel "y" (TypeIdent "Int"),TypeIdent "Int"]) -------------------------------------------------------------------------------- /tests/infer/04 array.txt: -------------------------------------------------------------------------------- 1 | [1 2 3] 2 | - 3 | TypeApply (TypeIdent "Array") [TypeIdent "Int"] 4 | = 5 | ffi eqInt : (Int, Int) => Bool 6 | eqInt [1 2 3] 1 7 | - 8 | (UnificationFail (TypeApply (TypeIdent "Array") [TypeIdent "Int"]) (TypeIdent "Int"),(2,1,"")) 9 | = 10 | [] 11 | - 12 | TypeApply (TypeIdent "Array") [TypeVar "a"] 13 | = 14 | x : Array Int 15 | x = [] 16 | - 17 | TypeLabel "x" (TypeApply (TypeIdent "Array") [TypeIdent "Int"]) -------------------------------------------------------------------------------- /tests/infer/05 cases show.txt: -------------------------------------------------------------------------------- 1 | class show a : a => String 2 | case 3 | x => show x 4 | - 5 | TypeFunc (TypeConstraints [(TypeVar "a","show")] (TypeVar "a")) (TypeIdent "String") -------------------------------------------------------------------------------- /tests/infer/06 classes.txt: -------------------------------------------------------------------------------- 1 | class mempty a: a 2 | foo = mempty 3 | - 4 | TypeLabel "foo" (TypeConstraints [(TypeVar "a","mempty")] (TypeVar "a")) 5 | = 6 | class mempty a: a 7 | instance Int mempty = 0 8 | test : Int 9 | test = mempty 10 | - 11 | TypeLabel "test" (TypeIdent "Int") 12 | = 13 | class mempty a: a 14 | x : Int 15 | x = mempty 16 | - 17 | (NoInstance (TypeIdent "Int") "mempty",(2,1,"")) 18 | = 19 | class mempty a: a 20 | instance Int mempty = 0 21 | type Foo = Int 22 | x : Foo 23 | x = mempty 24 | - 25 | TypeLabel "x" (TypeIdent "Foo") 26 | = 27 | class show s: s => Unit 28 | - 29 | NoType 30 | = 31 | class show s: s => Unit 32 | foo x = show x 33 | - 34 | TypeLabel "foo" (TypeFunc (TypeConstraints [(TypeVar "a","show")] (TypeVar "a")) (TypeIdent "Unit")) 35 | = 36 | class show s: s => Unit 37 | show 1 38 | - 39 | (NoInstance (TypeIdent "Int") "show",(2,1,"")) 40 | = 41 | class show s: s => Unit 42 | ffi showInt : Int => Unit 43 | instance Int show x = showInt x 44 | show(1) 45 | - 46 | TypeIdent "Unit" 47 | = 48 | type Foo a = Int 49 | class bar f : (f a) => Int 50 | instance Foo bar (x : Foo a) = 1 51 | x : Foo Int 52 | x = 1 53 | test = bar x 54 | - 55 | TypeLabel "test" (TypeIdent "Int") 56 | = 57 | class mempty a: a 58 | instance Int mempty = 0 59 | type Foo a = foo : a 60 | instance (Foo (a mempty <: a)) mempty = (foo = mempty) 61 | x : Foo Int 62 | x = mempty 63 | - 64 | TypeLabel "x" (TypeApply (TypeIdent "Foo") [TypeIdent "Int"]) 65 | = 66 | class mempty a: a 67 | instance Int mempty = 0 68 | type Foo a = foo : a 69 | instance (Foo (a mempty <: a)) mempty = (foo = mempty) 70 | x : Foo Double 71 | x = mempty 72 | - 73 | (NoInstance (TypeApply (TypeIdent "Foo") [TypeIdent "Double"]) "mempty",(5,1,"")) 74 | = 75 | type Foo a = (foo : a) 76 | fooMap : ((a => b), Foo a) => Foo b 77 | fooMap f x = foo = f (x.foo) 78 | - 79 | TypeLabel "fooMap" (TypeFunc (TypeRecord [TypeFunc (TypeVar "a") (TypeVar "b"),TypeApply (TypeIdent "Foo") [TypeVar "a"]]) (TypeApply (TypeIdent "Foo") [TypeVar "b"])) -------------------------------------------------------------------------------- /tests/infer/07 class pure.txt: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | 3 | pureFoo : a => Foo a 4 | pureFoo x = foo = x 5 | 6 | class pure f : a => f a 7 | 8 | instance Foo pure x = pureFoo x 9 | x : Foo Int 10 | x = pure 1 11 | - 12 | TypeLabel "x" (TypeApply (TypeIdent "Foo") [TypeIdent "Int"]) -------------------------------------------------------------------------------- /tests/infer/08 class show.txt: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | 3 | class show a : a => String 4 | instance Int show x = "test" 5 | 6 | showFoo : (Foo a) => String 7 | showFoo x = show x.foo 8 | 9 | instance (Foo (a show <: a)) show = showFoo 10 | 11 | test : Foo Int 12 | test = foo = 1 13 | 14 | bar = show test 15 | - 16 | TypeLabel "bar" (TypeIdent "String") -------------------------------------------------------------------------------- /tests/infer/09 class show2.txt: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | class show a: a => String 3 | showFoo : Foo (a show <: a) => String 4 | showFoo x = show x.foo 5 | - 6 | TypeLabel "showFoo" (TypeFunc (TypeApply (TypeIdent "Foo") [TypeConstraints [(TypeVar "a","show")] (TypeVar "a")]) (TypeIdent "String")) 7 | = 8 | type Foo a = foo : a 9 | class show a: a => String 10 | showFoo : Foo (a show <: a) => String 11 | showFoo x = show x.foo 12 | bar = showFoo (foo = 1) 13 | - 14 | (NoInstance (TypeIdent "Int") "show",(5,7,"")) 15 | = 16 | type Foo a = foo : a 17 | class show a: a => String 18 | showFoo x = show x.foo 19 | - 20 | TypeLabel "showFoo" (TypeFunc (TypeRow (TypeVar "a") [TypeLabel "foo" (TypeConstraints [(TypeVar "b","show")] (TypeVar "b"))]) (TypeIdent "String")) -------------------------------------------------------------------------------- /tests/infer/10 class show maybe: -------------------------------------------------------------------------------- 1 | ffi unit : Unit 2 | 3 | type None = Unit 4 | none : None 5 | none = unit 6 | type Maybe a = None | just : a 7 | 8 | ffi showMaybe : Maybe a => String 9 | 10 | foo x = showMaybe x 11 | - 12 | TypeLabelF "foo" (TypeFuncF (TypeApplyF (TypeIdentF "Maybe") [TypeVarF "a"]) (TypeIdentF "String")) -------------------------------------------------------------------------------- /tests/infer/11 conflict.txt: -------------------------------------------------------------------------------- 1 | ffi foo : a 2 | bar x = foo 3 | - 4 | TypeLabel "bar" (TypeFunc (TypeVar "a") (TypeVar "b")) -------------------------------------------------------------------------------- /tests/infer/12 either.txt: -------------------------------------------------------------------------------- 1 | class pure f : a => f a 2 | type Either a b = left : a | right : b 3 | 4 | pureEither : b => Either a b 5 | pureEither x = right = x 6 | 7 | instance (Either a) pure x = pureEither x 8 | 9 | x : Either String Int 10 | x = pure 2 11 | - 12 | TypeLabel "x" (TypeApply (TypeIdent "Either") [TypeIdent "String",TypeIdent "Int"]) 13 | = 14 | type Either a b = left : a | right : b 15 | 16 | foo : Either String Int 17 | foo = right = 1 18 | 19 | fromEither : b, Either a b => b 20 | fromEither = case 21 | def (left = x) => def 22 | _ (right = x) => x 23 | 24 | bar = fromEither 3 foo 25 | - 26 | TypeLabel "bar" (TypeIdent "Int") 27 | = 28 | type Either a b = left : a | right : b 29 | 30 | either : (a => c), (b => c), (Either a b) => c 31 | either fl fr m = m # case 32 | (left = x) => fl x 33 | (right = x) => fr x 34 | - 35 | TypeLabel "either" (TypeFunc (TypeRecord [TypeFunc (TypeVar "a") (TypeVar "c"),TypeFunc (TypeVar "b") (TypeVar "c"),TypeApply (TypeIdent "Either") [TypeVar "a",TypeVar "b"]]) (TypeVar "c")) 36 | = 37 | type Either a b = left : a | right : b 38 | 39 | mapEither : (b => c, (Either a b)) => Either a c 40 | mapEither f z = z # case 41 | (left = x) => left = x 42 | (right = x) => right = f x 43 | 44 | class map f : (a => b, (f a)) => f b 45 | 46 | instance (Either a) map = mapEither 47 | 48 | foo : Either String Int 49 | foo = left = "foo" 50 | 51 | bar = map (x => x) foo 52 | - 53 | TypeLabel "bar" (TypeApply (TypeIdent "Either") [TypeIdent "String",TypeIdent "Int"]) -------------------------------------------------------------------------------- /tests/infer/13 emptytype.txt: -------------------------------------------------------------------------------- 1 | ffi emptyObject : a 2 | class eq a : a , a => Bool 3 | ffi eqAny : a , a => Bool 4 | type Foo = bar 5 | foo = bar 6 | - 7 | TypeLabel "foo" (TypeIdent "Bar") -------------------------------------------------------------------------------- /tests/infer/14 fails.txt: -------------------------------------------------------------------------------- 1 | ffi foo : Int => Int 2 | y = foo 1.0 3 | - 4 | (UnificationFail (TypeIdent "Double") (TypeIdent "Int"),(2,5,"")) 5 | = 6 | foo = bar 7 | - 8 | (UnboundVariable "bar",(1,7,"")) 9 | = 10 | x : Unit 11 | x = 1 12 | - 13 | (UnificationFail (TypeIdent "Int") (TypeIdent "Unit"),(1,1,"")) -------------------------------------------------------------------------------- /tests/infer/15 func.txt: -------------------------------------------------------------------------------- 1 | type Foo a = a 2 | foo : ((Foo a) => (Foo a)) 3 | foo x = x 4 | foo 1 5 | foo 1.0 6 | - 7 | TypeApply (TypeIdent "Foo") [TypeIdent "Double"] 8 | = 9 | compose f g x = f (g x) 10 | - 11 | TypeLabel "compose" (TypeFunc (TypeRecord [TypeFunc (TypeVar "b") (TypeVar "c"),TypeFunc (TypeVar "a") (TypeVar "b"),TypeVar "a"]) (TypeVar "c")) 12 | = 13 | ffi eq : (Int, Int) => Bool 14 | foo x = x # case (1 => 2) 15 | - 16 | TypeLabel "foo" (TypeFunc (TypeIdent "Int") (TypeIdent "Int")) 17 | = 18 | foo : Int => Int 19 | foo x = x 20 | - 21 | TypeLabel "foo" (TypeFunc (TypeIdent "Int") (TypeIdent "Int")) 22 | = 23 | ffi bar : Int => Int 24 | foo x = bar x 25 | - 26 | TypeLabel "foo" (TypeFunc (TypeIdent "Int") (TypeIdent "Int")) 27 | = 28 | ffi eq : (Int, Int) => Bool 29 | 1 => 2 30 | - 31 | TypeFunc (TypeIdent "Int") (TypeIdent "Int") 32 | = 33 | ffi eq : (Int, Int) => Bool 34 | 1 => 2 35 | 2 => 3 36 | - 37 | TypeFunc (TypeIdent "Int") (TypeIdent "Int") 38 | = 39 | x = 1 40 | y => y x 41 | - 42 | TypeFunc (TypeFunc (TypeIdent "Int") (TypeVar "a")) (TypeVar "a") 43 | = 44 | x y => x 45 | - 46 | TypeFunc (TypeRecord [TypeVar "a",TypeVar "b"]) (TypeVar "a") 47 | = 48 | equal x y => equal x y 49 | - 50 | TypeFunc (TypeRecord [TypeFunc (TypeRecord [TypeVar "a",TypeVar "b"]) (TypeVar "c"),TypeVar "a",TypeVar "b"]) (TypeVar "c") 51 | = 52 | \(equal : (a, a => Int), x, y) => equal x y 53 | - 54 | TypeFunc (TypeRecord [TypeFunc (TypeRecord [TypeVar "a",TypeVar "a"]) (TypeIdent "Int"),TypeVar "a",TypeVar "a"]) (TypeIdent "Int") 55 | = 56 | \(x : Int) => x 57 | - 58 | TypeFunc (TypeIdent "Int") (TypeIdent "Int") 59 | = 60 | ffi foo : Int => Int 61 | \(x : Unit) => foo x 62 | - 63 | (UnificationFail (TypeIdent "Unit") (TypeIdent "Int"),(2,16,"")) 64 | = 65 | ffi foo : (x : xType) => xType 66 | ffi bar : (y : yType) => yType 67 | \x => foo (bar x) 68 | - 69 | TypeFunc (TypeLabel "y" (TypeLabel "x" (TypeVar "a"))) (TypeVar "a") 70 | = 71 | ffi eq : (a,a) => Int 72 | test x = eq x 1 73 | - 74 | TypeLabel "test" (TypeFunc (TypeIdent "Int") (TypeIdent "Int")) 75 | = 76 | ffi foo : Int => Bool 77 | x | (foo x) => x 78 | - 79 | TypeFunc (TypeIdent "Int") (TypeIdent "Int") -------------------------------------------------------------------------------- /tests/infer/16 generic.txt: -------------------------------------------------------------------------------- 1 | id x = x 2 | id 1.0 3 | id 1 4 | - 5 | TypeIdent "Int" 6 | = 7 | foo(x) = x 8 | - 9 | TypeLabel "foo" (TypeFunc (TypeVar "a") (TypeVar "a")) 10 | = 11 | ffi foo : (a,a) => Unit 12 | foo 1 1.1 13 | - 14 | (UnificationFail (TypeIdent "Double") (TypeIdent "Int"),(2,1,"")) 15 | = 16 | id : a => a 17 | id x = x 18 | - 19 | TypeLabel "id" (TypeFunc (TypeVar "a") (TypeVar "a")) 20 | = 21 | ffi foo : x => Unit 22 | foo 1 23 | - 24 | TypeIdent "Unit" 25 | = 26 | ffi foo : x => x 27 | foo 1 28 | - 29 | TypeIdent "Int" -------------------------------------------------------------------------------- /tests/infer/17 guard.txt: -------------------------------------------------------------------------------- 1 | x | (1) => x 2 | - 3 | (UnificationFail (TypeIdent "Int") (TypeIdent "Bool"),(1,1,"")) 4 | = 5 | ffi foo : Int => Bool 6 | x | (foo x) => x 7 | - 8 | TypeFunc (TypeIdent "Int") (TypeIdent "Int") -------------------------------------------------------------------------------- /tests/infer/18 instance typecheck.txt: -------------------------------------------------------------------------------- 1 | class zero a : a 2 | instance Double zero = 0 3 | - 4 | (UnificationFail (TypeIdent "Int") (TypeIdent "Double"),(2,1,"")) 5 | = 6 | class mempty a: a 7 | instance Int mempty = 1.0 8 | - 9 | (UnificationFail (TypeIdent "Double") (TypeIdent "Int"),(2,1,"")) -------------------------------------------------------------------------------- /tests/infer/19 kinds.txt: -------------------------------------------------------------------------------- 1 | ffi foo : (Array a) => Int 2 | ffi x : (Array Int) 3 | foo x 4 | - 5 | TypeIdent "Int" 6 | = 7 | ffi foo : (Array Unit) => Unit 8 | ffi x : (Array Int) 9 | foo x 10 | - 11 | (UnificationFail (TypeIdent "Int") (TypeIdent "Unit"),(3,1,"")) 12 | = 13 | ffi foo : (Array a) => a 14 | ffi x : (Array Int) 15 | foo x 16 | - 17 | TypeIdent "Int" 18 | = 19 | type Foo a = Int 20 | x : Foo Int 21 | x = 1 22 | - 23 | TypeLabel "x" (TypeApply (TypeIdent "Foo") [TypeIdent "Int"]) 24 | = 25 | type Foo a = a 26 | x : Foo Int 27 | x = 1 28 | - 29 | TypeLabel "x" (TypeApply (TypeIdent "Foo") [TypeIdent "Int"]) -------------------------------------------------------------------------------- /tests/infer/20 maker.txt: -------------------------------------------------------------------------------- 1 | ffi foo : Array 2 | 3 | bar : Array a 4 | bar = foo 5 | - 6 | TypeLabel "bar" (TypeApply (TypeIdent "Array") [TypeVar "a"]) -------------------------------------------------------------------------------- /tests/infer/21 match.txt: -------------------------------------------------------------------------------- 1 | ffi eq : (Int, Int) => Bool 2 | case (1 => 2) (2 => 3) 3 | - 4 | TypeFunc (TypeIdent "Int") (TypeIdent "Int") 5 | = 6 | case (\(z : Int) => 1) (\(z : Unit) => 2) 7 | - 8 | TypeFunc (TypeUnion [TypeIdent "Int",TypeIdent "Unit"]) (TypeIdent "Int") 9 | = 10 | ffi eq : (Int, Int) => Bool 11 | foo = case (\1 => 2) (\2 => 3) 12 | foo 1 13 | - 14 | TypeIdent "Int" 15 | = 16 | ffi eq : (Int, Int) => Bool 17 | foo = case (\1 => 2) (\2 => 3) 18 | - 19 | TypeLabel "foo" (TypeFunc (TypeIdent "Int") (TypeIdent "Int")) 20 | = 21 | foo = case (\(x : Int) => 1) (\(y : Unit) => 2) 22 | - 23 | TypeLabel "foo" (TypeFunc (TypeUnion [TypeIdent "Int",TypeIdent "Unit"]) (TypeIdent "Int")) -------------------------------------------------------------------------------- /tests/infer/22 match2.txt: -------------------------------------------------------------------------------- 1 | \(x,y) z => 1 2 | - 3 | TypeFunc (TypeRecord [TypeRow (TypeVar "d") [TypeLabel "item1" (TypeVar "b"),TypeLabel "item2" (TypeVar "c")],TypeVar "a"]) (TypeIdent "Int") 4 | = 5 | \(x,y) (l,m) => m 6 | - 7 | TypeFunc (TypeRecord [TypeRow (TypeVar "c") [TypeLabel "item1" (TypeVar "a"),TypeLabel "item2" (TypeVar "b")],TypeRow (TypeVar "f") [TypeLabel "item1" (TypeVar "d"),TypeLabel "item2" (TypeVar "e")]]) (TypeVar "e") 8 | = 9 | _ => 1 10 | - 11 | TypeFunc (TypeVar "a") (TypeIdent "Int") 12 | = 13 | ffi eq : Int, Int => Bool 14 | 1 => 1 15 | - 16 | TypeFunc (TypeIdent "Int") (TypeIdent "Int") 17 | = 18 | ffi eq : Int, Int => Bool 19 | ffi andBool : Bool, Bool => Bool 20 | 1 2 => 1 21 | - 22 | TypeFunc (TypeRecord [TypeIdent "Int",TypeIdent "Int"]) (TypeIdent "Int") 23 | = 24 | ffi eq : Int, Int => Bool 25 | \(x = 1) => 1 26 | - 27 | TypeFunc (TypeRow (TypeVar "a") [TypeLabel "x" (TypeIdent "Int")]) (TypeIdent "Int") 28 | = 29 | ffi eq : a, a => Bool 30 | \(x = y) => y 31 | - 32 | TypeFunc (TypeRow (TypeVar "b") [TypeLabel "x" (TypeVar "a")]) (TypeVar "a") -------------------------------------------------------------------------------- /tests/infer/23 maybe.txt: -------------------------------------------------------------------------------- 1 | ffi unit : Unit 2 | type None = Unit 3 | none : None 4 | none = unit 5 | type Maybe a = None | a 6 | 7 | maybe : (b, (a => b), (Maybe a)) => b 8 | maybe x f m = m # case 9 | (z : None) => x 10 | z => f z 11 | 12 | foo = maybe 1 (x => 2) none 13 | - 14 | TypeLabel "foo" (TypeIdent "Int") 15 | = 16 | ffi emptyObject : a 17 | ffi eqAny : a, a => Bool 18 | ffi andBool : Bool, Bool => Bool 19 | class eq a : a, a => Bool 20 | type Maybe a = none | just : a 21 | eqMaybe : (a eq <: (Maybe a, Maybe a)) => Bool 22 | eqMaybe = case 23 | ^none ^none => true 24 | x y => eq x.just y.just 25 | - 26 | TypeLabel "eqMaybe" (TypeFunc (TypeConstraints [(TypeVar "a","eq")] (TypeRecord [TypeApply (TypeIdent "Maybe") [TypeVar "a"],TypeApply (TypeIdent "Maybe") [TypeVar "a"]])) (TypeIdent "Bool")) 27 | = 28 | ffi emptyObject : a 29 | ffi eqAny : a, a => Bool 30 | ffi andBool : Bool, Bool => Bool 31 | class eq a : a, a => Bool 32 | type Maybe a = none | just : a 33 | 34 | maybe : b, (a => b), (Maybe a) => b 35 | maybe x f m = m # case 36 | ^none => x 37 | z => f z.just 38 | 39 | noneMaybe : Maybe a 40 | noneMaybe = none 41 | 42 | mapMaybe : (a => b, (Maybe a)) => Maybe b 43 | mapMaybe f x = maybe noneMaybe (y => just = (f y)) x 44 | - 45 | TypeLabel "mapMaybe" (TypeFunc (TypeRecord [TypeFunc (TypeVar "a") (TypeVar "b"),TypeApply (TypeIdent "Maybe") [TypeVar "a"]]) (TypeApply (TypeIdent "Maybe") [TypeVar "b"])) 46 | -------------------------------------------------------------------------------- /tests/infer/24 none.txt: -------------------------------------------------------------------------------- 1 | ffi unit : Unit 2 | class eq a : (a,a) => Bool 3 | case (x | (eq x unit) => x) 4 | - 5 | (NoInstance (TypeIdent "Unit") "eq",(3,11,"")) -------------------------------------------------------------------------------- /tests/infer/25 open.txt: -------------------------------------------------------------------------------- 1 | foo = x = 1 2 | open foo 3 | x 4 | - 5 | TypeIdent "Int" -------------------------------------------------------------------------------- /tests/infer/26 record.txt: -------------------------------------------------------------------------------- 1 | 1 2 | - 3 | TypeIdent "Int" 4 | = 5 | x = 1 6 | - 7 | TypeLabel "x" (TypeIdent "Int") 8 | = 9 | x = 1 10 | y = x 11 | - 12 | TypeLabel "y" (TypeIdent "Int") 13 | = 14 | x = 1 15 | y = z = x 16 | - 17 | TypeLabel "y" (TypeLabel "z" (TypeIdent "Int")) 18 | = 19 | foo : ((x : Int), y : Int) 20 | foo = ((x = 1), y = 1) 21 | - 22 | TypeLabel "foo" (TypeRecord [TypeLabel "x" (TypeIdent "Int"),TypeLabel "y" (TypeIdent "Int")]) -------------------------------------------------------------------------------- /tests/infer/27 recursion.txt: -------------------------------------------------------------------------------- 1 | fst x = fst x 2 | - 3 | TypeLabel "fst" (TypeFunc (TypeVar "a") (TypeVar "b")) 4 | = 5 | fst x = fst 1 6 | - 7 | TypeLabel "fst" (TypeFunc (TypeIdent "Int") (TypeVar "a")) 8 | = 9 | fst x = fst x 1 10 | - 11 | (InfiniteType "b" (TypeRecord [TypeVar "b",TypeIdent "Int"]),(1,1,"")) -------------------------------------------------------------------------------- /tests/infer/28 two classes.txt: -------------------------------------------------------------------------------- 1 | class inc a : a => a 2 | class zero a : a 3 | foo = inc zero 4 | - 5 | TypeLabel "foo" (TypeConstraints [(TypeVar "a","zero"),(TypeVar "a","inc")] (TypeVar "a")) 6 | = 7 | class add a : a, a => a 8 | class zero a : a 9 | foo = add zero zero 10 | - 11 | TypeLabel "foo" (TypeConstraints [(TypeVar "a","zero"),(TypeVar "a","add")] (TypeVar "a")) 12 | = 13 | class add a : a, a => a 14 | class zero a : a 15 | class inc a : a => a 16 | foo = add zero (inc zero) 17 | - 18 | TypeLabel "foo" (TypeConstraints [(TypeVar "a","zero"),(TypeVar "a","inc"),(TypeVar "a","add")] (TypeVar "a")) 19 | = 20 | class foldl f : f a => a 21 | foo x = foldl x 22 | - 23 | TypeLabel "foo" (TypeFunc (TypeApply (TypeConstraints [(TypeVar "b","foldl")] (TypeVar "b")) [TypeVar "a"]) (TypeVar "a")) 24 | = 25 | class zero a : a 26 | class foldl f : a, f a => Int 27 | foo x = foldl zero x 28 | - 29 | TypeLabel "foo" (TypeFunc (TypeApply (TypeConstraints [(TypeVar "a","foldl")] (TypeVar "a")) [TypeConstraints [(TypeVar "b","zero")] (TypeVar "b")]) (TypeIdent "Int")) 30 | = 31 | class add a : a, a => a 32 | class zero a : a 33 | instance Int add x y = 0 34 | instance Int zero = 0 35 | 36 | class foldl f : (((b,a) => b), b, f a) => Int 37 | 38 | ffi arrayFoldl : (a, e => e), a, Array e => a 39 | 40 | instance Array foldl f i x = arrayFoldl f i x 41 | 42 | sum l = foldl (a e => add a e) zero l 43 | 44 | foo = sum [1] 45 | - 46 | TypeLabel "foo" (TypeIdent "Int") -------------------------------------------------------------------------------- /tests/infer/29 typechange.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | foo : Foo 3 | foo = 1 4 | bar = foo 5 | - 6 | TypeLabel "bar" (TypeIdent "Foo") 7 | = 8 | type Foo a = a 9 | foo : Foo Int 10 | foo = 1 11 | - 12 | TypeLabel "foo" (TypeApply (TypeIdent "Foo") [TypeIdent "Int"]) -------------------------------------------------------------------------------- /tests/infer/30 typeDesc.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | x : Foo 3 | x = 1 4 | - 5 | TypeLabel "x" (TypeIdent "Foo") 6 | = 7 | type Foo = 8 | foo : Int 9 | bar : Int 10 | x : Foo 11 | x = ((foo = 1), bar = 1) 12 | - 13 | TypeLabel "x" (TypeIdent "Foo") 14 | = 15 | type Foo = y : Int 16 | x : Foo 17 | x = y = 1 18 | - 19 | TypeLabel "x" (TypeIdent "Foo") 20 | = 21 | type False = Unit 22 | ffi fls : False 23 | ffi bool : False => Int 24 | bool fls 25 | - 26 | TypeIdent "Int" 27 | = 28 | type Foo a = foo : a 29 | 30 | x : Foo Int = foo = 1 31 | y : Foo String = foo = "foo" 32 | - 33 | TypeLabel "y" (TypeApply (TypeIdent "Foo") [TypeIdent "String"]) -------------------------------------------------------------------------------- /tests/infer/31 typerow.txt: -------------------------------------------------------------------------------- 1 | foo x = 2 | x.foo 3 | x.bar 4 | - 5 | TypeLabel "foo" (TypeFunc (TypeRow (TypeVar "c") [TypeLabel "foo" (TypeVar "a"),TypeLabel "bar" (TypeVar "b")]) (TypeRecord [TypeVar "a",TypeVar "b"])) 6 | = 7 | foo x = 8 | x.foo 9 | x.bar 10 | x.qwe 11 | - 12 | TypeLabel "foo" (TypeFunc (TypeRow (TypeVar "d") [TypeLabel "foo" (TypeVar "a"),TypeLabel "bar" (TypeVar "b"),TypeLabel "qwe" (TypeVar "c")]) (TypeRecord [TypeVar "a",TypeVar "b",TypeVar "c"])) 13 | = 14 | ffi foo : (Int, Int) => Int 15 | test x = foo x.foo x.bar 16 | - 17 | TypeLabel "test" (TypeFunc (TypeRow (TypeVar "a") [TypeLabel "foo" (TypeIdent "Int"),TypeLabel "bar" (TypeIdent "Int")]) (TypeIdent "Int")) 18 | = 19 | foo (x,y) z = 0 20 | foo (1,2) 3 21 | - 22 | TypeIdent "Int" 23 | = 24 | ffi eqInt : (Int, Int) => Bool 25 | foo = case 26 | x y | (eqInt x 1) => 2 27 | z => 1 28 | - 29 | TypeLabel "foo" (TypeFunc (TypeUnion [TypeRow (TypeVar "b") [TypeLabel "item1" (TypeIdent "Int"),TypeLabel "item2" (TypeVar "a")],TypeVar "c"]) (TypeIdent "Int")) -------------------------------------------------------------------------------- /tests/infer/32 union.txt: -------------------------------------------------------------------------------- 1 | ffi foo : (Int | Unit) => Int 2 | foo 1 3 | - 4 | TypeIdent "Int" 5 | = 6 | ffi foo : Int => Int 7 | ffi x : (Int | Unit) 8 | foo x 9 | - 10 | (UnificationFail (TypeUnion [TypeIdent "Int",TypeIdent "Unit"]) (TypeIdent "Int"),(3,1,"")) 11 | = 12 | ffi foo : (Int | Unit | String) 13 | bar : (Int | Unit) 14 | bar = foo 15 | - 16 | (UnificationFail (TypeIdent "String") (TypeUnion [TypeIdent "Int",TypeIdent "Unit"]),(2,1,"")) 17 | = 18 | ffi foo : (Int | Unit) 19 | bar : (Int | Unit | String) 20 | bar = foo 21 | - 22 | TypeLabel "bar" (TypeUnion [TypeIdent "Int",TypeIdent "Unit",TypeIdent "String"]) 23 | = 24 | foo = case (\(x : Int) => 2) (_ => 3) 25 | foo 1 26 | - 27 | TypeIdent "Int" -------------------------------------------------------------------------------- /tests/infer/33 union2.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | type Bar = Foo 3 | bar : Bar 4 | bar = 1 5 | - 6 | (TextError "type synonym \"Foo\" is already used",(3,1,"")) 7 | = 8 | type Foo = Int 9 | type Bar = Int 10 | type FooBar = Foo | Bar 11 | x : FooBar 12 | x = 1 13 | - 14 | (UnificationFail (TypeIdent "Int") (TypeUnion [TypeIdent "Foo",TypeIdent "Bar"]),(4,1,"")) 15 | = 16 | type Foo = Int | String 17 | type Bar = Foo | Int 18 | - 19 | (TypeUnionWithUnion "Bar",(2,1,"")) 20 | = 21 | type Bar = Int 22 | type Foo = Int | Double 23 | bar : Bar 24 | bar = 1 25 | foo : Foo 26 | foo = bar 27 | - 28 | (UnificationFail (TypeIdent "Bar") (TypeUnion [TypeIdent "Int",TypeIdent "Double"]),(5,1,"")) 29 | = 30 | type Foo a = Int | Foo a 31 | - 32 | (UnboundType "Foo",(1,1,"")) -------------------------------------------------------------------------------- /tests/infer/34 union3.txt: -------------------------------------------------------------------------------- 1 | ffi type None 2 | ffi none : None 3 | type Maybe a = None 4 | foo : Maybe 5 | foo = none 6 | - 7 | TypeLabel "foo" (TypeIdent "Maybe") -------------------------------------------------------------------------------- /tests/infer/35 with type.txt: -------------------------------------------------------------------------------- 1 | ffi foo : Int 2 | foo = 1 3 | - 4 | TypeLabel "foo" (TypeIdent "Int") -------------------------------------------------------------------------------- /tests/infer/36 lazy.txt: -------------------------------------------------------------------------------- 1 | type Lazy a = a 2 | 3 | foo : Lazy Int 4 | foo = 1 5 | - 6 | TypeLabel "foo" (TypeApply (TypeIdent "Lazy") [TypeIdent "Int"]) -------------------------------------------------------------------------------- /tests/infer/37 with.txt: -------------------------------------------------------------------------------- 1 | x = foo = 1 2 | /* TODO y : (foo : Int) */ 3 | y = x with foo = 1 4 | - 5 | TypeLabel "y" (TypeRow (TypeVar "a") [TypeLabel "foo" (TypeIdent "Int")]) 6 | = 7 | \x => x with bar = 1 8 | - 9 | TypeFunc (TypeRow (TypeVar "a") [TypeLabel "bar" (TypeIdent "Int")]) (TypeRow (TypeVar "a") [TypeLabel "bar" (TypeIdent "Int")]) -------------------------------------------------------------------------------- /tests/infer/38 if.txt: -------------------------------------------------------------------------------- 1 | if true then 1 else 2 2 | - 3 | TypeIdent "Int" 4 | = 5 | foo x y = if x then x else y 6 | - 7 | TypeLabel "foo" (TypeFunc (TypeRecord [TypeIdent "Bool",TypeIdent "Bool"]) (TypeIdent "Bool")) 8 | = 9 | if true then 1 else "str" 10 | - 11 | (UnificationFail (TypeIdent "Int") (TypeIdent "String"),(1,1,"")) 12 | = 13 | if 0 then 1 else 2 14 | - 15 | (UnificationFail (TypeIdent "Int") (TypeIdent "Bool"),(1,1,"")) -------------------------------------------------------------------------------- /tests/infer/39 set.txt: -------------------------------------------------------------------------------- 1 | x = 1 2 | x := 2 3 | - 4 | NoType 5 | = 6 | x = 1 7 | x := "str" 8 | - 9 | (UnificationFail (TypeIdent "String") (TypeIdent "Int"),(2,1,"")) 10 | = 11 | foo = 1 12 | bar x = foo := x 13 | - 14 | TypeLabel "bar" (TypeFunc (TypeIdent "Int") NoType) 15 | = 16 | foo = bar = 1 17 | foo.bar := 2 18 | - 19 | NoType -------------------------------------------------------------------------------- /tests/infer/cases match: -------------------------------------------------------------------------------- 1 | cases 2 | \(x : Int) (y : Double) => (1, 1.0) 3 | \(y : Double) (x : Int) => (1.0, 1) 4 | - 5 | (Int | Double), (Double | Int) => (Int | Double), (Double | Int) 6 | -------------------------------------------------------------------------------- /tests/infer/class eq: -------------------------------------------------------------------------------- 1 | class eq a : (a,a) => Bool 2 | ffi eqInt : (Int,Int) => Bool 3 | ffi eqDouble : (Double,Double) => Bool 4 | ffi and : (Bool, Bool) => Bool 5 | instance Int eq = eqInt 6 | instance Double eq = eqDouble 7 | cases 8 | 1 1.0 => (1, 1.0) 9 | 1.0 1 => (1.0, 1) 10 | - 11 | (Int | Double), (Double | Int) => (Int | Double), (Double | Int) 12 | -------------------------------------------------------------------------------- /tests/infer/class maybe: -------------------------------------------------------------------------------- 1 | ffi unit : Unit 2 | type None = Unit 3 | none : None 4 | none = unit 5 | type Maybe a = None | a 6 | mapMaybe f = cases (\(z : None) => none), (\z => f z) 7 | - 8 | mapMaybe : (a => b => (None | a) => (None | b)) 9 | = 10 | ffi unit : Unit 11 | type None = Unit 12 | none : None 13 | none = unit 14 | type Maybe a = None | a 15 | pureMaybe : a => Maybe a 16 | pureMaybe x = x 17 | - 18 | pureMaybe : (a => Maybe(a)) 19 | = 20 | ffi unit : Unit 21 | type None = Unit 22 | none : None 23 | none = unit 24 | type Maybe a = None | a 25 | mapMaybe : (a => b) => ((Maybe a) => Maybe b) 26 | mapMaybe f = cases (\(z : None) => none), (\z => f z) 27 | - 28 | mapMaybe : (a => b => Maybe(a) => Maybe(b)) 29 | = 30 | ffi unit : Unit 31 | type None = Unit 32 | none : None 33 | none = unit 34 | type Maybe a = None | a 35 | class map f : (a => b), f a => f b 36 | mapMaybe : ((a => b), (Maybe a)) => Maybe b 37 | mapMaybe f x = x # cases (\(z : None) => none), (\z => f z) 38 | instance Maybe map = mapMaybe 39 | - 40 | NoType 41 | 42 | -------------------------------------------------------------------------------- /tests/infer/func c: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | class show a : a => String 3 | foo : Foo a => String 4 | foo x = show x.foo 5 | bar x = foo x 6 | 7 | -------------------------------------------------------------------------------- /tests/infer/tuple: -------------------------------------------------------------------------------- 1 | type Foo = (Int, Int) 2 | x : Foo 3 | x = (item1 = 1), item2 = 2 4 | - 5 | x : Foo 6 | = 7 | foo (x,y) z = x 8 | bar = foo (1,2) 3 9 | - 10 | bar : Int 11 | = 12 | foo y = y.foo 13 | foo (bar = 1) 14 | - 15 | foo : c, d <> bar : Int 16 | = 17 | foo y = y.foo 18 | foo (foo = 1) 19 | - 20 | Int -------------------------------------------------------------------------------- /tests/inferast/1 call.txt: -------------------------------------------------------------------------------- 1 | ffi foo: a => String 2 | foo 1 3 | - 4 | (RecordF [(FfiF "foo" (TypeFunc (TypeVar "a") (TypeIdent "String")) ANN NoType),(CallF (IdentF "foo" ANN TypeFunc (TypeIdent "Int") (TypeIdent "String")) (LitF (LitInt 1) ANN TypeIdent "Int") ANN TypeIdent "String")] ANN TypeRecord [NoType,TypeIdent "String"]) -------------------------------------------------------------------------------- /tests/inferast/2 call.txt: -------------------------------------------------------------------------------- 1 | ffi show: a => String 2 | foo x = show x 3 | bar = foo 1 4 | - 5 | (RecordF [(FfiF "show" (TypeFunc (TypeVar "a") (TypeIdent "String")) ANN NoType),(RecordLabelF "foo" (FunctionF (ParamIdentF "x" ANN TypeVar "d") Nothing (CallF (IdentF "show" ANN TypeFunc (TypeVar "d") (TypeIdent "String")) (IdentF "x" ANN TypeVar "d") ANN TypeIdent "String") ANN TypeFunc (TypeVar "d") (TypeIdent "String")) ANN TypeLabel "foo" (TypeFunc (TypeVar "d") (TypeIdent "String"))),(RecordLabelF "bar" (CallF (IdentF "foo" ANN TypeFunc (TypeIdent "Int") (TypeIdent "String")) (LitF (LitInt 1) ANN TypeIdent "Int") ANN TypeIdent "String") ANN TypeLabel "bar" (TypeIdent "String"))] ANN TypeRecord [NoType,TypeLabel "foo" (TypeFunc (TypeVar "d") (TypeIdent "String")),TypeLabel "bar" (TypeIdent "String")]) -------------------------------------------------------------------------------- /tests/inferast/3 class show.txt: -------------------------------------------------------------------------------- 1 | class show a: a => String 2 | instance Int show x = "test" 3 | y = show 1 4 | - 5 | (RecordF [(ClassFnF "show" (TypePoly [TypeVar "a"] (TypeFunc (TypeVar "a") (TypeIdent "String"))) ANN NoType),(InstanceFnF (TypeIdent "Int") "show" (FunctionF (ParamIdentF "x" ANN TypeVar "b") Nothing (LitF (LitString "test") ANN TypeIdent "String") ANN TypeFunc (TypeVar "b") (TypeIdent "String")) ANN TypeFunc (TypeVar "b") (TypeIdent "String")),(RecordLabelF "y" (CallF (IdentF "show" ANN TypeFunc (TypeIdent "Int") (TypeIdent "String")) (LitF (LitInt 1) ANN TypeIdent "Int") ANN TypeIdent "String") ANN TypeLabel "y" (TypeIdent "String"))] ANN TypeRecord [NoType,TypeFunc (TypeVar "b") (TypeIdent "String"),TypeLabel "y" (TypeIdent "String")]) -------------------------------------------------------------------------------- /tests/inferast/4 lit.txt: -------------------------------------------------------------------------------- 1 | 1 2 | - 3 | (LitF (LitInt 1) ANN TypeIdent "Int") 4 | = 5 | type Foo = Int 6 | bar : Foo 7 | bar = 1 8 | - 9 | (RecordF [(TypeDeclF "Foo" (TypeIdent "Int") ANN NoType),(RecordLabelF "bar" (LitF (LitInt 1) ANN TypeIdent "Foo") ANN TypeLabel "bar" (TypeIdent "Foo"))] ANN TypeRecord [NoType,TypeLabel "bar" (TypeIdent "Foo")]) -------------------------------------------------------------------------------- /tests/inferast/5 cases show.txt: -------------------------------------------------------------------------------- 1 | class show a : a => String 2 | foo = case 3 | x => show x 4 | - 5 | (RecordF [(ClassFnF "show" (TypePoly [TypeVar "a"] (TypeFunc (TypeVar "a") (TypeIdent "String"))) ANN NoType),(RecordLabelF "foo" (CasesF [(FunctionF (ParamIdentF "x" ANN TypeConstraints [(TypeVar "f","show")] (TypeVar "f")) Nothing (CallF (IdentF "show" ANN TypeConstraints [(TypeVar "f","show")] (TypeFunc (TypeVar "f") (TypeIdent "String"))) (IdentF "x" ANN TypeConstraints [(TypeVar "f","show")] (TypeVar "f")) ANN TypeIdent "String") ANN TypeFunc (TypeConstraints [(TypeVar "f","show")] (TypeVar "f")) (TypeIdent "String"))] ANN TypeFunc (TypeConstraints [(TypeVar "f","show")] (TypeVar "f")) (TypeIdent "String")) ANN TypeLabel "foo" (TypeFunc (TypeConstraints [(TypeVar "f","show")] (TypeVar "f")) (TypeIdent "String")))] ANN TypeRecord [NoType,TypeLabel "foo" (TypeFunc (TypeConstraints [(TypeVar "f","show")] (TypeVar "f")) (TypeIdent "String"))]) -------------------------------------------------------------------------------- /tests/inferast/6 typechange.txt: -------------------------------------------------------------------------------- 1 | type Foo = Int 2 | pureFoo : Int => Foo 3 | pureFoo x = x 4 | - 5 | (RecordF [(TypeDeclF "Foo" (TypeIdent "Int") ANN NoType),(RecordLabelF "pureFoo" (FunctionF (ParamIdentF "x" ANN TypeIdent "Int") Nothing (IdentF "x" ANN TypeIdent "Int") ANN TypeFunc (TypeIdent "Int") (TypeIdent "Foo")) ANN TypeLabel "pureFoo" (TypeFunc (TypeIdent "Int") (TypeIdent "Foo")))] ANN TypeRecord [NoType,TypeLabel "pureFoo" (TypeFunc (TypeIdent "Int") (TypeIdent "Foo"))]) -------------------------------------------------------------------------------- /tests/parser/01 ident.txt: -------------------------------------------------------------------------------- 1 | foo 2 | - 3 | Ident "foo" 4 | -------------------------------------------------------------------------------- /tests/parser/02 lit.txt: -------------------------------------------------------------------------------- 1 | 10 2 | - 3 | Lit (LitInt 10) 4 | = 5 | 10.1 6 | - 7 | Lit (LitDouble 10.1) 8 | = 9 | 'a' 10 | - 11 | Lit (LitChar 'a') 12 | = 13 | "test" 14 | - 15 | Lit (LitString "test") 16 | = 17 | foo "foo" "foo" 18 | - 19 | Call (Ident "foo") (Record [Lit (LitString "foo"),Lit (LitString "foo")]) 20 | = 21 | true 22 | - 23 | Lit (LitBool True) -------------------------------------------------------------------------------- /tests/parser/03 array.txt: -------------------------------------------------------------------------------- 1 | [1 foo bar (foo bar)] 2 | - 3 | Array [Lit (LitInt 1),Ident "foo",Ident "bar",Call (Ident "foo") (Ident "bar")] 4 | = 5 | [ 6 | 1 7 | foo 8 | bar 9 | foo bar 10 | ] 11 | - 12 | Array [Lit (LitInt 1),Ident "foo",Ident "bar",Call (Ident "foo") (Ident "bar")] 13 | = 14 | [] 15 | - 16 | Array [] 17 | = 18 | [1, foo bar] 19 | - 20 | Array [Lit (LitInt 1),Call (Ident "foo") (Ident "bar")] 21 | = 22 | [1 _ 2] 23 | - 24 | Function (ParamIdent "_a") Nothing (Array [Lit (LitInt 1),Ident "_a",Lit (LitInt 2)]) -------------------------------------------------------------------------------- /tests/parser/04 ffi.txt: -------------------------------------------------------------------------------- 1 | ffi foo : Int 2 | - 3 | Ffi "foo" (TypeIdent "Int") 4 | = 5 | ffi type Array a 6 | - 7 | FfiType "Array" (TypePoly [TypeVar "a"] (TypeIdent "Array")) -------------------------------------------------------------------------------- /tests/parser/05 func.txt: -------------------------------------------------------------------------------- 1 | foo x = 1 2 | - 3 | RecordLabel "foo" (Function (ParamIdent "x") Nothing (Lit (LitInt 1))) 4 | = 5 | foo x y = 1 6 | - 7 | RecordLabel "foo" (Function (Record [ParamIdent "x",ParamIdent "y"]) Nothing (Lit (LitInt 1))) 8 | = 9 | foo ^x = 1 10 | - 11 | RecordLabel "foo" (Function (ParamIdent "_a") (Just (Call (Ident "eq") (Record [Ident "_a",Ident "x"]))) (Lit (LitInt 1))) 12 | -------------------------------------------------------------------------------- /tests/parser/06 anonfunc.txt: -------------------------------------------------------------------------------- 1 | x => 1 2 | - 3 | Function (ParamIdent "x") Nothing (Lit (LitInt 1)) 4 | = 5 | x y => 1 6 | - 7 | Function (Record [ParamIdent "x",ParamIdent "y"]) Nothing (Lit (LitInt 1)) 8 | = 9 | \ (x : Int) => x 10 | - 11 | Function (ExprType (TypeLabel "x" (TypeIdent "Int"))) Nothing (Ident "x") 12 | = 13 | x | 1 => x 14 | - 15 | Function (ParamIdent "x") (Just (Lit (LitInt 1))) (Ident "x") -------------------------------------------------------------------------------- /tests/parser/07 call.txt: -------------------------------------------------------------------------------- 1 | foo x 2 | - 3 | Call (Ident "foo") (Ident "x") 4 | = 5 | foo x y 6 | - 7 | Call (Ident "foo") (Record [Ident "x",Ident "y"]) 8 | = 9 | foo (bar y) 10 | - 11 | Call (Ident "foo") (Call (Ident "bar") (Ident "y")) 12 | = 13 | foo (x = 1) 14 | - 15 | Call (Ident "foo") (RecordLabel "x" (Lit (LitInt 1))) 16 | = 17 | foo (x = 1) (y = 1) 18 | - 19 | Call (Ident "foo") (Record [RecordLabel "x" (Lit (LitInt 1)),RecordLabel "y" (Lit (LitInt 1))]) 20 | = 21 | foo (x => x) 22 | - 23 | Call (Ident "foo") (Function (ParamIdent "x") Nothing (Ident "x")) 24 | = 25 | x | (foo x) => x 26 | - 27 | Function (ParamIdent "x") (Just (Call (Ident "foo") (Ident "x"))) (Ident "x") 28 | = 29 | foo case (x => x) 30 | - 31 | Call (Ident "foo") (Cases [Function (ParamIdent "x") Nothing (Ident "x")]) -------------------------------------------------------------------------------- /tests/parser/08 call-op.txt: -------------------------------------------------------------------------------- 1 | x # case (x => 2) 2 | - 3 | Call (Cases [Function (ParamIdent "x") Nothing (Lit (LitInt 2))]) (Ident "x") 4 | = 5 | foo (bar [1 2 3] # qwe) 6 | - 7 | Call (Ident "foo") (Call (Ident "qwe") (Call (Ident "bar") (Array [Lit (LitInt 1),Lit (LitInt 2),Lit (LitInt 3)]))) 8 | = 9 | 1 , 2 # foo 10 | - 11 | Call (Ident "foo") (Record [Lit (LitInt 1),Lit (LitInt 2)]) 12 | = 13 | foo $ bar qwe 14 | - 15 | Call (Ident "foo") (Call (Ident "bar") (Ident "qwe")) -------------------------------------------------------------------------------- /tests/parser/09 indent.txt: -------------------------------------------------------------------------------- 1 | foo = 2 | 1 3 | 2 4 | bar = 5 | 3 6 | 4 7 | - 8 | Record [RecordLabel "foo" (Record [Lit (LitInt 1),Lit (LitInt 2)]),RecordLabel "bar" (Record [Lit (LitInt 3),Lit (LitInt 4)])] 9 | = 10 | foo (x) = 11 | 1 12 | 2 13 | - 14 | RecordLabel "foo" (Function (ParamIdent "x") Nothing (Record [Lit (LitInt 1),Lit (LitInt 2)])) 15 | = 16 | type Foo = 17 | Int 18 | Int 19 | - 20 | TypeDecl "Foo" (TypeRecord [TypeIdent "Int",TypeIdent "Int"]) 21 | = 22 | case 23 | x => 1 24 | - 25 | Cases [Function (ParamIdent "x") Nothing (Lit (LitInt 1))] 26 | = 27 | foo = 28 | case 29 | x => 1 30 | - 31 | RecordLabel "foo" (Cases [Function (ParamIdent "x") Nothing (Lit (LitInt 1))]) -------------------------------------------------------------------------------- /tests/parser/10 label.txt: -------------------------------------------------------------------------------- 1 | foo = 1 2 | - 3 | RecordLabel "foo" (Lit (LitInt 1)) 4 | = 5 | foo = bar = 1 6 | - 7 | RecordLabel "foo" (RecordLabel "bar" (Lit (LitInt 1))) 8 | = 9 | y = foo 1.0 10 | - 11 | RecordLabel "y" (Call (Ident "foo") (Lit (LitDouble 1.0))) 12 | = 13 | x = 1 14 | y = 2 15 | - 16 | Record [RecordLabel "x" (Lit (LitInt 1)),RecordLabel "y" (Lit (LitInt 2))] 17 | = 18 | x = 1, y = 2 19 | - 20 | Record [RecordLabel "x" (Lit (LitInt 1)),RecordLabel "y" (Lit (LitInt 2))] 21 | = 22 | x = y = 1, z = 2 23 | - 24 | Record [RecordLabel "x" (RecordLabel "y" (Lit (LitInt 1))),RecordLabel "z" (Lit (LitInt 2))] 25 | = 26 | x = (1, y = 2) 27 | - 28 | RecordLabel "x" (Record [Lit (LitInt 1),RecordLabel "y" (Lit (LitInt 2))]) 29 | = 30 | foo (_.foo) 31 | - 32 | Call (Ident "foo") (Function (ParamIdent "_a") Nothing (Call (LabelAccess "foo") (Ident "_a"))) 33 | = 34 | x.foo 35 | - 36 | Call (LabelAccess "foo") (Ident "x") 37 | = 38 | x.foo.bar 39 | - 40 | Call (LabelAccess "bar") (Call (LabelAccess "foo") (Ident "x")) 41 | = 42 | x = y.foo 43 | - 44 | RecordLabel "x" (Call (LabelAccess "foo") (Ident "y")) -------------------------------------------------------------------------------- /tests/parser/11 let.txt: -------------------------------------------------------------------------------- 1 | x = 1 in 2 2 | - 3 | Let (RecordLabel "x" (Lit (LitInt 1))) (Lit (LitInt 2)) 4 | = 5 | x = 1 6 | in 2 7 | - 8 | Let (RecordLabel "x" (Lit (LitInt 1))) (Lit (LitInt 2)) 9 | = 10 | x = 1 11 | in 12 | x 13 | x 14 | - 15 | Let (RecordLabel "x" (Lit (LitInt 1))) (Record [Ident "x",Ident "x"]) 16 | = 17 | foo x = y = bar z in y 18 | - 19 | RecordLabel "foo" (Function (ParamIdent "x") Nothing (Let (RecordLabel "y" (Call (Ident "bar") (Ident "z"))) (Ident "y"))) -------------------------------------------------------------------------------- /tests/parser/12 instance.txt: -------------------------------------------------------------------------------- 1 | instance Int eq x y = eqInt x y 2 | - 3 | InstanceFn (TypeIdent "Int") "eq" (Function (Record [ParamIdent "x",ParamIdent "y"]) Nothing (Call (Ident "eqInt") (Record [Ident "x",Ident "y"]))) 4 | = 5 | instance (Foo (a eq <: a)) eq = eqFoo 6 | - 7 | InstanceFn (TypeApply (TypeIdent "Foo") [TypeConstraints [(TypeVar "a","eq")] (TypeVar "a")]) "eq" (Ident "eqFoo") 8 | = 9 | instance (a eq <: Foo a) eq = eqFoo 10 | - 11 | InstanceFn (TypeConstraints [(TypeVar "a","eq")] (TypeApply (TypeIdent "Foo") [TypeVar "a"])) "eq" (Ident "eqFoo") -------------------------------------------------------------------------------- /tests/parser/13 classes.txt: -------------------------------------------------------------------------------- 1 | class eq a: (a,a) => Unit 2 | - 3 | ClassFn "eq" (TypePoly [TypeVar "a"] (TypeFunc (TypeRecord [TypeVar "a",TypeVar "a"]) (TypeIdent "Unit"))) 4 | = 5 | foo : a show <: a 6 | - 7 | ExprType (TypeLabel "foo" (TypeConstraints [(TypeVar "a","show")] (TypeVar "a"))) -------------------------------------------------------------------------------- /tests/parser/14 monoid.txt: -------------------------------------------------------------------------------- 1 | class mempty a: a 2 | - 3 | ClassFn "mempty" (TypePoly [TypeVar "a"] (TypeVar "a")) 4 | = 5 | instance Int mempty = 0 6 | - 7 | InstanceFn (TypeIdent "Int") "mempty" (Lit (LitInt 0)) -------------------------------------------------------------------------------- /tests/parser/15 import.txt: -------------------------------------------------------------------------------- 1 | import list 2 | - 3 | Stmt (StmtImport ["list"] Nothing) 4 | = 5 | import list as l 6 | - 7 | Stmt (StmtImport ["list"] (Just "l")) 8 | = 9 | include list 10 | - 11 | Stmt (StmtInclude ["list"]) 12 | = 13 | import foo.bar as l 14 | - 15 | Stmt (StmtImport ["foo","bar"] (Just "l")) -------------------------------------------------------------------------------- /tests/parser/16 open.txt: -------------------------------------------------------------------------------- 1 | open foo 2 | - 3 | Stmt (StmtOpen "foo") -------------------------------------------------------------------------------- /tests/parser/17 cases.txt: -------------------------------------------------------------------------------- 1 | case (x => 1) (y => 1) 2 | - 3 | Cases [Function (ParamIdent "x") Nothing (Lit (LitInt 1)),Function (ParamIdent "y") Nothing (Lit (LitInt 1))] 4 | = 5 | case (x => 1) 6 | - 7 | Cases [Function (ParamIdent "x") Nothing (Lit (LitInt 1))] 8 | = 9 | case (\x | (1) => 1) 10 | - 11 | Cases [Function (ParamIdent "x") (Just (Lit (LitInt 1))) (Lit (LitInt 1))] 12 | = 13 | case (\x => 1) (\y => 2) 14 | - 15 | Cases [Function (ParamIdent "x") Nothing (Lit (LitInt 1)),Function (ParamIdent "y") Nothing (Lit (LitInt 2))] 16 | = 17 | foo = case 18 | x y => 2 19 | z => 2 20 | - 21 | RecordLabel "foo" (Cases [Function (ParamIdent "_a") Nothing (Let (Record [RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a"))]) (Lit (LitInt 2))),Function (ParamIdent "z") Nothing (Lit (LitInt 2))]) 22 | = 23 | ffi eqInt : (Int, Int) => Bool 24 | foo = case 25 | x y | (eqInt x 1) => 2 26 | z => 2 27 | - 28 | Record [Ffi "eqInt" (TypeFunc (TypeRecord [TypeIdent "Int",TypeIdent "Int"]) (TypeIdent "Bool")),RecordLabel "foo" (Cases [Function (ParamIdent "_a") (Just (Let (Record [RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a"))]) (Call (Ident "eqInt") (Record [Ident "x",Lit (LitInt 1)])))) (Let (Record [RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a"))]) (Lit (LitInt 2))),Function (ParamIdent "z") Nothing (Lit (LitInt 2))])] -------------------------------------------------------------------------------- /tests/parser/18 match.txt: -------------------------------------------------------------------------------- 1 | x y => 1 2 | - 3 | Function (Record [ParamIdent "x",ParamIdent "y"]) Nothing (Lit (LitInt 1)) 4 | = 5 | x, y => 1 6 | - 7 | Function (ParamIdent "_a") Nothing (Let (Record [RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a"))]) (Lit (LitInt 1))) 8 | = 9 | \(x, y) => 1 10 | - 11 | Function (ParamIdent "_a") Nothing (Let (Record [RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a"))]) (Lit (LitInt 1))) 12 | = 13 | x, y z => 1 14 | - 15 | Function (Record [ParamIdent "_a",ParamIdent "z"]) Nothing (Let (Record [RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a"))]) (Lit (LitInt 1))) 16 | = 17 | \(x,y) (l,m) => m 18 | - 19 | Function (Record [ParamIdent "_a",ParamIdent "_b"]) Nothing (Let (Record [RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a")),RecordLabel "l" (Call (LabelAccess "item1") (Ident "_b")),RecordLabel "m" (Call (LabelAccess "item2") (Ident "_b"))]) (Ident "m")) 20 | = 21 | _ => 1 22 | - 23 | Function (ParamIdent "_a") Nothing (Lit (LitInt 1)) 24 | = 25 | 1 => 1 26 | - 27 | Function (ParamIdent "_a") (Just (Call (Ident "eq") (Record [Ident "_a",Lit (LitInt 1)]))) (Lit (LitInt 1)) 28 | = 29 | 1 2 => 1 30 | - 31 | Function (Record [ParamIdent "_a",ParamIdent "_b"]) (Just (Call (Ident "andBool") (Record [Call (Ident "eq") (Record [Ident "_a",Lit (LitInt 1)]),Call (Ident "eq") (Record [Ident "_b",Lit (LitInt 2)])]))) (Lit (LitInt 1)) 32 | = 33 | \(x = 1) => 1 34 | - 35 | Function (ParamIdent "_a") (Just (Call (Ident "eq") (Record [Call (LabelAccess "x") (Ident "_a"),Lit (LitInt 1)]))) (Lit (LitInt 1)) 36 | = 37 | \(foo = 1, bar = 1) => 1 38 | - 39 | Function (Record [ParamIdent "_a",ParamIdent "_b"]) (Just (Call (Ident "andBool") (Record [Call (Ident "eq") (Record [Call (LabelAccess "foo") (Ident "_a"),Lit (LitInt 1)]),Call (Ident "eq") (Record [Call (LabelAccess "bar") (Ident "_b"),Lit (LitInt 1)])]))) (Lit (LitInt 1)) 40 | = 41 | \(x = y) => 1 42 | - 43 | Function (ParamIdent "_a") Nothing (Let (RecordLabel "y" (Call (LabelAccess "x") (Ident "_a"))) (Lit (LitInt 1))) 44 | = 45 | \(foo = x, bar = y) => 1 46 | - 47 | Function (Record [ParamIdent "_a",ParamIdent "_b"]) Nothing (Let (Record [RecordLabel "x" (Call (LabelAccess "foo") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "bar") (Ident "_b"))]) (Lit (LitInt 1))) 48 | = 49 | ^qwe => 1 50 | - 51 | Function (ParamIdent "_a") (Just (Call (Ident "eq") (Record [Ident "_a",Ident "qwe"]))) (Lit (LitInt 1)) 52 | = 53 | \(x = 1) 2 => 3 54 | - 55 | Function (Record [ParamIdent "_a",ParamIdent "_b"]) (Just (Call (Ident "andBool") (Record [Call (Ident "eq") (Record [Call (LabelAccess "x") (Ident "_a"),Lit (LitInt 1)]),Call (Ident "eq") (Record [Ident "_b",Lit (LitInt 2)])]))) (Lit (LitInt 3)) 56 | = 57 | \(x = 1), 2 => 3 58 | - 59 | Function (ParamIdent "_a") (Just (Call (Ident "andBool") (Record [Call (Ident "eq") (Record [Call (LabelAccess "x") (Ident "_a"),Lit (LitInt 1)]),Call (Ident "eq") (Record [Call (LabelAccess "item2") (Ident "_a"),Lit (LitInt 2)])]))) (Lit (LitInt 3)) 60 | -------------------------------------------------------------------------------- /tests/parser/19 poly.txt: -------------------------------------------------------------------------------- 1 | type Bar a = List a 2 | - 3 | TypeDecl "Bar" (TypePoly [TypeVar "a"] (TypeApply (TypeIdent "List") [TypeVar "a"])) 4 | = 5 | foo: (List a) => a 6 | - 7 | ExprType (TypeLabel "foo" (TypeFunc (TypeApply (TypeIdent "List") [TypeVar "a"]) (TypeVar "a"))) 8 | = 9 | foo: a b 10 | - 11 | ExprType (TypeLabel "foo" (TypeApply (TypeVar "a") [TypeVar "b"])) -------------------------------------------------------------------------------- /tests/parser/20 typeapply.txt: -------------------------------------------------------------------------------- 1 | foo : Foo Int => Int 2 | - 3 | ExprType (TypeLabel "foo" (TypeFunc (TypeApply (TypeIdent "Foo") [TypeIdent "Int"]) (TypeIdent "Int"))) 4 | = 5 | foo : Foo Int Int => Int 6 | - 7 | ExprType (TypeLabel "foo" (TypeFunc (TypeApply (TypeIdent "Foo") [TypeIdent "Int",TypeIdent "Int"]) (TypeIdent "Int"))) -------------------------------------------------------------------------------- /tests/parser/21 types.txt: -------------------------------------------------------------------------------- 1 | type Foo = y : Int 2 | x : Foo 3 | x = y = 1 4 | - 5 | Record [TypeDecl "Foo" (TypeLabel "y" (TypeIdent "Int")),RecordLabel "x" (WithType (RecordLabel "y" (Lit (LitInt 1))) (TypeIdent "Foo"))] 6 | = 7 | type Foo = Int 8 | - 9 | TypeDecl "Foo" (TypeIdent "Int") 10 | = 11 | type Foo = Foo | Bar 12 | - 13 | TypeDecl "Foo" (TypeUnion [TypeIdent "Foo",TypeIdent "Bar"]) 14 | = 15 | foo : x 16 | - 17 | ExprType (TypeLabel "foo" (TypeVar "x")) 18 | = 19 | foo : x => x 20 | - 21 | ExprType (TypeLabel "foo" (TypeFunc (TypeVar "x") (TypeVar "x"))) 22 | = 23 | foo : Int => Int 24 | - 25 | ExprType (TypeLabel "foo" (TypeFunc (TypeIdent "Int") (TypeIdent "Int"))) 26 | = 27 | foo : (foo : Int, bar : Int) 28 | - 29 | ExprType (TypeLabel "foo" (TypeRecord [TypeLabel "foo" (TypeIdent "Int"),TypeLabel "bar" (TypeIdent "Int")])) 30 | = 31 | foo : Int, Int => Int 32 | - 33 | ExprType (TypeLabel "foo" (TypeFunc (TypeRecord [TypeIdent "Int",TypeIdent "Int"]) (TypeIdent "Int"))) -------------------------------------------------------------------------------- /tests/parser/22 withtype.txt: -------------------------------------------------------------------------------- 1 | foo : Int 2 | foo = 1 3 | - 4 | RecordLabel "foo" (WithType (Lit (LitInt 1)) (TypeIdent "Int")) 5 | = 6 | foo : Int = 1 7 | - 8 | RecordLabel "foo" (WithType (Lit (LitInt 1)) (TypeIdent "Int")) -------------------------------------------------------------------------------- /tests/parser/23 emptytype.txt: -------------------------------------------------------------------------------- 1 | type Foo = bar 2 | - 3 | Record [FfiType "Bar" (TypeIdent "Bar"),RecordLabel "bar" (WithType (UniqObject "bar") (TypeIdent "Bar")),InstanceFn (TypeIdent "Bar") "eq" (Ident "eqAny"),TypeDecl "Foo" (TypeIdent "Bar")] 4 | = 5 | type Foo = bar 6 | foo = bar 7 | - 8 | Record [FfiType "Bar" (TypeIdent "Bar"),RecordLabel "bar" (WithType (UniqObject "bar") (TypeIdent "Bar")),InstanceFn (TypeIdent "Bar") "eq" (Ident "eqAny"),TypeDecl "Foo" (TypeIdent "Bar"),RecordLabel "foo" (Ident "bar")] -------------------------------------------------------------------------------- /tests/parser/24 semi: -------------------------------------------------------------------------------- 1 | 1,2;3 2 | - 3 | RecordF [RecordF [LitF (LitInt 1),LitF (LitInt 2)],LitF (LitInt 3)] -------------------------------------------------------------------------------- /tests/parser/25 operator.txt: -------------------------------------------------------------------------------- 1 | infixl + 6 addInt 2 | - 3 | Stmt StmtOperator 4 | = 5 | ffi add : (Int, Int) => Int 6 | infixl + 6 add 7 | 1 + 2 8 | - 9 | Record [Ffi "add" (TypeFunc (TypeRecord [TypeIdent "Int",TypeIdent "Int"]) (TypeIdent "Int")),Stmt StmtOperator,Call (Ident "add") (Record [Lit (LitInt 1),Lit (LitInt 2)])] 10 | = 11 | ffi mul : (Int, Int) => Int 12 | ffi add : (Int, Int) => Int 13 | infixl + 6 add 14 | infixl * 7 mul 15 | 1 + 2 * 3 16 | - 17 | Record [Ffi "mul" (TypeFunc (TypeRecord [TypeIdent "Int",TypeIdent "Int"]) (TypeIdent "Int")),Ffi "add" (TypeFunc (TypeRecord [TypeIdent "Int",TypeIdent "Int"]) (TypeIdent "Int")),Stmt StmtOperator,Stmt StmtOperator,Call (Ident "add") (Record [Lit (LitInt 1),Call (Ident "mul") (Record [Lit (LitInt 2),Lit (LitInt 3)])])] 18 | = 19 | (1) # foo 20 | - 21 | Call (Ident "foo") (Lit (LitInt 1)) 22 | = 23 | infixl + 6 add 24 | infixl ++ 5 add 25 | 1 ++ 2 26 | - 27 | Record [Stmt StmtOperator,Stmt StmtOperator,Call (Ident "add") (Record [Lit (LitInt 1),Lit (LitInt 2)])] 28 | = 29 | infix == 4 eq 30 | 31 | y = x == 2 32 | - 33 | Record [Stmt StmtOperator,RecordLabel "y" (Call (Ident "eq") (Record [Ident "x",Lit (LitInt 2)]))] -------------------------------------------------------------------------------- /tests/parser/26 as.txt: -------------------------------------------------------------------------------- 1 | foo x@(1,2) = x 2 | - 3 | RecordLabel "foo" (Function (ParamIdent "x") (Just (Call (Ident "andBool") (Record [Call (Ident "eq") (Record [Call (LabelAccess "item1") (Ident "x"),Lit (LitInt 1)]),Call (Ident "eq") (Record [Call (LabelAccess "item2") (Ident "x"),Lit (LitInt 2)])]))) (Ident "x")) 4 | = 5 | @(1,2) => 1 6 | - 7 | Function (ParamIdent "_a") (Just (Call (Ident "andBool") (Record [Call (Ident "eq") (Record [Call (LabelAccess "item1") (Ident "_a"),Lit (LitInt 1)]),Call (Ident "eq") (Record [Call (LabelAccess "item2") (Ident "_a"),Lit (LitInt 2)])]))) (Lit (LitInt 1)) 8 | = 9 | @(foo = x, bar = y) => 1 10 | - 11 | Function (ParamIdent "_a") Nothing (Let (Record [RecordLabel "x" (Call (LabelAccess "foo") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "bar") (Ident "_a"))]) (Lit (LitInt 1))) -------------------------------------------------------------------------------- /tests/parser/27 destruct.txt: -------------------------------------------------------------------------------- 1 | (x,y) = (1,2) 2 | - 3 | Record [RecordLabel "_a" (Record [Lit (LitInt 1),Lit (LitInt 2)]),RecordLabel "x" (Call (LabelAccess "item1") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "item2") (Ident "_a"))] 4 | = 5 | (foo = x) = bar 6 | - 7 | Record [RecordLabel "_a" (Ident "bar"),RecordLabel "x" (Call (LabelAccess "foo") (Ident "_a"))] 8 | = 9 | (foo = x, bar = y) = x 10 | - 11 | Record [RecordLabel "_a" (Ident "x"),RecordLabel "x" (Call (LabelAccess "foo") (Ident "_a")),RecordLabel "y" (Call (LabelAccess "bar") (Ident "_a"))] -------------------------------------------------------------------------------- /tests/parser/28 partial.txt: -------------------------------------------------------------------------------- 1 | foo _ 2 | - 3 | Function (ParamIdent "_a") Nothing (Call (Ident "foo") (Ident "_a")) -------------------------------------------------------------------------------- /tests/parser/29 with.txt: -------------------------------------------------------------------------------- 1 | foo with bar = 1 2 | - 3 | Update (Ident "foo") [RecordLabel "bar" (Lit (LitInt 1))] 4 | = 5 | foo with 6 | bar = 1 7 | qwe = 2 8 | - 9 | Update (Ident "foo") [RecordLabel "bar" (Lit (LitInt 1)),RecordLabel "qwe" (Lit (LitInt 2))] -------------------------------------------------------------------------------- /tests/parser/30 if.txt: -------------------------------------------------------------------------------- 1 | if true then 1 else 2 2 | - 3 | If (Lit (LitBool True)) (Lit (LitInt 1)) (Lit (LitInt 2)) 4 | = 5 | if true 6 | then 1 7 | else 2 8 | - 9 | If (Lit (LitBool True)) (Lit (LitInt 1)) (Lit (LitInt 2)) -------------------------------------------------------------------------------- /tests/parser/31 set.txt: -------------------------------------------------------------------------------- 1 | x = 1 2 | x := 2 3 | - 4 | Record [RecordLabel "x" (Lit (LitInt 1)),SetStmt (Ident "x") (Lit (LitInt 2))] -------------------------------------------------------------------------------- /tests/parser/32 keyword-multiline.txt: -------------------------------------------------------------------------------- 1 | class 2 | foo a : a 3 | bar a : a 4 | - 5 | Record [ClassFn "foo" (TypePoly [TypeVar "a"] (TypeVar "a")),ClassFn "bar" (TypePoly [TypeVar "a"] (TypeVar "a"))] 6 | = 7 | instance 8 | Int foo = 1 9 | Int bar = 1 10 | - 11 | Record [InstanceFn (TypeIdent "Int") "foo" (Lit (LitInt 1)),InstanceFn (TypeIdent "Int") "bar" (Lit (LitInt 1))] 12 | = 13 | import 14 | foo 15 | bar 16 | - 17 | Record [Stmt (StmtImport ["foo"] Nothing),Stmt (StmtImport ["bar"] Nothing)] 18 | = 19 | include 20 | foo 21 | bar 22 | - 23 | Record [Stmt (StmtInclude ["foo"]),Stmt (StmtInclude ["bar"])] -------------------------------------------------------------------------------- /tests/parser/cases-match: -------------------------------------------------------------------------------- 1 | foo = cases 2 | 1 1.0 => 1 3 | - 4 | ? 5 | = 6 | foo = cases 7 | (x : Int) (y : Int) => 2 8 | - 9 | ? 10 | -------------------------------------------------------------------------------- /tests/parser/label-type: -------------------------------------------------------------------------------- 1 | foo : Int = 1 2 | -------------------------------------------------------------------------------- /tests/pretty/01 record.txt: -------------------------------------------------------------------------------- 1 | foo x = x 2 | bar = 1 3 | - 4 | foo : (a => a), bar : Int -------------------------------------------------------------------------------- /tests/pretty/02 constrain.txt: -------------------------------------------------------------------------------- 1 | class show a : a => String 2 | foo = show 3 | - 4 | foo : a show <: (a => String) -------------------------------------------------------------------------------- /tests/pretty/03 type.txt: -------------------------------------------------------------------------------- 1 | type Foo a = foo : a 2 | bar : Foo Int 3 | bar = foo = 1 4 | - 5 | bar : Foo Int 6 | = 7 | type Foo a = foo : a 8 | ffi mempty : a 9 | bar : Foo a 10 | bar = foo = mempty 11 | - 12 | bar : Foo a -------------------------------------------------------------------------------- /tests/pretty/04 union.txt: -------------------------------------------------------------------------------- 1 | ffi f : foo : Int => Int | bar : Int 2 | bar = f 3 | - 4 | bar : foo : (Int => Int | bar : Int) -------------------------------------------------------------------------------- /tests/pretty/05 sub.txt: -------------------------------------------------------------------------------- 1 | foo x = x.foo 2 | - 3 | foo : (b@(foo : a) => a) -------------------------------------------------------------------------------- /tests/rewriter/01 eta.txt: -------------------------------------------------------------------------------- 1 | bar x = x 2 | foo x = bar x 3 | - 4 | ScopeF 5 | [ VarF "bar" (FunctionF [ "x" ] [ ReturnF (IdentF "x") ]) 6 | , VarF "foo" (IdentF "bar") 7 | ] 8 | (ObjectF [ ( "bar" , IdentF "bar" ) , ( "foo" , IdentF "foo" ) ]) -------------------------------------------------------------------------------- /tests/rewriter/02 operator: -------------------------------------------------------------------------------- 1 | ffi and : Bool, Bool => Bool 2 | ff = addBool = 1 3 | foo = ff.andBool true false 4 | - 5 | ObjectF 6 | [ ( "andBool" , IdentF "andBool" ) 7 | , ( "foo" 8 | , OperatorF "&&" [ LitF (LitBool True) , LitF (LitBool False) ] 9 | ) 10 | ] 11 | -------------------------------------------------------------------------------- /tests/rewriter/03 apply.txt: -------------------------------------------------------------------------------- 1 | 1 # (x => x) 2 | - 3 | CallF 4 | (ParensF (FunctionF [ "x" ] [ ReturnF (IdentF "x") ])) 5 | [ LitF (LitInt 1) ] -------------------------------------------------------------------------------- /tests/rewriter/04 instance.txt: -------------------------------------------------------------------------------- 1 | ffi addInt : (Int,Int) => Int 2 | 3 | class add a : a, a => a 4 | 5 | instance Int add x y = addInt x y 6 | 7 | foo = add 1 2 8 | - 9 | ScopeF 10 | [ SetF 11 | (FieldF (FieldF (IdentF "oc") "instances") "add") (ObjectF []) 12 | , VarF 13 | "add" 14 | (FunctionF 15 | [ "x" , "p1" , "p2" ] 16 | [ ReturnF (CallF (IdentF "x") [ IdentF "p1" , IdentF "p2" ]) ]) 17 | , SetF 18 | (FieldF (FieldF (FieldF (IdentF "oc") "instances") "add") "Int") 19 | (IdentF "addInt") 20 | ] 21 | (ObjectF 22 | [ ( "addInt" , IdentF "addInt" ) 23 | , ( "add" , IdentF "add" ) 24 | , ( "foo" 25 | , ParensF (OperatorF "+" [ LitF (LitInt 1) , LitF (LitInt 2) ]) 26 | ) 27 | ]) -------------------------------------------------------------------------------- /tests/rewriter/05 operators: -------------------------------------------------------------------------------- 1 | ffi addInt : (Int,Int) => Int 2 | 3 | class add a : a, a => a 4 | class mul a : a, a => a 5 | 6 | instance Int add x y = addInt x y 7 | instance Int mul x y = mulInt x y 8 | 9 | foo = mul 3 (add 1 2) 10 | --------------------------------------------------------------------------------