aboutsummaryrefslogtreecommitdiff
path: root/source/lux/host/jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux/host/jvm.lux377
1 files changed, 0 insertions, 377 deletions
diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux
deleted file mode 100644
index 737c1731d..000000000
--- a/source/lux/host/jvm.lux
+++ /dev/null
@@ -1,377 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-## If a copy of the MPL was not distributed with this file,
-## You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(;import lux
- (lux (control (monoid #as m)
- (functor #as F)
- (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 Int/Number))
- maybe
- 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 AnnotationParam
- (, Text AST))
-
-(deftype Annotation
- (& #ann-name Text
- #ann-params (List AnnotationParam)))
-
-(deftype MemberDecl
- (& #member-name Text
- #member-modifiers (List Modifier)
- #member-anns (List Annotation)))
-
-(deftype FieldDecl
- JvmType)
-
-(deftype MethodDecl
- (& #method-inputs (List JvmType)
- #method-output JvmType
- #method-exs (List JvmType)))
-
-(deftype ArgDecl
- (& #arg-name Text
- #arg-type JvmType))
-
-(deftype MethodDef
- (& #method-vars (List ArgDecl)
- #return-type JvmType
- #return-body AST
- #throws-exs (List JvmType)))
-
-(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])))
-
-(def (class->type class)
- (-> JvmType AST)
- (case class
- "boolean" (' (;^ java.lang.Boolean))
- "byte" (' (;^ java.lang.Byte))
- "short" (' (;^ java.lang.Short))
- "int" (' (;^ java.lang.Integer))
- "long" (' (;^ java.lang.Long))
- "float" (' (;^ java.lang.Float))
- "double" (' (;^ java.lang.Double))
- "char" (' (;^ java.lang.Character))
- "void" (` ;Unit)
- _
- (` (^ (~ (symbol$ ["" class]))))))
-
-## Parsers
-(def annotation-params^
- (Parser (List AnnotationParam))
- (record^ (*^ (tuple^ (&^ local-tag^ id^)))))
-
-(def annotation^
- (Parser Annotation)
- (form^ (&^ local-symbol^
- annotation-params^)))
-
-(def annotations^'
- (Parser (List Annotation))
- (do Parser/Monad
- [_ (tag!^ ["" "ann"])]
- (tuple^ (*^ annotation^))))
-
-(def annotations^
- (Parser (List Annotation))
- (do Parser/Monad
- [anns?? (?^ annotations^')]
- (wrap (? (@list) anns??))))
-
-(def member-decl^
- (Parser MemberDecl)
- (do Parser/Monad
- [modifiers (*^ local-tag^)
- name local-symbol^
- anns annotations^]
- (wrap [name modifiers anns])))
-
-(def throws-decl'^
- (Parser (List JvmType))
- (do Parser/Monad
- [_ (tag!^ ["" "throws"])]
- (tuple^ (*^ local-symbol^))))
-
-(def throws-decl^
- (Parser (List JvmType))
- (do Parser/Monad
- [exs? (?^ throws-decl'^)]
- (wrap (? (@list) exs?))))
-
-(def method-decl'^
- (Parser MethodDecl)
- (do Parser/Monad
- [inputs (tuple^ (*^ local-symbol^))
- outputs local-symbol^
- exs throws-decl^]
- (wrap [inputs outputs exs])))
-
-(def method-decl^
- (Parser (, MemberDecl MethodDecl))
- (form^ (&^ member-decl^
- method-decl'^)))
-
-(def field-decl^
- (Parser (, MemberDecl FieldDecl))
- (form^ (&^ member-decl^
- local-symbol^)))
-
-(def arg-decl^
- (Parser ArgDecl)
- (form^ (&^ local-symbol^ local-symbol^)))
-
-(def method-def'^
- (Parser MethodDef)
- (do Parser/Monad
- [inputs (tuple^ (*^ arg-decl^))
- output local-symbol^
- exs throws-decl^
- body id^]
- (wrap [inputs output body exs])))
-
-(def method-def^
- (Parser (, MemberDecl MethodDef))
- (form^ (&^ member-decl^
- method-def'^)))
-
-(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-annotation-param [name value])
- (-> AnnotationParam (, AST AST))
- [(text$ name) value])
-
-(def (gen-annotation [name params])
- (-> Annotation AST)
- (` ((~ (text$ name))
- (~ (record$ (map gen-annotation-param params))))))
-
-(def (gen-method-decl [[name modifiers anns] [inputs output exs]])
- (-> (, MemberDecl MethodDecl) AST)
- (` ((~ (text$ name))
- [(~@ (map text$ modifiers))]
- [(~@ (map gen-annotation anns))]
- [(~@ (map text$ exs))]
- [(~@ (map text$ inputs))]
- (~ (text$ output)))))
-
-(def (gen-field-decl [[name modifiers anns] class])
- (-> (, MemberDecl FieldDecl) AST)
- (` ((~ (text$ name))
- [(~@ (map text$ modifiers))]
- [(~@ (map gen-annotation anns))]
- (~ (text$ class))
- )))
-
-(def (gen-arg-decl [name type])
- (-> ArgDecl AST)
- (form$ (@list (symbol$ ["" name]) (text$ type))))
-
-(def (gen-method-def [[name modifiers anns] [inputs output body exs]])
- (-> (, MemberDecl MethodDef) AST)
- (` ((~ (text$ name))
- [(~@ (map text$ modifiers))]
- [(~@ (map gen-annotation anns))]
- [(~@ (map text$ exs))]
- [(~@ (map gen-arg-decl inputs))]
- (~ (text$ output))
- (~ body))))
-
-(def (gen-expected-output [ex? opt? output] body)
- (-> ExpectedOutput AST (, AST AST))
- (let [type (class->type 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 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)
- (-> (^ java.lang.Throwable) Text)
- ($ text:++
- (_jvm_invokevirtual "java.lang.Object" "toString" [] t [])
- "\n"
- (|> t get-stack-trace stack-trace->text)))
-
-## [Syntax]
-(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))]
- [annotations annotations^]
- [fields (*^ field-decl^)]
- [methods (*^ method-def^)])
- (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super))
- [(~@ (map text$ interfaces))]
- [(~@ (map gen-annotation annotations))]
- [(~@ (map gen-field-decl fields))]
- [(~@ (map gen-method-def methods))])))))
-
-(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))]
- [annotations annotations^]
- [members (*^ method-decl^)])
- (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))]
- [(~@ (map gen-annotation annotations))]
- (~@ (map gen-method-decl members)))))))
-
-(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))
- (~ body))))))
-
-(defsyntax #export (??? expr)
- (do Lux/Monad
- [g!temp (gensym "")]
- (wrap (@list (` (let [(~ g!temp) (~ expr)]
- (if (;_jvm_null? (~ g!temp))
- #;None
- (#;Some (~ g!temp)))))))))
-
-(defsyntax #export (try expr)
- (emit (@list (` (;_jvm_try (#;Right (~ expr))
- (~ (' (_jvm_catch "java.lang.Exception" e
- (#;Left (throwable->text e))))))))))
-
-(defsyntax #export (instance? [class local-symbol^] obj)
- (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj))))))
-
-(defsyntax #export (locking lock body)
- (do Lux/Monad
- [g!lock (gensym "")
- g!body (gensym "")
- g!_ (gensym "")]
- (emit (@list (` (let [(~ g!lock) (~ lock)
- (~ g!_) (;_jvm_monitorenter (~ g!lock))
- (~ g!body) (~ body)
- (~ g!_) (;_jvm_monitorexit (~ g!lock))]
- (~ g!body)))))
- ))
-
-(defsyntax #export (null? obj)
- (emit (@list (` (;_jvm_null? (~ obj))))))
-
-(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [unsafe? (tag?^ ["" "unsafe"])])
- (do Lux/Monad
- [[vars var-types var-rebinds arg-classes] (prepare-args args)
- #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))
- return-type (class->type class)
- [new-expr return-type] (if unsafe?
- [(` (try (~ new-expr))) (` (Either Text (~ return-type)))]
- [new-expr return-type])]]
- (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type))
- (lambda [[(~@ vars)]]
- (let [(~@ var-rebinds)]
- (~ new-expr)))))))))
-
-(do-template [<name> <op> <use-self?>]
- [(defsyntax #export (<name> [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))]
- [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])])
- (do Lux/Monad
- [[vars var-types var-rebinds arg-classes] (prepare-args args)
- g!self (gensym "self")
- #let [included-self (: (List AST)
- (if <use-self?>
- (@list g!self)
- (@list)))
- [body return-type] (gen-expected-output expected-output
- (` (<op> (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)])))
- [body return-type] (if unsafe?
- [(` (try (~ body))) (` (Either Text (~ return-type)))]
- [body return-type])]]
- (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type))
- (lambda [[(~@ vars)] (~@ included-self)]
- (let [(~@ var-rebinds)]
- (~ body)))))))
- ))]
-
- [invoke-virtual$ ;_jvm_invokevirtual true]
- [invoke-interface$ ;_jvm_invokeinterface true]
- [invoke-special$ ;_jvm_invokespecial true]
- [invoke-static$ ;_jvm_invokestatic false]
- )
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-29 08:10:18 +0000