diff options
Diffstat (limited to 'source')
| -rw-r--r-- | source/lux/codata/state.lux | 10 | ||||
| -rw-r--r-- | source/lux/control/enum.lux | 2 | ||||
| -rw-r--r-- | source/lux/data/io.lux | 5 | ||||
| -rw-r--r-- | source/lux/data/number/int.lux | 2 | ||||
| -rw-r--r-- | source/lux/host/jvm.lux | 330 | ||||
| -rw-r--r-- | source/lux/meta/syntax.lux | 15 |
6 files changed, 217 insertions, 147 deletions
diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index de7220a45..311fce320 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -23,11 +23,17 @@ (Monad (State s))) (def _functor State/Functor) - (def (wrap x) + (def (wrap a) (lambda [state] - [state x])) + [state a])) (def (join mma) (lambda [state] (let [[state' ma] (mma state)] (ma state'))))) + +## [Functions] +(def #export (run-state state action) + (All [s a] (-> s (State s a) a)) + (let [[state' output] (action state)] + output)) diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux index c54eab75b..4ce368e96 100644 --- a/source/lux/control/enum.lux +++ b/source/lux/control/enum.lux @@ -13,7 +13,7 @@ (: (-> e e) pred)) ## [Functions] -(def #export (range' <= succ from to) +(def (range' <= succ from to) (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) (if (<= from to) (#;Cons from (range' <= succ (succ from) to)) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index a0bfda3e0..973d37e38 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -35,3 +35,8 @@ (def (join mma) (mma []))) + +## [Functions] +(def #export (run-io io) + (All [a] (-> (IO a) a)) + (io [])) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index 20ea5fced..ea58cac17 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -58,7 +58,7 @@ [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) ## Enum -(defstruct Int/Enum (EN;Enum Int) +(defstruct #export Int/Enum (EN;Enum Int) (def _ord Int/Ord) (def succ (lambda [n] (:: Int/Number (N;+ n 1)))) (def pred (lambda [n] (:: Int/Number (N;- n 1))))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 710bc9a20..1e903ad1d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -6,98 +6,202 @@ (;import lux (lux (control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do seq%))) + (monad #as M #refer (#only do seq%)) + (enum #as E)) (data (list #refer #all #open ("" List/Functor List/Fold)) - (number/int #refer #all #open ("i:" Int/Ord)) + (number/int #refer #all #open ("i:" Int/Ord Int/Number)) maybe - tuple) + tuple + (text #open ("text:" Text/Monoid))) (meta lux ast syntax))) (open List/Monad "list:") +## [Types] +(defsyntax #export (Array [dimensions (?^ nat^)] type) + (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner))))) + type + (repeat (? 1 dimensions) []))))) + ## [Utils] +## Types +(deftype StackFrame (^ java.lang.StackTraceElement)) +(deftype StackTrace (Array StackFrame)) + +(deftype Modifier Text) +(deftype JvmType Text) + +(deftype MemberDecl + (& #member-modifiers (List Modifier) + #member-name Text)) + +(deftype FieldDecl + JvmType) + +(deftype MethodDecl + (& #method-inputs (List JvmType) + #method-output JvmType)) + +(deftype ArgDecl + (& #arg-name Text + #arg-type JvmType)) + +(deftype MethodDef + (& #method-vars (List ArgDecl) + #return-type JvmType + #return-body AST)) + +(deftype ExpectedInput + (& #opt-input? Bool + #input-type JvmType)) + +(deftype ExpectedOutput + (& #ex-output? Bool + #opt-output? Bool + #output-type JvmType)) + +## Functions +(def (prepare-args args) + (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text)))) + (do Lux/Monad + [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) + #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) + (lambda [[[opt? arg-class] var]] + (if opt? + [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) + (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) + (case (~ var) + (#;Some (~ var)) (~ var) + #;None ;_jvm_null))))] + [(` (^ (~ (symbol$ ["" arg-class])))) + (@list)]))) + (zip2 args vars)) + var-types (map first pairings) + var-rebinds (map second pairings) + arg-classes (map second args)]] + (wrap [vars var-types (list:join var-rebinds) arg-classes]))) + ## Parsers +(def member-decl^ + (Parser MemberDecl) + (&^ (*^ local-tag^) local-symbol^)) + (def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^] - (wrap [modifiers name inputs output])))) + (Parser (, MemberDecl MethodDecl)) + (form^ (&^ member-decl^ + (&^ (tuple^ (*^ local-symbol^)) + local-symbol^)))) (def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^] - (wrap [modifiers name class])))) + (Parser (, MemberDecl FieldDecl)) + (form^ (&^ member-decl^ + local-symbol^))) (def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^] - (wrap [arg-name arg-class])))) + (Parser ArgDecl) + (form^ (&^ local-symbol^ local-symbol^))) (def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text AST)) + (Parser (, MemberDecl MethodDef)) (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ + [=member-decl member-decl^ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ body id^] - (wrap [modifiers name inputs output body])))) + (wrap [=member-decl [inputs output body]])))) -(def opt-arg^ - (Parser (, Bool Text)) +(def exp-input^ + (Parser ExpectedInput) (&^ (tag?^ ["" "?"]) local-symbol^)) +(def exp-output^ + (Parser ExpectedOutput) + (do Parser/Monad + [ex? (tag?^ ["" "!"]) + opt? (tag?^ ["" "?"]) + return local-symbol^] + (wrap [ex? opt? return]))) + +## Generators +(def (gen-method-decl [[modifiers name] [inputs output]]) + (-> (, MemberDecl MethodDecl) AST) + (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))) + +(def (gen-field-decl [[modifiers name] class]) + (-> (, MemberDecl FieldDecl) AST) + (` ((~ (text$ name)) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))) + +(def (gen-arg-decl [name type]) + (-> ArgDecl AST) + (form$ (@list (symbol$ ["" name]) (text$ type)))) + +(def (gen-method-def [[modifiers name] [inputs output body]]) + (-> (, MemberDecl MethodDef) AST) + (` ((~ (text$ name)) + [(~@ (map gen-arg-decl inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))) + +(def (gen-expected-output [ex? opt? output] body) + (-> ExpectedOutput AST (, AST AST)) + (let [type (` (^ (~ (symbol$ ["" output])))) + [body type] (if opt? + [(` (;;??? (~ body))) + (` (Maybe (~ type)))] + [body type]) + [body type] (if ex? + [(` (;;try (~ body))) + (` (Either Text (~ type)))] + [body type])] + [body type])) + +## [Functions] +(def (stack-trace->text trace) + (-> StackTrace Text) + (let [size (_jvm_arraylength trace) + idxs (E;range Int/Enum 0 (i:+ -1 size))] + (|> idxs + (map (: (-> Int Text) + (lambda [idx] + (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload "java.lang.StackTraceElement" trace idx) [])))) + (interpose "\n") + (foldL text:++ "") + ))) + +(def (get-stack-trace t) + (-> (^ java.lang.Throwable) StackTrace) + (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t [])) + +(def #export (throwable->text t) + ($ text:++ + (_jvm_invokevirtual "java.lang.Object" "toString" [] t []) + "\n" + (|> t get-stack-trace stack-trace->text))) + ## [Syntax] (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) + (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ (map gen-method-decl members))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] [methods (*^ method-def^)]) - (do Lux/Monad - [current-module get-module-name - #let [fields' (map (: (-> (, (List Text) Text Text) AST) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (text$ name)) - (~ (text$ class)) - [(~@ (map text$ modifiers))]))))) - fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text AST) AST) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (text$ name)) - [(~@ (map (: (-> (, Text Text) AST) - (lambda [in] - (let [[left right] in] - (form$ (@list (symbol$ ["" left]) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) + (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-field-decl fields))] + [(~@ (map gen-method-def methods))]))))) + +(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [methods (*^ method-def^)]) + (emit (@list (` (;_jvm_anon-class (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-method-def methods))]))))) (defsyntax #export (program [args symbol^] body) (emit (@list (` (;_jvm_program (~ (symbol$ args)) @@ -105,24 +209,16 @@ (defsyntax #export (??? expr) (do Lux/Monad - [g!val (gensym "")] - (emit (@list (` (let [(~ g!val) (~ expr)] - (if (;_jvm_null? (~ g!val)) + [g!temp (gensym "")] + (wrap (@list (` (let [(~ g!temp) (~ expr)] + (if (;_jvm_null? (~ g!temp)) #;None - (#;Some (~ g!val))))))))) + (#;Some (~ g!temp))))))))) (defsyntax #export (try expr) (emit (@list (` (;_jvm_try (#;Right (~ expr)) (~ (' (_jvm_catch "java.lang.Exception" e - (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) - -(defsyntax #export (Array [dimensions (?^ int^)] type) - (let [dimensions (? 1 dimensions)] - (if (i:> dimensions 0) - (emit (@list (foldL (lambda [inner _] (` (#;DataT "Array" (@list (~ inner))))) - type - (repeat dimensions [])))) - (fail "Array must have positive dimension.")))) + (#;Left (throwable->text e)))))))))) (defsyntax #export (instance? [class local-symbol^] obj) (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) @@ -142,64 +238,26 @@ (defsyntax #export (null? obj) (emit (@list (` (;_jvm_null? (~ obj)))))) -(def (prepare-args args) - (-> (List (, Bool Text)) (Lux (, (List AST) (List AST) (List AST) (List Text)))) +(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [ex? (tag?^ ["" "!"])]) (do Lux/Monad - [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) - #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) - (lambda [[[opt? arg-class] var]] - (if opt? - [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) - (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) - (case (~ var) - (#;Some (~ var)) (~ var) - #;None ;_jvm_null))))] - [(` (^ (~ (symbol$ ["" arg-class])))) - (@list)]))) - (zip2 args vars)) - var-types (map first pairings) - var-rebinds (map second pairings) - arg-classes (map second args)]] - (wrap [vars var-types (list:join var-rebinds) arg-classes]))) - -(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ opt-arg^))]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args)] - (case vars - (\ (@list)) - (do Lux/Monad - [g!_ (gensym "")] - (wrap (@list (` (: (-> (,) (^ (~ (symbol$ ["" class])))) - (lambda [(~ g!_)] - (;_jvm_new (~ (text$ class)) [] []))))))) - - _ - (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) - (lambda [[(~@ vars)]] - (let [(~@ var-rebinds)] - (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))))))) - ))) + [[vars var-types var-rebinds arg-classes] (prepare-args args) + #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])) + new-expr (if ex? + (` (try (~ new-expr))) + new-expr)]] + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (~ new-expr))))))))) (do-template [<name> <op>] - [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] - [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) + [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] + [expected-output exp-output^]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) g!self (gensym "self") - g!temp (gensym "temp") - #let [return-type (` (^ (~ (symbol$ ["" return])))) - body (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])) - [body return-type] (if opt? - [(` (let [(~ g!temp) (~ body)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))) - (` (Maybe (~ return-type)))] - [body return-type]) - [body return-type] (if ex? - [(` (try (~ body))) - (` (Either Text (~ return-type)))] - [body return-type])]] + #let [[body return-type] (gen-expected-output expected-output + (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])))]] (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) (lambda [[(~@ vars)] (~ g!self)] (let [(~@ var-rebinds)] @@ -210,24 +268,12 @@ [invoke-interface$ ;_jvm_invokeinterface] ) -(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] - [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) +(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] + [expected-output exp-output^]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) - g!temp (gensym "temp") - #let [return-type (` (^ (~ (symbol$ ["" return])))) - body (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])) - [body return-type] (if opt? - [(` (let [(~ g!temp) (~ body)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))) - (` (Maybe (~ return-type)))] - [body return-type]) - [body return-type] (if ex? - [(` (try (~ body))) - (` (Either Text (~ return-type)))] - [body return-type])]] + #let [[body return-type] (gen-expected-output expected-output + (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])))]] (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) (lambda [[(~@ vars)]] (let [(~@ var-rebinds)] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index a28fa6d27..d47780798 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -13,7 +13,7 @@ (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) (list #refer #all #open ("" List/Fold)) - (number (int #open ("i" Int/Eq)) + (number (int #open ("i" Int/Ord)) (real #open ("r" Real/Eq)))))) ## [Utils] @@ -84,6 +84,19 @@ [ tag^ Ident #;TagS] ) +(def #export (assert v tokens) + (-> Bool (Parser (,))) + (if v + (#;Some [tokens []]) + #;None)) + +(def #export nat^ + (Parser Int) + (do Parser/Monad + [n int^ + _ (assert (i>= n 0))] + (wrap n))) + (do-template [<name> <tag>] [(def #export (<name> tokens) (Parser Text) |