aboutsummaryrefslogtreecommitdiff
path: root/source
diff options
context:
space:
mode:
Diffstat (limited to 'source')
-rw-r--r--source/lux/codata/state.lux10
-rw-r--r--source/lux/control/enum.lux2
-rw-r--r--source/lux/data/io.lux5
-rw-r--r--source/lux/data/number/int.lux2
-rw-r--r--source/lux/host/jvm.lux330
-rw-r--r--source/lux/meta/syntax.lux15
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)