(;module: lux (lux (control ["M" monad #+ do Monad] [enum] ["p" parser]) [io #+ IO Monad io] (data (coll [list "L/" Monad Fold Monoid] [array #+ Array]) number maybe [product] [text "Text/" Eq Monoid] text/format [bool "Bool/" Codec]) [macro #+ with-gensyms Functor Monad] (macro [code] ["s" syntax #+ syntax: Syntax]) [type] )) (do-template [ ] [(def: #export ( value) {#;doc (doc "Type converter." "From:" "To:" )} (-> (host ) (host )) (_lux_proc ["jvm" ] [value]))] [b2l "b2l" java.lang.Byte java.lang.Long] [s2l "s2l" java.lang.Short java.lang.Long] [d2i "d2i" java.lang.Double java.lang.Integer] [d2l "d2l" java.lang.Double java.lang.Long] [d2f "d2f" java.lang.Double java.lang.Float] [f2i "f2i" java.lang.Float java.lang.Integer] [f2l "f2l" java.lang.Float java.lang.Long] [f2d "f2d" java.lang.Float java.lang.Double] [i2b "i2b" java.lang.Integer java.lang.Byte] [i2s "i2s" java.lang.Integer java.lang.Short] [i2l "i2l" java.lang.Integer java.lang.Long] [i2f "i2f" java.lang.Integer java.lang.Float] [i2d "i2d" java.lang.Integer java.lang.Double] [i2c "i2c" java.lang.Integer java.lang.Character] [l2b "l2b" java.lang.Long java.lang.Byte] [l2s "l2s" java.lang.Long java.lang.Short] [l2i "l2i" java.lang.Long java.lang.Integer] [l2f "l2f" java.lang.Long java.lang.Float] [l2d "l2d" java.lang.Long java.lang.Double] [c2b "c2b" java.lang.Character java.lang.Byte] [c2s "c2s" java.lang.Character java.lang.Short] [c2i "c2i" java.lang.Character java.lang.Integer] [c2l "c2l" java.lang.Character java.lang.Long] ) ## [Utils] (def: array-type-name "#Array") (def: constructor-method-name "") (def: member-separator ".") ## Types (do-template [ ] [(type: #export (#;Host #;Nil))] ["[Z" Boolean-Array] ["[B" Byte-Array] ["[S" Short-Array] ["[I" Int-Array] ["[J" Long-Array] ["[F" Float-Array] ["[D" Double-Array] ["[C" Char-Array] ) (type: JVM-Code Text) (type: BoundKind #UpperBound #LowerBound) (type: #rec GenericType (#GenericTypeVar Text) (#GenericClass [Text (List GenericType)]) (#GenericArray GenericType) (#GenericWildcard (Maybe [BoundKind GenericType]))) (type: TypeParam [Text (List GenericType)]) (type: Primitive-Mode #ManualPrM #AutoPrM) (type: PrivacyModifier #PublicPM #PrivatePM #ProtectedPM #DefaultPM) (type: StateModifier #VolatileSM #FinalSM #DefaultSM) (type: InheritanceModifier #FinalIM #AbstractIM #DefaultIM) (type: ClassKind #Class #Interface) (type: ClassDecl {#class-name Text #class-params (List TypeParam)}) (type: StackFrame (host java.lang.StackTraceElement)) (type: StackTrace (Array StackFrame)) (type: SuperClassDecl {#super-class-name Text #super-class-params (List GenericType)}) (type: AnnotationParam [Text Code]) (type: Annotation {#ann-name Text #ann-params (List AnnotationParam)}) (type: MemberDecl {#member-name Text #member-privacy PrivacyModifier #member-anns (List Annotation)}) (type: FieldDecl (#ConstantField GenericType Code) (#VariableField StateModifier GenericType)) (type: MethodDecl {#method-tvars (List TypeParam) #method-inputs (List GenericType) #method-output GenericType #method-exs (List GenericType)}) (type: ArgDecl {#arg-name Text #arg-type GenericType}) (type: ConstructorArg [GenericType Code]) (type: MethodDef (#ConstructorMethod [Bool (List TypeParam) (List ArgDecl) (List ConstructorArg) Code (List GenericType)]) (#VirtualMethod [Bool Bool (List TypeParam) (List ArgDecl) GenericType Code (List GenericType)]) (#OverridenMethod [Bool ClassDecl (List TypeParam) (List ArgDecl) GenericType Code (List GenericType)]) (#StaticMethod [Bool (List TypeParam) (List ArgDecl) GenericType Code (List GenericType)]) (#AbstractMethod [(List TypeParam) (List ArgDecl) GenericType (List GenericType)]) (#NativeMethod [(List TypeParam) (List ArgDecl) GenericType (List GenericType)])) (type: PartialCall {#pc-method Code #pc-args Code}) (type: ImportMethodKind #StaticIMK #VirtualIMK) (type: ImportMethodCommons {#import-member-mode Primitive-Mode #import-member-alias Text #import-member-kind ImportMethodKind #import-member-tvars (List TypeParam) #import-member-args (List [Bool GenericType]) #import-member-maybe? Bool #import-member-try? Bool #import-member-io? Bool}) (type: ImportConstructorDecl {}) (type: ImportMethodDecl {#import-method-name Text #import-method-return GenericType}) (type: ImportFieldDecl {#import-field-mode Primitive-Mode #import-field-name Text #import-field-static? Bool #import-field-maybe? Bool #import-field-setter? Bool #import-field-type GenericType}) (type: ImportMemberDecl (#EnumDecl (List Text)) (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) (#MethodDecl [ImportMethodCommons ImportMethodDecl]) (#FieldAccessDecl ImportFieldDecl)) (type: ClassImports (List [Text Text])) ## Utils (def: (short-class-name name) (-> Text Text) (case (list;reverse (text;split-all-with "." name)) (#;Cons short-name _) short-name #;Nil name)) (def: (manual-primitive-to-type class) (-> Text (Maybe Code)) (case class (^template [ ] (#;Some (' ))) (["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]) _ #;None)) (def: (auto-primitive-to-type class) (-> Text (Maybe Code)) (case class (^template [ ] (#;Some (' ))) (["boolean" ;Bool] ["byte" ;Int] ["short" ;Int] ["int" ;Int] ["long" ;Int] ["float" ;Real] ["double" ;Real] ["void" ;Unit]) _ #;None)) (def: (generic-class->type' mode type-params in-array? name+params class->type') (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)] (-> Primitive-Mode (List TypeParam) Bool GenericType Code) Code) (case [name+params mode in-array?] (^multi [[prim #;Nil] #ManualPrM false] [(manual-primitive-to-type prim) (#;Some output)]) output (^multi [[prim #;Nil] #AutoPrM false] [(auto-primitive-to-type prim) (#;Some output)]) output [[name params] _ _] (let [=params (L/map (class->type' mode type-params in-array?) params)] (` (host (~ (code;symbol ["" name])) [(~@ =params)]))))) (def: (class->type' mode type-params in-array? class) (-> Primitive-Mode (List TypeParam) Bool GenericType Code) (case class (#GenericTypeVar name) (case (list;find (function [[pname pbounds]] (and (Text/= name pname) (not (list;empty? pbounds)))) type-params) #;None (code;symbol ["" name]) (#;Some [pname pbounds]) (class->type' mode type-params in-array? (default (undefined) (list;head pbounds)))) (#GenericClass name+params) (generic-class->type' mode type-params in-array? name+params class->type') (#GenericArray param) (let [=param (class->type' mode type-params true param)] (` (host (~ (code;symbol ["" array-type-name])) [(~ =param)]))) (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) (' (;Ex [*] *)) (#GenericWildcard (#;Some [#UpperBound upper-bound])) (class->type' mode type-params in-array? upper-bound) )) (def: (class->type mode type-params class) (-> Primitive-Mode (List TypeParam) GenericType Code) (class->type' mode type-params false class)) (def: (type-param-type$ [name bounds]) (-> TypeParam Code) (code;symbol ["" name])) (def: (class-decl-type$ (^slots [#class-name #class-params])) (-> ClassDecl Code) (let [=params (L/map (: (-> TypeParam Code) (function [[pname pbounds]] (case pbounds #;Nil (code;symbol ["" pname]) (#;Cons bound1 _) (class->type #ManualPrM class-params bound1)))) class-params)] (` (host (~ (code;symbol ["" class-name])) [(~@ =params)])))) (def: empty-imports ClassImports (list)) (def: (get-import name imports) (-> Text ClassImports (Maybe Text)) (:: Functor map product;right (list;find (|>. product;left (Text/= name)) imports))) (def: (add-import short+full imports) (-> [Text Text] ClassImports ClassImports) (#;Cons short+full imports)) (def: (class-imports compiler) (-> Compiler ClassImports) (case (macro;run compiler (: (Lux ClassImports) (do Monad [current-module macro;current-module-name defs (macro;defs current-module)] (wrap (L/fold (: (-> [Text Def] ClassImports ClassImports) (function [[short-name [_ meta _]] imports] (case (macro;get-text-ann (ident-for #;;jvm-class) meta) (#;Some full-class-name) (add-import [short-name full-class-name] imports) _ imports))) empty-imports defs))))) (#;Left _) (list) (#;Right imports) imports)) (def: java.lang-classes (List Text) (list ## Interfaces "Appendable" "AutoCloseable" "CharSequence" "Cloneable" "Comparable" "Iterable" "Readable" "Runnable" ## Classes "Boolean" "Byte" "Character" "Class" "ClassLoader" "ClassValue" "Compiler" "Double" "Enum" "Float" "InheritableThreadLocal" "Integer" "Long" "Math" "Number" "Object" "Package" "Process" "ProcessBuilder" "Runtime" "RuntimePermission" "SecurityManager" "Short" "StackTraceElement" "StrictMath" "String" "StringBuffer" "StringBuilder" "System" "Thread" "ThreadGroup" "ThreadLocal" "Throwable" "Void" ## Exceptions "ArithmeticException" "ArrayIndexOutOfBoundsException" "ArrayStoreException" "ClassCastException" "ClassNotFoundException" "CloneNotSupportedException" "EnumConstantNotPresentException" "Exception" "IllegalAccessException" "IllegalArgumentException" "IllegalMonitorStateException" "IllegalStateException" "IllegalThreadStateException" "IndexOutOfBoundsException" "InstantiationException" "InterruptedException" "NegativeArraySizeException" "NoSuchFieldException" "NoSuchMethodException" "NullPointerException" "NumberFormatException" "ReflectiveOperationException" "RuntimeException" "SecurityException" "StringIndexOutOfBoundsException" "TypeNotPresentException" "UnsupportedOperationException" ## Annotations "Deprecated" "Override" "SafeVarargs" "SuppressWarnings")) (def: (fully-qualified-class-name? name) (-> Text Bool) (text;contains? "." name)) (def: (fully-qualify-class-name imports name) (-> ClassImports Text Text) (cond (fully-qualified-class-name? name) name (list;member? text;Eq java.lang-classes name) (format "java.lang." name) ## else (default name (get-import name imports)))) (def: type-var-class Text "java.lang.Object") (def: (simple-class$ params class) (-> (List TypeParam) GenericType Text) (case class (#GenericTypeVar name) (case (list;find (function [[pname pbounds]] (and (Text/= name pname) (not (list;empty? pbounds)))) params) #;None type-var-class (#;Some [pname pbounds]) (simple-class$ params (default (undefined) (list;head pbounds)))) (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) type-var-class (#GenericWildcard (#;Some [#UpperBound upper-bound])) (simple-class$ params upper-bound) (#GenericClass name params) name (#GenericArray param') (case param' (#GenericArray param) (format "[" (simple-class$ params param)) (^template [ ] (#GenericClass #;Nil) ) (["boolean" "[Z"] ["byte" "[B"] ["short" "[S"] ["int" "[I"] ["long" "[J"] ["float" "[F"] ["double" "[D"] ["char" "[C"]) param (format "[L" (simple-class$ params param) ";")) )) (def: (make-get-const-parser class-name field-name) (-> Text Text (Syntax Code)) (do p;Monad [#let [dotted-name (format "." field-name)] _ (s;this (code;symbol ["" dotted-name]))] (wrap (`' (_lux_proc ["jvm" (~ (code;text (format "getstatic" ":" class-name ":" field-name)))] []))))) (def: (make-get-var-parser class-name field-name) (-> Text Text (Syntax Code)) (do p;Monad [#let [dotted-name (format "." field-name)] _ (s;this (code;symbol ["" dotted-name]))] (wrap (`' (_lux_proc ["jvm" (~ (code;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this]))))) (def: (make-put-var-parser class-name field-name) (-> Text Text (Syntax Code)) (do p;Monad [#let [dotted-name (format "." field-name)] [_ _ value] (: (Syntax [Unit Unit Code]) (s;form ($_ p;seq (s;this (' :=)) (s;this (code;symbol ["" dotted-name])) s;any)))] (wrap (`' (_lux_proc ["jvm" (~ (code;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)]))))) (def: (pre-walk-replace f input) (-> (-> Code Code) Code Code) (case (f input) (^template [] [meta ( parts)] [meta ( (L/map (pre-walk-replace f) parts))]) ([#;Form] [#;Tuple]) [meta (#;Record pairs)] [meta (#;Record (L/map (: (-> [Code Code] [Code Code]) (function [[key val]] [(pre-walk-replace f key) (pre-walk-replace f val)])) pairs))] ast' ast')) (def: (parser->replacer p ast) (-> (Syntax Code) (-> Code Code)) (case (p;run (list ast) p) (#;Right [#;Nil ast']) ast' _ ast )) (def: (field->parser class-name [[field-name _ _] field]) (-> Text [MemberDecl FieldDecl] (Syntax Code)) (case field (#ConstantField _) (make-get-const-parser class-name field-name) (#VariableField _) (p;either (make-get-var-parser class-name field-name) (make-put-var-parser class-name field-name)))) (def: (make-constructor-parser params class-name arg-decls) (-> (List TypeParam) Text (List ArgDecl) (Syntax Code)) (do p;Monad [[_ args] (: (Syntax [Unit (List Code)]) (s;form ($_ p;seq (s;this (' .new!)) (s;tuple (p;exactly (list;size arg-decls) s;any))))) #let [arg-decls' (: (List Text) (L/map (. (simple-class$ params) product;right) arg-decls))]] (wrap (` (;_lux_proc ["jvm" (~ (code;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))] [(~@ args)]))))) (def: (make-static-method-parser params class-name method-name arg-decls) (-> (List TypeParam) Text Text (List ArgDecl) (Syntax Code)) (do p;Monad [#let [dotted-name (format "." method-name "!")] [_ args] (: (Syntax [Unit (List Code)]) (s;form ($_ p;seq (s;this (code;symbol ["" dotted-name])) (s;tuple (p;exactly (list;size arg-decls) s;any))))) #let [arg-decls' (: (List Text) (L/map (. (simple-class$ params) product;right) arg-decls))]] (wrap (`' (;_lux_proc ["jvm" (~ (code;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] [(~@ args)]))))) (do-template [ ] [(def: ( params class-name method-name arg-decls) (-> (List TypeParam) Text Text (List ArgDecl) (Syntax Code)) (do p;Monad [#let [dotted-name (format "." method-name "!")] [_ args] (: (Syntax [Unit (List Code)]) (s;form ($_ p;seq (s;this (code;symbol ["" dotted-name])) (s;tuple (p;exactly (list;size arg-decls) s;any))))) #let [arg-decls' (: (List Text) (L/map (. (simple-class$ params) product;right) arg-decls))]] (wrap (`' (;_lux_proc ["jvm" (~ (code;text (format ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] [(~' _jvm_this) (~@ args)])))))] [make-special-method-parser "invokespecial"] [make-virtual-method-parser "invokevirtual"] ) (def: (method->parser params class-name [[method-name _ _] meth-def]) (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax Code)) (case meth-def (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) (make-constructor-parser params class-name args) (#StaticMethod strict? type-vars args return-type return-expr exs) (make-static-method-parser params class-name method-name args) (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs)) (make-special-method-parser params class-name method-name args) (#AbstractMethod type-vars args return-type exs) (make-virtual-method-parser params class-name method-name args) (#NativeMethod type-vars args return-type exs) (make-virtual-method-parser params class-name method-name args))) ## Syntaxs (def: (full-class-name^ imports) (-> ClassImports (Syntax Text)) (do p;Monad [name s;local-symbol] (wrap (fully-qualify-class-name imports name)))) (def: privacy-modifier^ (Syntax PrivacyModifier) (let [(^open) p;Monad] ($_ p;alt (s;this (' #public)) (s;this (' #private)) (s;this (' #protected)) (wrap [])))) (def: inheritance-modifier^ (Syntax InheritanceModifier) (let [(^open) p;Monad] ($_ p;alt (s;this (' #final)) (s;this (' #abstract)) (wrap [])))) (def: bound-kind^ (Syntax BoundKind) (p;alt (s;this (' <)) (s;this (' >)))) (def: (generic-type^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax GenericType)) ($_ p;either (do p;Monad [_ (s;this (' ?))] (wrap (#GenericWildcard #;None))) (s;tuple (do p;Monad [_ (s;this (' ?)) bound-kind bound-kind^ bound (generic-type^ imports type-vars)] (wrap (#GenericWildcard (#;Some [bound-kind bound]))))) (do p;Monad [name (full-class-name^ imports)] (with-expansions [ (do-template [ ] [(Text/= name) (wrap (#GenericClass (list)))] ["[Z" "Boolean-Array"] ["[B" "Byte-Array"] ["[S" "Short-Array"] ["[I" "Int-Array"] ["[J" "Long-Array"] ["[F" "Float-Array"] ["[D" "Double-Array"] ["[C" "Char-Array"])] (cond (list;member? text;Eq (L/map product;left type-vars) name) (wrap (#GenericTypeVar name)) ## else (wrap (#GenericClass name (list)))))) (s;form (do p;Monad [name (s;this (' Array)) component (generic-type^ imports type-vars)] (case component (^template [ ] (#GenericClass #;Nil) (wrap (#GenericClass (list)))) (["[Z" "boolean"] ["[B" "byte"] ["[S" "short"] ["[I" "int"] ["[J" "long"] ["[F" "float"] ["[D" "double"] ["[C" "char"]) _ (wrap (#GenericArray component))))) (s;form (do p;Monad [name (full-class-name^ imports) params (p;some (generic-type^ imports type-vars)) _ (p;assert (format name " cannot be a type-parameter!") (not (list;member? text;Eq (L/map product;left type-vars) name)))] (wrap (#GenericClass name params)))) )) (def: (type-param^ imports) (-> ClassImports (Syntax TypeParam)) (p;either (do p;Monad [param-name s;local-symbol] (wrap [param-name (list)])) (s;tuple (do p;Monad [param-name s;local-symbol _ (s;this (' <)) bounds (p;many (generic-type^ imports (list)))] (wrap [param-name bounds]))))) (def: (type-params^ imports) (-> ClassImports (Syntax (List TypeParam))) (s;tuple (p;some (type-param^ imports)))) (def: (class-decl^ imports) (-> ClassImports (Syntax ClassDecl)) (p;either (do p;Monad [name (full-class-name^ imports)] (wrap [name (list)])) (s;form (do p;Monad [name (full-class-name^ imports) params (p;some (type-param^ imports))] (wrap [name params]))) )) (def: (super-class-decl^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax SuperClassDecl)) (p;either (do p;Monad [name (full-class-name^ imports)] (wrap [name (list)])) (s;form (do p;Monad [name (full-class-name^ imports) params (p;some (generic-type^ imports type-vars))] (wrap [name params]))))) (def: annotation-params^ (Syntax (List AnnotationParam)) (s;record (p;some (p;seq s;local-tag s;any)))) (def: (annotation^ imports) (-> ClassImports (Syntax Annotation)) (p;either (do p;Monad [ann-name (full-class-name^ imports)] (wrap [ann-name (list)])) (s;form (p;seq (full-class-name^ imports) annotation-params^)))) (def: (annotations^' imports) (-> ClassImports (Syntax (List Annotation))) (do p;Monad [_ (s;this (' #ann))] (s;tuple (p;some (annotation^ imports))))) (def: (annotations^ imports) (-> ClassImports (Syntax (List Annotation))) (do p;Monad [anns?? (p;opt (annotations^' imports))] (wrap (default (list) anns??)))) (def: (throws-decl'^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax (List GenericType))) (do p;Monad [_ (s;this (' #throws))] (s;tuple (p;some (generic-type^ imports type-vars))))) (def: (throws-decl^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax (List GenericType))) (do p;Monad [exs? (p;opt (throws-decl'^ imports type-vars))] (wrap (default (list) exs?)))) (def: (method-decl^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl])) (s;form (do p;Monad [tvars (p;default (list) (type-params^ imports)) name s;local-symbol anns (annotations^ imports) inputs (s;tuple (p;some (generic-type^ imports type-vars))) output (generic-type^ imports type-vars) exs (throws-decl^ imports type-vars)] (wrap [[name #PublicPM anns] {#method-tvars tvars #method-inputs inputs #method-output output #method-exs exs}])))) (def: state-modifier^ (Syntax StateModifier) ($_ p;alt (s;this (' #volatile)) (s;this (' #final)) (:: p;Monad wrap []))) (def: (field-decl^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl])) (p;either (s;form (do p;Monad [_ (s;this (' #const)) name s;local-symbol anns (annotations^ imports) type (generic-type^ imports type-vars) body s;any] (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) (s;form (do p;Monad [pm privacy-modifier^ sm state-modifier^ name s;local-symbol anns (annotations^ imports) type (generic-type^ imports type-vars)] (wrap [[name pm anns] (#VariableField [sm type])]))))) (def: (arg-decl^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax ArgDecl)) (s;tuple (p;seq s;local-symbol (generic-type^ imports type-vars)))) (def: (arg-decls^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax (List ArgDecl))) (p;some (arg-decl^ imports type-vars))) (def: (constructor-arg^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax ConstructorArg)) (s;tuple (p;seq (generic-type^ imports type-vars) s;any))) (def: (constructor-args^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg))) (s;tuple (p;some (constructor-arg^ imports type-vars)))) (def: (constructor-method^ imports class-vars) (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) (s;form (do p;Monad [pm privacy-modifier^ strict-fp? (s;this? (' #strict)) method-vars (p;default (list) (type-params^ imports)) #let [total-vars (L/append class-vars method-vars)] [_ arg-decls] (s;form (p;seq (s;this (' new)) (arg-decls^ imports total-vars))) constructor-args (constructor-args^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) body s;any] (wrap [{#member-name constructor-method-name #member-privacy pm #member-anns annotations} (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) (def: (virtual-method-def^ imports class-vars) (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) (s;form (do p;Monad [pm privacy-modifier^ strict-fp? (s;this? (' #strict)) final? (s;this? (' #final)) method-vars (p;default (list) (type-params^ imports)) #let [total-vars (L/append class-vars method-vars)] [name arg-decls] (s;form (p;seq s;local-symbol (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) body s;any] (wrap [{#member-name name #member-privacy pm #member-anns annotations} (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) (def: (overriden-method-def^ imports) (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do p;Monad [strict-fp? (s;this? (' #strict)) owner-class (class-decl^ imports) method-vars (p;default (list) (type-params^ imports)) #let [total-vars (L/append (product;right owner-class) method-vars)] [name arg-decls] (s;form (p;seq s;local-symbol (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) body s;any] (wrap [{#member-name name #member-privacy #PublicPM #member-anns annotations} (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) (def: (static-method-def^ imports) (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do p;Monad [pm privacy-modifier^ strict-fp? (s;this? (' #strict)) _ (s;this (' #static)) method-vars (p;default (list) (type-params^ imports)) #let [total-vars method-vars] [name arg-decls] (s;form (p;seq s;local-symbol (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) body s;any] (wrap [{#member-name name #member-privacy pm #member-anns annotations} (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) (def: (abstract-method-def^ imports) (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do p;Monad [pm privacy-modifier^ _ (s;this (' #abstract)) method-vars (p;default (list) (type-params^ imports)) #let [total-vars method-vars] [name arg-decls] (s;form (p;seq s;local-symbol (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports)] (wrap [{#member-name name #member-privacy pm #member-anns annotations} (#AbstractMethod method-vars arg-decls return-type exs)])))) (def: (native-method-def^ imports) (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do p;Monad [pm privacy-modifier^ _ (s;this (' #native)) method-vars (p;default (list) (type-params^ imports)) #let [total-vars method-vars] [name arg-decls] (s;form (p;seq s;local-symbol (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports)] (wrap [{#member-name name #member-privacy pm #member-anns annotations} (#NativeMethod method-vars arg-decls return-type exs)])))) (def: (method-def^ imports class-vars) (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) ($_ p;either (constructor-method^ imports class-vars) (virtual-method-def^ imports class-vars) (overriden-method-def^ imports) (static-method-def^ imports) (abstract-method-def^ imports) (native-method-def^ imports))) (def: partial-call^ (Syntax PartialCall) (s;form (p;seq s;any s;any))) (def: class-kind^ (Syntax ClassKind) (p;either (do p;Monad [_ (s;this (' #class))] (wrap #Class)) (do p;Monad [_ (s;this (' #interface))] (wrap #Interface)) )) (def: import-member-alias^ (Syntax (Maybe Text)) (p;opt (do p;Monad [_ (s;this (' #as))] s;local-symbol))) (def: (import-member-args^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType]))) (s;tuple (p;some (p;seq (s;this? (' #?)) (generic-type^ imports type-vars))))) (def: import-member-return-flags^ (Syntax [Bool Bool Bool]) ($_ p;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?)))) (def: primitive-mode^ (Syntax Primitive-Mode) (p;alt (s;this (' #manual)) (s;this (' #auto)))) (def: (import-member-decl^ imports owner-vars) (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl)) ($_ p;either (s;form (do p;Monad [_ (s;this (' #enum)) enum-members (p;some s;local-symbol)] (wrap (#EnumDecl enum-members)))) (s;form (do p;Monad [tvars (p;default (list) (type-params^ imports)) _ (s;this (' new)) ?alias import-member-alias^ #let [total-vars (L/append owner-vars tvars)] ?prim-mode (p;opt primitive-mode^) args (import-member-args^ imports total-vars) [io? try? maybe?] import-member-return-flags^] (wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode) #import-member-alias (default "new" ?alias) #import-member-kind #VirtualIMK #import-member-tvars tvars #import-member-args args #import-member-maybe? maybe? #import-member-try? try? #import-member-io? io?} {}])) )) (s;form (do p;Monad [kind (: (Syntax ImportMethodKind) (p;alt (s;this (' #static)) (wrap []))) tvars (p;default (list) (type-params^ imports)) name s;local-symbol ?alias import-member-alias^ #let [total-vars (L/append owner-vars tvars)] ?prim-mode (p;opt primitive-mode^) args (import-member-args^ imports total-vars) [io? try? maybe?] import-member-return-flags^ return (generic-type^ imports total-vars)] (wrap (#MethodDecl [{#import-member-mode (default #AutoPrM ?prim-mode) #import-member-alias (default name ?alias) #import-member-kind kind #import-member-tvars tvars #import-member-args args #import-member-maybe? maybe? #import-member-try? try? #import-member-io? io?} {#import-method-name name #import-method-return return }])))) (s;form (do p;Monad [static? (s;this? (' #static)) name s;local-symbol ?prim-mode (p;opt primitive-mode^) gtype (generic-type^ imports owner-vars) maybe? (s;this? (' #?)) setter? (s;this? (' #!))] (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode) #import-field-name name #import-field-static? static? #import-field-maybe? maybe? #import-field-setter? setter? #import-field-type gtype})))) )) ## Generators (def: with-parens (-> JVM-Code JVM-Code) (text;enclose ["(" ")"])) (def: with-brackets (-> JVM-Code JVM-Code) (text;enclose ["[" "]"])) (def: spaced (-> (List JVM-Code) JVM-Code) (text;join-with " ")) (def: (privacy-modifier$ pm) (-> PrivacyModifier JVM-Code) (case pm #PublicPM "public" #PrivatePM "private" #ProtectedPM "protected" #DefaultPM "default")) (def: (inheritance-modifier$ im) (-> InheritanceModifier JVM-Code) (case im #FinalIM "final" #AbstractIM "abstract" #DefaultIM "default")) (def: (annotation-param$ [name value]) (-> AnnotationParam JVM-Code) (format name "=" (code;to-text value))) (def: (annotation$ [name params]) (-> Annotation JVM-Code) (format "(" name " " "{" (text;join-with "\t" (L/map annotation-param$ params)) "}" ")")) (def: (bound-kind$ kind) (-> BoundKind JVM-Code) (case kind #UpperBound "<" #LowerBound ">")) (def: (generic-type$ gtype) (-> GenericType JVM-Code) (case gtype (#GenericTypeVar name) name (#GenericClass name params) (format "(" name " " (spaced (L/map generic-type$ params)) ")") (#GenericArray param) (format "(" array-type-name " " (generic-type$ param) ")") (#GenericWildcard #;None) "?" (#GenericWildcard (#;Some [bound-kind bound])) (format (bound-kind$ bound-kind) (generic-type$ bound)))) (def: (type-param$ [name bounds]) (-> TypeParam JVM-Code) (format "(" name " " (spaced (L/map generic-type$ bounds)) ")")) (def: (class-decl$ (^open)) (-> ClassDecl JVM-Code) (format "(" class-name " " (spaced (L/map type-param$ class-params)) ")")) (def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) (-> SuperClassDecl JVM-Code) (format "(" super-class-name " " (spaced (L/map generic-type$ super-class-params)) ")")) (def: (method-decl$ [[name pm anns] method-decl]) (-> [MemberDecl MethodDecl] JVM-Code) (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] (with-parens (spaced (list name (with-brackets (spaced (L/map annotation$ anns))) (with-brackets (spaced (L/map type-param$ method-tvars))) (with-brackets (spaced (L/map generic-type$ method-exs))) (with-brackets (spaced (L/map generic-type$ method-inputs))) (generic-type$ method-output)) )))) (def: (state-modifier$ sm) (-> StateModifier JVM-Code) (case sm #VolatileSM "volatile" #FinalSM "final" #DefaultSM "default")) (def: (field-decl$ [[name pm anns] field]) (-> [MemberDecl FieldDecl] JVM-Code) (case field (#ConstantField class value) (with-parens (spaced (list "constant" name (with-brackets (spaced (L/map annotation$ anns))) (generic-type$ class) (code;to-text value)) )) (#VariableField sm class) (with-parens (spaced (list "variable" name (privacy-modifier$ pm) (state-modifier$ sm) (with-brackets (spaced (L/map annotation$ anns))) (generic-type$ class)) )) )) (def: (arg-decl$ [name type]) (-> ArgDecl JVM-Code) (with-parens (spaced (list name (generic-type$ type))))) (def: (constructor-arg$ [class term]) (-> ConstructorArg JVM-Code) (with-brackets (spaced (list (generic-type$ class) (code;to-text term))))) (def: (method-def$ replacer super-class [[name pm anns] method-def]) (-> (-> Code Code) SuperClassDecl [MemberDecl MethodDef] JVM-Code) (case method-def (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) (with-parens (spaced (list "init" (privacy-modifier$ pm) (Bool/encode strict-fp?) (with-brackets (spaced (L/map annotation$ anns))) (with-brackets (spaced (L/map type-param$ type-vars))) (with-brackets (spaced (L/map generic-type$ exs))) (with-brackets (spaced (L/map arg-decl$ arg-decls))) (with-brackets (spaced (L/map constructor-arg$ constructor-args))) (code;to-text (pre-walk-replace replacer body)) ))) (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs) (with-parens (spaced (list "virtual" name (privacy-modifier$ pm) (Bool/encode final?) (Bool/encode strict-fp?) (with-brackets (spaced (L/map annotation$ anns))) (with-brackets (spaced (L/map type-param$ type-vars))) (with-brackets (spaced (L/map generic-type$ exs))) (with-brackets (spaced (L/map arg-decl$ arg-decls))) (generic-type$ return-type) (code;to-text (pre-walk-replace replacer body))))) (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) (let [super-replacer (parser->replacer (s;form (do p;Monad [_ (s;this (' .super!)) args (s;tuple (p;exactly (list;size arg-decls) s;any)) #let [arg-decls' (: (List Text) (L/map (. (simple-class$ (list)) product;right) arg-decls))]] (wrap (`' (;_lux_proc ["jvm" (~ (code;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))] [(~' _jvm_this) (~@ args)]))))))] (with-parens (spaced (list "override" (class-decl$ class-decl) name (Bool/encode strict-fp?) (with-brackets (spaced (L/map annotation$ anns))) (with-brackets (spaced (L/map type-param$ type-vars))) (with-brackets (spaced (L/map generic-type$ exs))) (with-brackets (spaced (L/map arg-decl$ arg-decls))) (generic-type$ return-type) (|> body (pre-walk-replace replacer) (pre-walk-replace super-replacer) (code;to-text)) )))) (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) (with-parens (spaced (list "static" name (privacy-modifier$ pm) (Bool/encode strict-fp?) (with-brackets (spaced (L/map annotation$ anns))) (with-brackets (spaced (L/map type-param$ type-vars))) (with-brackets (spaced (L/map generic-type$ exs))) (with-brackets (spaced (L/map arg-decl$ arg-decls))) (generic-type$ return-type) (code;to-text (pre-walk-replace replacer body))))) (#AbstractMethod type-vars arg-decls return-type exs) (with-parens (spaced (list "abstract" name (privacy-modifier$ pm) (with-brackets (spaced (L/map annotation$ anns))) (with-brackets (spaced (L/map type-param$ type-vars))) (with-brackets (spaced (L/map generic-type$ exs))) (with-brackets (spaced (L/map arg-decl$ arg-decls))) (generic-type$ return-type)))) (#NativeMethod type-vars arg-decls return-type exs) (with-parens (spaced (list "native" name (privacy-modifier$ pm) (with-brackets (spaced (L/map annotation$ anns))) (with-brackets (spaced (L/map type-param$ type-vars))) (with-brackets (spaced (L/map generic-type$ exs))) (with-brackets (spaced (L/map arg-decl$ arg-decls))) (generic-type$ return-type)))) )) (def: (complete-call$ obj [method args]) (-> Code PartialCall Code) (` ((~ method) (~ args) (~ obj)))) ## [Syntax] (def: object-super-class SuperClassDecl {#super-class-name "java.lang.Object" #super-class-params (list)}) (syntax: #export (class: [#let [imports (class-imports *compiler*)]] [im inheritance-modifier^] [class-decl (class-decl^ imports)] [#let [full-class-name (product;left class-decl) imports (add-import [(short-class-name full-class-name) full-class-name] (class-imports *compiler*))]] [#let [class-vars (product;right class-decl)]] [super (p;default object-super-class (super-class-decl^ imports class-vars))] [interfaces (p;default (list) (s;tuple (p;some (super-class-decl^ imports class-vars))))] [annotations (annotations^ imports)] [fields (p;some (field-decl^ imports class-vars))] [methods (p;some (method-def^ imports class-vars))]) {#;doc (doc "Allows defining JVM classes in Lux code." "For example:" (class: #final (JvmPromise A) [] ## Fields (#private resolved boolean) (#private datum A) (#private waitingList (java.util.List lux.Function)) ## Methods (#public [] new [] [] (exec (:= .resolved false) (:= .waitingList (ArrayList.new [])) [])) (#public [] resolve [{value A}] boolean (let [container (.new! [])] (synchronized _jvm_this (if .resolved false (exec (:= .datum value) (:= .resolved true) (let [sleepers .waitingList sleepers-count (java.util.List.size [] sleepers)] (L/map (function [idx] (let [sleeper (java.util.List.get [(l2i idx)] sleepers)] (Executor.execute [(runnable (lux.Function.apply [(:! Object value)] sleeper))] executor))) (i.range 0 (i.dec (i2l sleepers-count))))) (:= .waitingList (null)) true))))) (#public [] poll [] A .datum) (#public [] wasResolved [] boolean (synchronized _jvm_this .resolved)) (#public [] waitOn [{callback lux.Function}] void (synchronized _jvm_this (exec (if .resolved (lux.Function.apply [(:! Object .datum)] callback) (:! Object (java.util.List.add [callback] .waitingList))) []))) (#public #static [A] make [{value A}] (lux.concurrency.promise.JvmPromise A) (let [container (.new! [])] (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)]) container)))) "The vector corresponds to parent interfaces." "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed." "Fields and methods defined in the class can be used with special syntax." "For example:" ".resolved, for accessing the \"resolved\" field." "(:= .resolved true) for modifying it." "(.new! []) for calling the class's constructor." "(.resolve! container [value]) for calling the \"resolve\" method." )} (do Monad [current-module macro;current-module-name #let [fully-qualified-class-name (format (text;replace-all "/" "." current-module) "." full-class-name) field-parsers (L/map (field->parser fully-qualified-class-name) fields) method-parsers (L/map (method->parser (product;right class-decl) fully-qualified-class-name) methods) replacer (parser->replacer (L/fold p;either (p;fail "") (L/append field-parsers method-parsers))) def-code (format "class:" (spaced (list (class-decl$ class-decl) (super-class-decl$ super) (with-brackets (spaced (L/map super-class-decl$ interfaces))) (inheritance-modifier$ im) (with-brackets (spaced (L/map annotation$ annotations))) (with-brackets (spaced (L/map field-decl$ fields))) (with-brackets (spaced (L/map (method-def$ replacer super) methods))))))]] (wrap (list (` (;_lux_proc ["jvm" (~ (code;text def-code))] [])))))) (syntax: #export (interface: [#let [imports (class-imports *compiler*)]] [class-decl (class-decl^ imports)] [#let [full-class-name (product;left class-decl) imports (add-import [(short-class-name full-class-name) full-class-name] (class-imports *compiler*))]] [#let [class-vars (product;right class-decl)]] [supers (p;default (list) (s;tuple (p;some (super-class-decl^ imports class-vars))))] [annotations (annotations^ imports)] [members (p;some (method-decl^ imports class-vars))]) {#;doc (doc "Allows defining JVM interfaces." (interface: TestInterface ([] foo [boolean String] void #throws [Exception])))} (let [def-code (format "interface:" (spaced (list (class-decl$ class-decl) (with-brackets (spaced (L/map super-class-decl$ supers))) (with-brackets (spaced (L/map annotation$ annotations))) (spaced (L/map method-decl$ members)))))] (wrap (list (` (;_lux_proc ["jvm" (~ (code;text def-code))] [])))) )) (syntax: #export (object [#let [imports (class-imports *compiler*)]] [#let [class-vars (list)]] [super (p;default object-super-class (super-class-decl^ imports class-vars))] [interfaces (p;default (list) (s;tuple (p;some (super-class-decl^ imports class-vars))))] [constructor-args (constructor-args^ imports class-vars)] [methods (p;some (overriden-method-def^ imports))]) {#;doc (doc "Allows defining anonymous classes." "The 1st vector corresponds to parent interfaces." "The 2nd vector corresponds to arguments to the super class constructor." "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed." (object [java.lang.Runnable] [] (java.lang.Runnable (run) void (exec (do-something some-input) []))) )} (let [def-code (format "anon-class:" (spaced (list (super-class-decl$ super) (with-brackets (spaced (L/map super-class-decl$ interfaces))) (with-brackets (spaced (L/map constructor-arg$ constructor-args))) (with-brackets (spaced (L/map (method-def$ id super) methods))))))] (wrap (list (` (;_lux_proc ["jvm" (~ (code;text def-code))] [])))))) (syntax: #export (null) {#;doc (doc "Null object reference." (null))} (wrap (list (` (;_lux_proc ["jvm" "null"] []))))) (def: #export (null? obj) {#;doc (doc "Test for null object reference." (null? (null)) "=>" true (null? "YOLO") "=>" false)} (-> (host java.lang.Object) Bool) (;_lux_proc ["jvm" "null?"] [obj])) (syntax: #export (??? expr) {#;doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." (??? (: java.lang.String (null))) "=>" #;None (??? "YOLO") "=>" (#;Some "YOLO"))} (with-gensyms [g!temp] (wrap (list (` (let [(~ g!temp) (~ expr)] (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)]) #;None (#;Some (~ g!temp))))))))) (syntax: #export (!!! expr) {#;doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." "A #;None would get translated into a (null)." (!!! (??? (: java.lang.Thread (null)))) "=>" (null) (!!! (??? "YOLO")) "=>" "YOLO")} (with-gensyms [g!value] (wrap (list (` (;_lux_case (~ expr) (#;Some (~ g!value)) (~ g!value) #;None (;_lux_proc ["jvm" "null"] []))))))) (syntax: #export (try expr) {#;doc (doc "Covers the expression in a try-catch block." "If it succeeds, you get (#;Right result)." "If it fails, you get (#;Left error+stack-traces-as-text)." (try (risky-computation input)))} (with-gensyms [g!_] (wrap (list (`' (_lux_proc ["lux" "try"] [(function [(~ g!_)] (~ expr))])))))) (syntax: #export (instance? [#let [imports (class-imports *compiler*)]] [class (generic-type^ imports (list))] [obj (p;opt s;any)]) {#;doc (doc "Checks whether an object is an instance of a particular class." "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes." (instance? String "YOLO"))} (case obj (#;Some obj) (wrap (list (` (;_lux_proc ["jvm" (~ (code;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))) #;None (do @ [g!obj (macro;gensym "obj")] (wrap (list (` (: (-> (host (~' java.lang.Object)) Bool) (function [(~ g!obj)] (;_lux_proc ["jvm" (~ (code;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ g!obj)]))))))) )) (syntax: #export (synchronized lock body) {#;doc (doc "Evaluates body, while holding a lock on a given object." (synchronized object-to-be-locked (exec (do-something ...) (do-something-else ...) (finish-the-computation ...))))} (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))) (syntax: #export (do-to obj [methods (p;some partial-call^)]) {#;doc (doc "Call a variety of methods on an object; then return the object." (do-to vreq (HttpServerRequest.setExpectMultipart [true]) (ReadStream.handler [(object [(Handler Buffer)] [] ((Handler A) (handle [buffer A]) void (io;run (do Monad [_ (write (Buffer.getBytes [] buffer) body)] (wrap [])))) )]) (ReadStream.endHandler [[(object [(Handler Void)] [] ((Handler A) (handle [_ A]) void (exec (do Monad [#let [_ (io;run (close body))] response (handler (request$ vreq body))] (respond! response vreq)) [])) )]])))} (with-gensyms [g!obj] (wrap (list (` (let [(~ g!obj) (~ obj)] (exec (~@ (L/map (complete-call$ g!obj) methods)) (~ g!obj)))))))) (def: (class-import$ long-name? [full-name params]) (-> Bool ClassDecl Code) (let [def-name (if long-name? full-name (short-class-name full-name))] (case params #;Nil (` (def: (~ (code;symbol ["" def-name])) {#;type? true #;;jvm-class (~ (code;text full-name))} Type (host (~ (code;symbol ["" full-name]))))) (#;Cons _) (let [params' (L/map (function [[p _]] (code;symbol ["" p])) params)] (` (def: (~ (code;symbol ["" def-name])) {#;type? true #;;jvm-class (~ (code;text full-name))} Type (All [(~@ params')] (host (~ (code;symbol ["" full-name])) [(~@ params')])))))))) (def: (member-type-vars class-tvars member) (-> (List TypeParam) ImportMemberDecl (List TypeParam)) (case member (#ConstructorDecl [commons _]) (L/append class-tvars (get@ #import-member-tvars commons)) (#MethodDecl [commons _]) (case (get@ #import-member-kind commons) #StaticIMK (get@ #import-member-tvars commons) _ (L/append class-tvars (get@ #import-member-tvars commons))) _ class-tvars)) (def: (member-def-arg-bindings type-params class member) (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List Code) (List Code) (List Text) (List Code)])) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (let [(^slots [#import-member-tvars #import-member-args]) commons] (do Monad [arg-inputs (M;map @ (: (-> [Bool GenericType] (Lux [Code Code])) (function [[maybe? _]] (with-gensyms [arg-name] (wrap [arg-name (if maybe? (` (!!! (~ arg-name))) arg-name)])))) import-member-args) #let [arg-classes (: (List Text) (L/map (. (simple-class$ (L/append type-params import-member-tvars)) product;right) import-member-args)) arg-types (L/map (: (-> [Bool GenericType] Code) (function [[maybe? arg]] (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] (if maybe? (` (Maybe (~ arg-type))) arg-type)))) import-member-args) arg-function-inputs (L/map product;left arg-inputs) arg-method-inputs (L/map product;right arg-inputs)]] (wrap [arg-function-inputs arg-method-inputs arg-classes arg-types]))) _ (:: Monad wrap [(list) (list) (list) (list)]))) (def: (member-def-return mode type-params class member) (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux Code)) (case member (#ConstructorDecl _) (:: Monad wrap (class-decl-type$ class)) (#MethodDecl [_ method]) (:: Monad wrap (class->type mode type-params (get@ #import-method-return method))) _ (macro;fail "Only methods have return values."))) (def: (decorate-return-maybe member [return-type return-term]) (-> ImportMemberDecl [Code Code] [Code Code]) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (if (get@ #import-member-maybe? commons) [(` (Maybe (~ return-type))) (` (??? (~ return-term)))] [return-type (let [g!temp (code;symbol ["" "Ω"])] (` (let [(~ g!temp) (~ return-term)] (if (not (null? (:! (host (~' java.lang.Object)) (~ g!temp)))) (~ g!temp) (error! "Cannot produce null references from method calls.")))))]) _ [return-type return-term])) (do-template [ ] [(def: ( member [return-type return-term]) (-> ImportMemberDecl [Code Code] [Code Code]) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (if (get@ commons) [ ] [return-type return-term]) _ [return-type return-term]))] [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))] [decorate-return-io #import-member-io? (` (IO (~ return-type))) (` (io (~ return-term)))] ) (def: (free-type-param? [name bounds]) (-> TypeParam Bool) (case bounds #;Nil true _ false)) (def: (type-param->type-arg [name _]) (-> TypeParam Code) (code;symbol ["" name])) (def: (with-mode-output mode output-type body) (-> Primitive-Mode GenericType Code Code) (case mode #ManualPrM body #AutoPrM (case output-type (#GenericClass ["byte" _]) (` (b2l (~ body))) (#GenericClass ["short" _]) (` (s2l (~ body))) (#GenericClass ["int" _]) (` (i2l (~ body))) (#GenericClass ["float" _]) (` (f2d (~ body))) _ body))) (def: (auto-conv-class? class) (-> Text Bool) (case class (^or "byte" "short" "int" "float") true _ false)) (def: (auto-conv [class var]) (-> [Text Code] (List Code)) (case class "byte" (list var (` (l2b (~ var)))) "short" (list var (` (l2s (~ var)))) "int" (list var (` (l2i (~ var)))) "float" (list var (` (d2f (~ var)))) _ (list))) (def: (with-mode-inputs mode inputs body) (-> Primitive-Mode (List [Text Code]) Code Code) (case mode #ManualPrM body #AutoPrM (` (let [(~@ (|> inputs (L/map auto-conv) L/join))] (~ body))))) (def: (with-mode-field-get mode class output) (-> Primitive-Mode GenericType Code Code) (case mode #ManualPrM output #AutoPrM (case (simple-class$ (list) class) "byte" (` (b2l (~ output))) "short" (` (s2l (~ output))) "int" (` (i2l (~ output))) "float" (` (f2d (~ output))) _ output))) (def: (with-mode-field-set mode class input) (-> Primitive-Mode GenericType Code Code) (case mode #ManualPrM input #AutoPrM (case (simple-class$ (list) class) "byte" (` (l2b (~ input))) "short" (` (l2s (~ input))) "int" (` (l2i (~ input))) "float" (` (d2f (~ input))) _ input))) (def: (member-def-interop type-params kind class [arg-function-inputs arg-method-inputs arg-classes arg-types] member method-prefix) (-> (List TypeParam) ClassKind ClassDecl [(List Code) (List Code) (List Text) (List Code)] ImportMemberDecl Text (Lux (List Code))) (let [[full-name class-tvars] class all-params (|> (member-type-vars class-tvars member) (list;filter free-type-param?) (L/map type-param->type-arg))] (case member (#EnumDecl enum-members) (do Monad [#let [enum-type (: Code (case class-tvars #;Nil (` (host (~ (code;symbol ["" full-name])))) _ (let [=class-tvars (|> class-tvars (list;filter free-type-param?) (L/map type-param->type-arg))] (` (All [(~@ =class-tvars)] (host (~ (code;symbol ["" full-name])) [(~@ =class-tvars)])))))) getter-interop (: (-> Text Code) (function [name] (let [getter-name (code;symbol ["" (format method-prefix member-separator name)])] (` (def: (~ getter-name) (~ enum-type) (;_lux_proc ["jvm" (~ (code;text (format "getstatic" ":" full-name ":" name)))] []))))))]] (wrap (L/map getter-interop enum-members))) (#ConstructorDecl [commons _]) (do Monad [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) #let [def-name (code;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) def-params (list (code;tuple arg-function-inputs)) jvm-interop (|> (` (;_lux_proc ["jvm" (~ (code;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))] [(~@ arg-method-inputs)])) (with-mode-inputs (get@ #import-member-mode commons) (list;zip2 arg-classes arg-function-inputs))) [return-type jvm-interop] (|> [return-type jvm-interop] (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] (wrap (list (` (def: ((~ def-name) (~@ def-params)) (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type))) (~ jvm-interop)))))) (#MethodDecl [commons method]) (with-gensyms [g!obj] (do @ [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) #let [def-name (code;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) (^slots [#import-member-kind]) commons (^slots [#import-method-name]) method [jvm-op obj-ast class-ast] (: [Text (List Code) (List Code)] (case import-member-kind #StaticIMK ["invokestatic" (list) (list)] #VirtualIMK (case kind #Class ["invokevirtual" (list g!obj) (list (class-decl-type$ class))] #Interface ["invokeinterface" (list g!obj) (list (class-decl-type$ class))] ))) def-params (#;Cons (code;tuple arg-function-inputs) obj-ast) def-param-types (#;Cons (` [(~@ arg-types)]) class-ast) jvm-interop (|> (` (;_lux_proc ["jvm" (~ (code;text (format jvm-op ":" full-name ":" import-method-name ":" (text;join-with "," arg-classes))))] [(~@ obj-ast) (~@ arg-method-inputs)])) (with-mode-output (get@ #import-member-mode commons) (get@ #import-method-return method)) (with-mode-inputs (get@ #import-member-mode commons) (list;zip2 arg-classes arg-function-inputs))) [return-type jvm-interop] (|> [return-type jvm-interop] (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] (wrap (list (` (def: ((~ def-name) (~@ def-params)) (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type))) (~ jvm-interop))))))) (#FieldAccessDecl fad) (do Monad [#let [(^open) fad base-gtype (class->type import-field-mode type-params import-field-type) g!class (class-decl-type$ class) g!type (if import-field-maybe? (` (Maybe (~ base-gtype))) base-gtype) tvar-asts (: (List Code) (|> class-tvars (list;filter free-type-param?) (L/map type-param->type-arg))) getter-name (code;symbol ["" (format method-prefix member-separator import-field-name)]) setter-name (code;symbol ["" (format method-prefix member-separator import-field-name "!")])] getter-interop (with-gensyms [g!obj] (let [getter-call (if import-field-static? getter-name (` ((~ getter-name) (~ g!obj)))) getter-type (if import-field-setter? (` (IO (~ g!type))) g!type) getter-type (if import-field-static? getter-type (` (-> (~ g!class) (~ getter-type)))) getter-type (` (All [(~@ tvar-asts)] (~ getter-type))) getter-body (if import-field-static? (with-mode-field-get import-field-mode import-field-type (` (;_lux_proc ["jvm" (~ (code;text (format "getstatic" ":" full-name ":" import-field-name)))] []))) (with-mode-field-get import-field-mode import-field-type (` (;_lux_proc ["jvm" (~ (code;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)])))) getter-body (if import-field-maybe? (` (??? (~ getter-body))) getter-body) getter-body (if import-field-setter? (` (io (~ getter-body))) getter-body)] (wrap (` (def: (~ getter-call) (~ getter-type) (~ getter-body)))))) setter-interop (if import-field-setter? (with-gensyms [g!obj g!value] (let [setter-call (if import-field-static? (` ((~ setter-name) (~ g!value))) (` ((~ setter-name) (~ g!value) (~ g!obj)))) setter-type (if import-field-static? (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit)))) (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit))))) setter-value (with-mode-field-set import-field-mode import-field-type g!value) setter-value (if import-field-maybe? (` (!!! (~ setter-value))) setter-value) setter-command (format (if import-field-static? "putstatic" "putfield") ":" full-name ":" import-field-name)] (wrap (: (List Code) (list (` (def: (~ setter-call) (~ setter-type) (io (;_lux_proc ["jvm" (~ (code;text setter-command))] [(~ setter-value)]))))))))) (wrap (list)))] (wrap (list& getter-interop setter-interop))) ))) (def: (member-import$ type-params long-name? kind class member) (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List Code))) (let [[full-name _] class method-prefix (if long-name? full-name (short-class-name full-name))] (do Monad [=args (member-def-arg-bindings type-params class member)] (member-def-interop type-params kind class =args member method-prefix)))) (def: (interface? class) (All [a] (-> (host java.lang.Class [a]) Bool)) (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class])) (def: (load-class class-name) (-> Text (Either Text (host java.lang.Class [(Ex [a] a)]))) (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name]))) (def: (class-kind [class-name _]) (-> ClassDecl (Lux ClassKind)) (case (load-class class-name) (#;Right class) (:: Monad wrap (if (interface? class) #Interface #Class)) (#;Left _) (macro;fail (format "Unknown class: " class-name)))) (syntax: #export (jvm-import [#let [imports (class-imports *compiler*)]] [long-name? (s;this? (' #long))] [class-decl (class-decl^ imports)] [#let [full-class-name (product;left class-decl) imports (add-import [(short-class-name full-class-name) full-class-name] (class-imports *compiler*))]] [members (p;some (import-member-decl^ imports (product;right class-decl)))]) {#;doc (doc "Allows importing JVM classes, and using them as types." "Their methods, fields and enum options can also be imported." "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes." "Examples:" (jvm-import java.lang.Object (new []) (equals [Object] boolean) (wait [int] #io #try void)) "Special options can also be given for the return values." "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None." "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type." "#io means the computation has side effects, and will be wrapped by the IO type." "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." (jvm-import java.lang.String (new [(Array byte)]) (#static valueOf [char] String) (#static valueOf #as int-valueOf [int] String)) (jvm-import #long (java.util.List e) (size [] int) (get [int] e)) (jvm-import (java.util.ArrayList a) ([T] toArray [(Array T)] (Array T))) "#long makes it so the class-type that is generated is of the fully-qualified name." "In this case, it avoids a clash between the java.util.List type, and Lux's own List type." (jvm-import java.lang.Character$UnicodeScript (#enum ARABIC CYRILLIC LATIN)) "All enum options to be imported must be specified." (jvm-import #long (lux.concurrency.promise.JvmPromise A) (resolve [A] boolean) (poll [] A) (wasResolved [] boolean) (waitOn [lux.Function] void) (#static [A] make [A] (JvmPromise A))) "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)." "Also, the names of the imported members will look like ClassName.MemberName." "E.g.:" (Object.new []) (Object.equals [other-object] my-object) (java.util.List.size [] my-list) Character$UnicodeScript.LATIN )} (do Monad [kind (class-kind class-decl) =members (M;map @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)] (wrap (list& (class-import$ long-name? class-decl) (L/join =members))))) (syntax: #export (array [#let [imports (class-imports *compiler*)]] [type (generic-type^ imports (list))] size) {#;doc (doc "Create an array of the given type, with the given size." (array Object +10))} (case type (^template [ ] (^ (#GenericClass (list))) (wrap (list (` (;_lux_proc ["jvm" ] [(~ size)]))))) (["boolean" "znewarray"] ["byte" "bnewarray"] ["short" "snewarray"] ["int" "inewarray"] ["long" "lnewarray"] ["float" "fnewarray"] ["double" "dnewarray"] ["char" "cnewarray"]) _ (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (code;text (generic-type$ type))) (~ size)])))))) (syntax: #export (array-length array) {#;doc (doc "Gives the length of an array." (array-length my-array))} (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)]))))) (def: (type->class-name type) (-> Type (Lux Text)) (case type (#;Host name params) (:: Monad wrap name) (#;Apply A F) (case (type;apply (list A) F) #;None (macro;fail (format "Cannot apply type: " (type;to-text F) " to " (type;to-text A))) (#;Some type') (type->class-name type')) (#;Named _ type') (type->class-name type') #;Unit (:: Monad wrap "java.lang.Object") (^or #;Void (#;Var _) (#;Ex _) (#;Bound _) (#;Sum _) (#;Product _) (#;Function _) (#;UnivQ _) (#;ExQ _)) (macro;fail (format "Cannot convert to JvmType: " (type;to-text type))) )) (syntax: #export (array-read idx array) {#;doc (doc "Loads an element from an array." (array-read +10 my-array))} (case array [_ (#;Symbol array-name)] (do Monad [array-type (macro;find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx)]))))) (["[Z" "zaload"] ["[B" "baload"] ["[S" "saload"] ["[I" "iaload"] ["[J" "jaload"] ["[F" "faload"] ["[D" "daload"] ["[C" "caload"]) _ (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)])))))) _ (with-gensyms [g!array] (wrap (list (` (let [(~ g!array) (~ array)] (;;array-read (~ idx) (~ g!array))))))))) (syntax: #export (array-write idx value array) {#;doc (doc "Stores an element into an array." (array-write +10 my-object my-array))} (case array [_ (#;Symbol array-name)] (do Monad [array-type (macro;find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx) (~ value)]))))) (["[Z" "zastore"] ["[B" "bastore"] ["[S" "sastore"] ["[I" "iastore"] ["[J" "jastore"] ["[F" "fastore"] ["[D" "dastore"] ["[C" "castore"]) _ (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)])))))) _ (with-gensyms [g!array] (wrap (list (` (let [(~ g!array) (~ array)] (;;array-write (~ idx) (~ value) (~ g!array))))))))) (def: simple-bindings^ (Syntax (List [Text Code])) (s;tuple (p;some (p;seq s;local-symbol s;any)))) (syntax: #export (with-open [bindings simple-bindings^] body) {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)." "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." (with-open [my-res1 (res1-constructor ...) my-res2 (res1-constructor ...)] (do Monad [foo (do-something my-res1) bar (do-something-else my-res2)] (do-one-last-thing foo bar))))} (with-gensyms [g!output g!_] (let [inits (L/join (L/map (function [[res-name res-ctor]] (list (code;symbol ["" res-name]) res-ctor)) bindings)) closes (L/map (function [res] (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"] [(~ (code;symbol ["" (product;left res)]))])))) bindings)] (wrap (list (` (do Monad [(~@ inits) (~ g!output) (~ body) (~' #let) [(~ g!_) (exec (~@ (list;reverse closes)) [])]] ((~' wrap) (~ g!output))))))))) (syntax: #export (class-for [#let [imports (class-imports *compiler*)]] [type (generic-type^ imports (list))]) {#;doc (doc "Loads the class as a java.lang.Class object." (class-for java.lang.String))} (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (code;text (simple-class$ (list) type)))]))))) (def: get-compiler (Lux Compiler) (function [compiler] (#;Right [compiler compiler]))) (def: (fully-qualify-class-name+ imports name) (-> ClassImports Text (Maybe Text)) (cond (fully-qualified-class-name? name) (#;Some name) (list;member? text;Eq java.lang-classes name) (#;Some (format "java.lang." name)) ## else (get-import name imports))) (def: #export (resolve-class class) {#;doc (doc "Given a potentially unqualified class name, qualifies it if necessary." (resolve-class "String") => "java.lang.String")} (-> Text (Lux Text)) (do Monad [*compiler* get-compiler] (case (fully-qualify-class-name+ (class-imports *compiler*) class) (#;Some fqcn) (wrap fqcn) #;None (macro;fail (Text/append "Unknown class: " class)))))