(.module: [lux (#- type) [abstract ["." monad (#+ Monad do)] ["." enum]] [control ["." function] ["." io] ["." try (#+ Try)] ["p" parser ["s" code (#+ Parser)]]] [data ["." maybe] ["." product] ["." bit ("#\." codec)] number ["." text ("#\." equivalence monoid) ["%" format (#+ format)]] [collection ["." array (#+ Array)] ["." list ("#\." monad fold monoid)]]] ["." type ("#\." equivalence)] [macro ["." code] [syntax (#+ syntax:)]] ["." meta (#+ with-gensyms) ["." annotation]]]) (template [ ] [(def: #export ( value) {#.doc (doc "Type converter." (: ( (: foo))))} (-> (primitive ) (primitive )) ( value))] [byte-to-long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"] [short-to-long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"] [double-to-int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"] [double-to-long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"] [double-to-float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"] [float-to-int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"] [float-to-long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"] [float-to-double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"] [int-to-byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"] [int-to-short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"] [int-to-long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"] [int-to-float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"] [int-to-double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"] [int-to-char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"] [long-to-byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"] [long-to-short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"] [long-to-int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"] [long-to-float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"] [long-to-double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"] [char-to-byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"] [char-to-short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"] [char-to-int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"] [char-to-long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"] ) ## [Utils] (def: constructor-method-name "") (def: member-separator "::") ## Types (type: JVM-Code Text) (type: BoundKind #UpperBound #LowerBound) (type: #rec GenericType (#GenericTypeVar Text) (#GenericClass [Text (List GenericType)]) (#GenericArray GenericType) (#GenericWildcard (Maybe [BoundKind GenericType]))) (type: Type-Parameter [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: Class-Kind #Class #Interface) (type: Class-Declaration {#class-name Text #class-params (List Type-Parameter)}) (type: StackFrame (primitive "java/lang/StackTraceElement")) (type: StackTrace (Array StackFrame)) (type: Super-Class-Decl {#super-class-name Text #super-class-params (List GenericType)}) (type: AnnotationParam [Text Code]) (type: Annotation {#ann-name Text #ann-params (List AnnotationParam)}) (type: Member-Declaration {#member-name Text #member-privacy PrivacyModifier #member-anns (List Annotation)}) (type: FieldDecl (#ConstantField GenericType Code) (#VariableField StateModifier GenericType)) (type: MethodDecl {#method-tvars (List Type-Parameter) #method-inputs (List GenericType) #method-output GenericType #method-exs (List GenericType)}) (type: ArgDecl {#arg-name Text #arg-type GenericType}) (type: ConstructorArg [GenericType Code]) (type: Method-Definition (#ConstructorMethod [Bit (List Type-Parameter) (List ArgDecl) (List ConstructorArg) Code (List GenericType)]) (#VirtualMethod [Bit Bit (List Type-Parameter) Text (List ArgDecl) GenericType Code (List GenericType)]) (#OverridenMethod [Bit Class-Declaration (List Type-Parameter) Text (List ArgDecl) GenericType Code (List GenericType)]) (#StaticMethod [Bit (List Type-Parameter) (List ArgDecl) GenericType Code (List GenericType)]) (#AbstractMethod [(List Type-Parameter) (List ArgDecl) GenericType (List GenericType)]) (#NativeMethod [(List Type-Parameter) (List ArgDecl) GenericType (List GenericType)])) (type: Partial-Call {#pc-method Name #pc-args (List Code)}) (type: ImportMethodKind #StaticIMK #VirtualIMK) (type: ImportMethodCommons {#import-member-mode Primitive-Mode #import-member-alias Text #import-member-kind ImportMethodKind #import-member-tvars (List Type-Parameter) #import-member-args (List [Bit GenericType]) #import-member-maybe? Bit #import-member-try? Bit #import-member-io? Bit}) (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? Bit #import-field-maybe? Bit #import-field-setter? Bit #import-field-type GenericType}) (type: Import-Member-Declaration (#EnumDecl (List Text)) (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) (#MethodDecl [ImportMethodCommons ImportMethodDecl]) (#FieldAccessDecl ImportFieldDecl)) ## Utils (def: (manual-primitive-to-type class) (-> Text (Maybe Code)) (case class (^template [ ] [ (#.Some (' ))]) (["boolean" (primitive "java.lang.Boolean")] ["byte" (primitive "java.lang.Byte")] ["short" (primitive "java.lang.Short")] ["int" (primitive "java.lang.Integer")] ["long" (primitive "java.lang.Long")] ["float" (primitive "java.lang.Float")] ["double" (primitive "java.lang.Double")] ["char" (primitive "java.lang.Character")] ["void" .Any]) _ #.None)) (def: (auto-primitive-to-type class) (-> Text (Maybe Code)) (case class (^template [ ] [ (#.Some (' ))]) (["boolean" .Bit] ["byte" .Int] ["short" .Int] ["int" .Int] ["long" .Int] ["float" .Frac] ["double" .Frac] ["void" .Any]) _ #.None)) (def: sanitize (-> Text Text) (text.replace-all "/" ".")) (def: (generic-class->type' mode type-params in-array? name+params class->type') (-> Primitive-Mode (List Type-Parameter) Bit [Text (List GenericType)] (-> Primitive-Mode (List Type-Parameter) Bit GenericType Code) Code) (case [name+params mode in-array?] (^multi [[prim #.Nil] #ManualPrM #0] [(manual-primitive-to-type prim) (#.Some output)]) output (^multi [[prim #.Nil] #AutoPrM #0] [(auto-primitive-to-type prim) (#.Some output)]) output [[name params] _ _] (let [name (sanitize name) =params (list\map (class->type' mode type-params in-array?) params)] (` (primitive (~ (code.text name)) [(~+ =params)]))))) (def: (class->type' mode type-params in-array? class) (-> Primitive-Mode (List Type-Parameter) Bit GenericType Code) (case class (#GenericTypeVar name) (case (list.find (function (_ [pname pbounds]) (and (text\= name pname) (not (list.empty? pbounds)))) type-params) #.None (code.identifier ["" name]) (#.Some [pname pbounds]) (class->type' mode type-params in-array? (maybe.assume (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 #1 param)] (` ((~! array.Array) (~ =param)))) (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) (` .Any) (#GenericWildcard (#.Some [#UpperBound upper-bound])) (class->type' mode type-params in-array? upper-bound) )) (def: (class->type mode type-params class) (-> Primitive-Mode (List Type-Parameter) GenericType Code) (class->type' mode type-params #0 class)) (def: (type-param-type$ [name bounds]) (-> Type-Parameter Code) (code.identifier ["" name])) (def: (class-decl-type$ (^slots [#class-name #class-params])) (-> Class-Declaration Code) (let [=params (list\map (: (-> Type-Parameter Code) (function (_ [pname pbounds]) (case pbounds #.Nil (code.identifier ["" pname]) (#.Cons bound1 _) (class->type #ManualPrM class-params bound1)))) class-params)] (` (primitive (~ (code.text (sanitize class-name))) [(~+ =params)])))) (def: type-var-class Text "java.lang.Object") (def: (simple-class$ env class) (-> (List Type-Parameter) GenericType Text) (case class (#GenericTypeVar name) (case (list.find (function (_ [pname pbounds]) (and (text\= name pname) (not (list.empty? pbounds)))) env) #.None type-var-class (#.Some [pname pbounds]) (simple-class$ env (maybe.assume (list.head pbounds)))) (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) type-var-class (#GenericWildcard (#.Some [#UpperBound upper-bound])) (simple-class$ env upper-bound) (#GenericClass name env) (sanitize name) (#GenericArray param') (case param' (#GenericArray param) (format "[" (simple-class$ env 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$ env param) ";")) )) (def: (make-get-const-parser class-name field-name) (-> Text Text (Parser Code)) (do p.monad [#let [dotted-name (format "::" field-name)] _ (s.this! (code.identifier ["" dotted-name]))] (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class-name ":" field-name)))))))) (def: (make-get-var-parser class-name field-name) (-> Text Text (Parser Code)) (do p.monad [#let [dotted-name (format "::" field-name)] _ (s.this! (code.identifier ["" dotted-name]))] (wrap (`' ((~ (code.text (format "jvm getfield" ":" class-name ":" field-name))) _jvm_this))))) (def: (make-put-var-parser class-name field-name) (-> Text Text (Parser Code)) (do p.monad [#let [dotted-name (format "::" field-name)] [_ _ value] (: (Parser [Any Any Code]) (s.form ($_ p.and (s.this! (' :=)) (s.this! (code.identifier ["" dotted-name])) s.any)))] (wrap (`' ((~ (code.text (format "jvm 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 ( (list\map (pre-walk-replace f) parts))]]) ([#.Form] [#.Tuple]) [meta (#.Record pairs)] [meta (#.Record (list\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) (-> (Parser Code) (-> Code Code)) (case (p.run p (list ast)) (#.Right [#.Nil ast']) ast' _ ast )) (def: (field->parser class-name [[field-name _ _] field]) (-> Text [Member-Declaration FieldDecl] (Parser 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 Type-Parameter) Text (List ArgDecl) (Parser Code)) (do p.monad [args (: (Parser (List Code)) (s.form (p.after (s.this! (' ::new!)) (s.tuple (p.exactly (list.size arg-decls) s.any))))) #let [arg-decls' (: (List Text) (list\map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (` ((~ (code.text (format "jvm new" ":" class-name ":" (text.join-with "," arg-decls')))) (~+ args)))))) (def: (make-static-method-parser params class-name method-name arg-decls) (-> (List Type-Parameter) Text Text (List ArgDecl) (Parser Code)) (do p.monad [#let [dotted-name (format "::" method-name "!")] args (: (Parser (List Code)) (s.form (p.after (s.this! (code.identifier ["" dotted-name])) (s.tuple (p.exactly (list.size arg-decls) s.any))))) #let [arg-decls' (: (List Text) (list\map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) (~+ args)))))) (template [ ] [(def: ( params class-name method-name arg-decls) (-> (List Type-Parameter) Text Text (List ArgDecl) (Parser Code)) (do p.monad [#let [dotted-name (format "::" method-name "!")] args (: (Parser (List Code)) (s.form (p.after (s.this! (code.identifier ["" dotted-name])) (s.tuple (p.exactly (list.size arg-decls) s.any))))) #let [arg-decls' (: (List Text) (list\map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (`' ((~ (code.text (format ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) (~' _jvm_this) (~+ args))))))] [make-special-method-parser "jvm invokespecial"] [make-virtual-method-parser "jvm invokevirtual"] ) (def: (method->parser params class-name [[method-name _ _] meth-def]) (-> (List Type-Parameter) Text [Member-Declaration Method-Definition] (Parser 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 self-name args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars self-name 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))) ## Parsers (def: privacy-modifier^ (Parser PrivacyModifier) (let [(^open ".") p.monad] ($_ p.or (s.this! (' #public)) (s.this! (' #private)) (s.this! (' #protected)) (wrap [])))) (def: inheritance-modifier^ (Parser InheritanceModifier) (let [(^open ".") p.monad] ($_ p.or (s.this! (' #final)) (s.this! (' #abstract)) (wrap [])))) (def: bound-kind^ (Parser BoundKind) (p.or (s.this! (' <)) (s.this! (' >)))) (def: (assert-no-periods name) (-> Text (Parser Any)) (p.assert "Names in class declarations cannot contain periods." (not (text.contains? "." name)))) (def: (generic-type^ type-vars) (-> (List Type-Parameter) (Parser GenericType)) (p.rec (function (_ recur^) ($_ p.either (do p.monad [_ (s.this! (' ?))] (wrap (#GenericWildcard #.None))) (s.tuple (do p.monad [_ (s.this! (' ?)) bound-kind bound-kind^ bound recur^] (wrap (#GenericWildcard (#.Some [bound-kind bound]))))) (do p.monad [name s.local-identifier _ (assert-no-periods name)] (if (list.member? text.equivalence (list\map product.left type-vars) name) (wrap (#GenericTypeVar name)) (wrap (#GenericClass name (list))))) (s.tuple (do p.monad [component recur^] (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 s.local-identifier _ (assert-no-periods name) params (p.some recur^) _ (p.assert (format name " cannot be a type-parameter!") (not (list.member? text.equivalence (list\map product.left type-vars) name)))] (wrap (#GenericClass name params)))) )))) (def: type-param^ (Parser Type-Parameter) (p.either (do p.monad [param-name s.local-identifier] (wrap [param-name (list)])) (s.tuple (do p.monad [param-name s.local-identifier _ (s.this! (' <)) bounds (p.many (..generic-type^ (list)))] (wrap [param-name bounds]))))) (def: type-params^ (Parser (List Type-Parameter)) (|> ..type-param^ p.some s.tuple (p.default (list)))) (def: class-decl^ (Parser Class-Declaration) (p.either (do p.monad [name s.local-identifier _ (assert-no-periods name)] (wrap [name (list)])) (s.form (do p.monad [name s.local-identifier _ (assert-no-periods name) params (p.some ..type-param^)] (wrap [name params]))) )) (def: (super-class-decl^ type-vars) (-> (List Type-Parameter) (Parser Super-Class-Decl)) (p.either (do p.monad [name s.local-identifier _ (assert-no-periods name)] (wrap [name (list)])) (s.form (do p.monad [name s.local-identifier _ (assert-no-periods name) params (p.some (..generic-type^ type-vars))] (wrap [name params]))))) (def: annotation-params^ (Parser (List AnnotationParam)) (s.record (p.some (p.and s.local-tag s.any)))) (def: annotation^ (Parser Annotation) (p.either (do p.monad [ann-name s.local-identifier] (wrap [ann-name (list)])) (s.form (p.and s.local-identifier annotation-params^)))) (def: annotations^' (Parser (List Annotation)) (do p.monad [_ (s.this! (' #ann))] (s.tuple (p.some ..annotation^)))) (def: annotations^ (Parser (List Annotation)) (do p.monad [anns?? (p.maybe ..annotations^')] (wrap (maybe.default (list) anns??)))) (def: (throws-decl'^ type-vars) (-> (List Type-Parameter) (Parser (List GenericType))) (do p.monad [_ (s.this! (' #throws))] (s.tuple (p.some (..generic-type^ type-vars))))) (def: (throws-decl^ type-vars) (-> (List Type-Parameter) (Parser (List GenericType))) (do p.monad [exs? (p.maybe (throws-decl'^ type-vars))] (wrap (maybe.default (list) exs?)))) (def: (method-decl^ type-vars) (-> (List Type-Parameter) (Parser [Member-Declaration MethodDecl])) (s.form (do p.monad [tvars ..type-params^ name s.local-identifier anns ..annotations^ inputs (s.tuple (p.some (..generic-type^ type-vars))) output (..generic-type^ type-vars) exs (..throws-decl^ type-vars)] (wrap [[name #PublicPM anns] {#method-tvars tvars #method-inputs inputs #method-output output #method-exs exs}])))) (def: state-modifier^ (Parser StateModifier) ($_ p.or (s.this! (' #volatile)) (s.this! (' #final)) (:: p.monad wrap []))) (def: (field-decl^ type-vars) (-> (List Type-Parameter) (Parser [Member-Declaration FieldDecl])) (p.either (s.form (do p.monad [_ (s.this! (' #const)) name s.local-identifier anns ..annotations^ type (..generic-type^ 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-identifier anns ..annotations^ type (..generic-type^ type-vars)] (wrap [[name pm anns] (#VariableField [sm type])]))))) (def: (arg-decl^ type-vars) (-> (List Type-Parameter) (Parser ArgDecl)) (s.record (p.and s.local-identifier (..generic-type^ type-vars)))) (def: (arg-decls^ type-vars) (-> (List Type-Parameter) (Parser (List ArgDecl))) (p.some (arg-decl^ type-vars))) (def: (constructor-arg^ type-vars) (-> (List Type-Parameter) (Parser ConstructorArg)) (s.record (p.and (..generic-type^ type-vars) s.any))) (def: (constructor-args^ type-vars) (-> (List Type-Parameter) (Parser (List ConstructorArg))) (s.tuple (p.some (constructor-arg^ type-vars)))) (def: (constructor-method^ class-vars) (-> (List Type-Parameter) (Parser [Member-Declaration Method-Definition])) (s.form (do p.monad [pm privacy-modifier^ strict-fp? (p.parses? (s.this! (' #strict))) method-vars ..type-params^ #let [total-vars (list\compose class-vars method-vars)] [_ arg-decls] (s.form (p.and (s.this! (' new)) (..arg-decls^ total-vars))) constructor-args (..constructor-args^ total-vars) exs (..throws-decl^ total-vars) annotations ..annotations^ 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^ class-vars) (-> (List Type-Parameter) (Parser [Member-Declaration Method-Definition])) (s.form (do p.monad [pm privacy-modifier^ strict-fp? (p.parses? (s.this! (' #strict))) final? (p.parses? (s.this! (' #final))) method-vars ..type-params^ #let [total-vars (list\compose class-vars method-vars)] [name this-name arg-decls] (s.form ($_ p.and s.local-identifier s.local-identifier (..arg-decls^ total-vars))) return-type (..generic-type^ total-vars) exs (..throws-decl^ total-vars) annotations ..annotations^ body s.any] (wrap [{#member-name name #member-privacy pm #member-anns annotations} (#VirtualMethod final? strict-fp? method-vars this-name arg-decls return-type body exs)])))) (def: overriden-method-def^ (Parser [Member-Declaration Method-Definition]) (s.form (do p.monad [strict-fp? (p.parses? (s.this! (' #strict))) owner-class ..class-decl^ method-vars ..type-params^ #let [total-vars (list\compose (product.right owner-class) method-vars)] [name this-name arg-decls] (s.form ($_ p.and s.local-identifier s.local-identifier (..arg-decls^ total-vars))) return-type (..generic-type^ total-vars) exs (..throws-decl^ total-vars) annotations ..annotations^ body s.any] (wrap [{#member-name name #member-privacy #PublicPM #member-anns annotations} (#OverridenMethod strict-fp? owner-class method-vars this-name arg-decls return-type body exs)])))) (def: static-method-def^ (Parser [Member-Declaration Method-Definition]) (s.form (do p.monad [pm privacy-modifier^ strict-fp? (p.parses? (s.this! (' #strict))) _ (s.this! (' #static)) method-vars ..type-params^ #let [total-vars method-vars] [name arg-decls] (s.form (p.and s.local-identifier (..arg-decls^ total-vars))) return-type (..generic-type^ total-vars) exs (..throws-decl^ total-vars) annotations ..annotations^ 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^ (Parser [Member-Declaration Method-Definition]) (s.form (do p.monad [pm privacy-modifier^ _ (s.this! (' #abstract)) method-vars ..type-params^ #let [total-vars method-vars] [name arg-decls] (s.form (p.and s.local-identifier (..arg-decls^ total-vars))) return-type (..generic-type^ total-vars) exs (..throws-decl^ total-vars) annotations ..annotations^] (wrap [{#member-name name #member-privacy pm #member-anns annotations} (#AbstractMethod method-vars arg-decls return-type exs)])))) (def: native-method-def^ (Parser [Member-Declaration Method-Definition]) (s.form (do p.monad [pm privacy-modifier^ _ (s.this! (' #native)) method-vars ..type-params^ #let [total-vars method-vars] [name arg-decls] (s.form (p.and s.local-identifier (..arg-decls^ total-vars))) return-type (..generic-type^ total-vars) exs (..throws-decl^ total-vars) annotations ..annotations^] (wrap [{#member-name name #member-privacy pm #member-anns annotations} (#NativeMethod method-vars arg-decls return-type exs)])))) (def: (method-def^ class-vars) (-> (List Type-Parameter) (Parser [Member-Declaration Method-Definition])) ($_ p.either (..constructor-method^ class-vars) (..virtual-method-def^ class-vars) ..overriden-method-def^ ..static-method-def^ ..abstract-method-def^ ..native-method-def^)) (def: partial-call^ (Parser Partial-Call) (s.form (p.and s.identifier (p.some s.any)))) (def: class-kind^ (Parser Class-Kind) (p.either (do p.monad [_ (s.this! (' #class))] (wrap #Class)) (do p.monad [_ (s.this! (' #interface))] (wrap #Interface)) )) (def: import-member-alias^ (Parser (Maybe Text)) (p.maybe (do p.monad [_ (s.this! (' #as))] s.local-identifier))) (def: (import-member-args^ type-vars) (-> (List Type-Parameter) (Parser (List [Bit GenericType]))) (s.tuple (p.some (p.and (p.parses? (s.this! (' #?))) (..generic-type^ type-vars))))) (def: import-member-return-flags^ (Parser [Bit Bit Bit]) ($_ p.and (p.parses? (s.this! (' #io))) (p.parses? (s.this! (' #try))) (p.parses? (s.this! (' #?))))) (def: primitive-mode^ (Parser Primitive-Mode) (p.or (s.this! (' #manual)) (s.this! (' #auto)))) (def: (import-member-decl^ owner-vars) (-> (List Type-Parameter) (Parser Import-Member-Declaration)) ($_ p.either (s.form (do p.monad [_ (s.this! (' #enum)) enum-members (p.some s.local-identifier)] (wrap (#EnumDecl enum-members)))) (s.form (do p.monad [tvars ..type-params^ _ (s.this! (' new)) ?alias import-member-alias^ #let [total-vars (list\compose owner-vars tvars)] ?prim-mode (p.maybe primitive-mode^) args (..import-member-args^ total-vars) [io? try? maybe?] import-member-return-flags^] (wrap (#ConstructorDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode) #import-member-alias (maybe.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 (: (Parser ImportMethodKind) (p.or (s.this! (' #static)) (wrap []))) tvars ..type-params^ name s.local-identifier ?alias import-member-alias^ #let [total-vars (list\compose owner-vars tvars)] ?prim-mode (p.maybe primitive-mode^) args (..import-member-args^ total-vars) [io? try? maybe?] import-member-return-flags^ return (..generic-type^ total-vars)] (wrap (#MethodDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode) #import-member-alias (maybe.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? (p.parses? (s.this! (' #static))) name s.local-identifier ?prim-mode (p.maybe primitive-mode^) gtype (..generic-type^ owner-vars) maybe? (p.parses? (s.this! (' #?))) setter? (p.parses? (s.this! (' #!)))] (wrap (#FieldAccessDecl {#import-field-mode (maybe.default #AutoPrM ?prim-mode) #import-field-name name #import-field-static? static? #import-field-maybe? maybe? #import-field-setter? setter? #import-field-type gtype})))) )) (def: bundle (-> (List Type-Parameter) (Parser [Text (List Import-Member-Declaration)])) (|>> ..import-member-decl^ p.some (p.and s.text) s.tuple)) ## 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.format value))) (def: (annotation$ [name params]) (-> Annotation JVM-Code) (format "(" name " " "{" (text.join-with text.tab (list\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 "(" (sanitize name) " " (spaced (list\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]) (-> Type-Parameter JVM-Code) (format "(" name " " (spaced (list\map generic-type$ bounds)) ")")) (def: (class-decl$ (^open ".")) (-> Class-Declaration JVM-Code) (format "(" (sanitize class-name) " " (spaced (list\map type-param$ class-params)) ")")) (def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) (-> Super-Class-Decl JVM-Code) (format "(" (sanitize super-class-name) " " (spaced (list\map generic-type$ super-class-params)) ")")) (def: (method-decl$ [[name pm anns] method-decl]) (-> [Member-Declaration MethodDecl] JVM-Code) (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] (with-parens (spaced (list name (with-brackets (spaced (list\map annotation$ anns))) (with-brackets (spaced (list\map type-param$ method-tvars))) (with-brackets (spaced (list\map generic-type$ method-exs))) (with-brackets (spaced (list\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]) (-> [Member-Declaration FieldDecl] JVM-Code) (case field (#ConstantField class value) (with-parens (spaced (list "constant" name (with-brackets (spaced (list\map annotation$ anns))) (generic-type$ class) (code.format value)) )) (#VariableField sm class) (with-parens (spaced (list "variable" name (privacy-modifier$ pm) (state-modifier$ sm) (with-brackets (spaced (list\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.format term))))) (def: (method-def$ replacer super-class [[name pm anns] method-def]) (-> (-> Code Code) Super-Class-Decl [Member-Declaration Method-Definition] JVM-Code) (case method-def (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) (with-parens (spaced (list "init" (privacy-modifier$ pm) (bit\encode strict-fp?) (with-brackets (spaced (list\map annotation$ anns))) (with-brackets (spaced (list\map type-param$ type-vars))) (with-brackets (spaced (list\map generic-type$ exs))) (with-brackets (spaced (list\map arg-decl$ arg-decls))) (with-brackets (spaced (list\map constructor-arg$ constructor-args))) (code.format (pre-walk-replace replacer body)) ))) (#VirtualMethod final? strict-fp? type-vars this-name arg-decls return-type body exs) (with-parens (spaced (list "virtual" name (privacy-modifier$ pm) (bit\encode final?) (bit\encode strict-fp?) (with-brackets (spaced (list\map annotation$ anns))) (with-brackets (spaced (list\map type-param$ type-vars))) (with-brackets (spaced (list\map generic-type$ exs))) (with-brackets (spaced (list\map arg-decl$ arg-decls))) (generic-type$ return-type) (code.format (pre-walk-replace replacer (` (let [(~ (code.local-identifier this-name)) (~' _jvm_this)] (~ body)))))))) (#OverridenMethod strict-fp? class-decl type-vars this-name 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) (list\map (|>> product.right (simple-class$ (list))) arg-decls))]] (wrap (`' ((~ (code.text (format "jvm 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 (bit\encode strict-fp?) (with-brackets (spaced (list\map annotation$ anns))) (with-brackets (spaced (list\map type-param$ type-vars))) (with-brackets (spaced (list\map generic-type$ exs))) (with-brackets (spaced (list\map arg-decl$ arg-decls))) (generic-type$ return-type) (|> (` (let [(~ (code.local-identifier this-name)) (~' _jvm_this)] (~ body))) (pre-walk-replace replacer) (pre-walk-replace super-replacer) (code.format)) )))) (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) (with-parens (spaced (list "static" name (privacy-modifier$ pm) (bit\encode strict-fp?) (with-brackets (spaced (list\map annotation$ anns))) (with-brackets (spaced (list\map type-param$ type-vars))) (with-brackets (spaced (list\map generic-type$ exs))) (with-brackets (spaced (list\map arg-decl$ arg-decls))) (generic-type$ return-type) (code.format (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 (list\map annotation$ anns))) (with-brackets (spaced (list\map type-param$ type-vars))) (with-brackets (spaced (list\map generic-type$ exs))) (with-brackets (spaced (list\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 (list\map annotation$ anns))) (with-brackets (spaced (list\map type-param$ type-vars))) (with-brackets (spaced (list\map generic-type$ exs))) (with-brackets (spaced (list\map arg-decl$ arg-decls))) (generic-type$ return-type)))) )) (def: (complete-call$ g!obj [method args]) (-> Code Partial-Call Code) (` ((~ (code.identifier method)) (~+ args) (~ g!obj)))) ## [Syntax] (def: object-super-class Super-Class-Decl {#super-class-name "java/lang/Object" #super-class-params (list)}) (syntax: #export (class: {im inheritance-modifier^} {class-decl ..class-decl^} {#let [full-class-name (product.left class-decl)]} {#let [class-vars (product.right class-decl)]} {super (p.default object-super-class (..super-class-decl^ class-vars))} {interfaces (p.default (list) (s.tuple (p.some (..super-class-decl^ class-vars))))} {annotations ..annotations^} {fields (p.some (..field-decl^ class-vars))} {methods (p.some (..method-def^ class-vars))}) {#.doc (doc "Allows defining JVM classes in Lux code." "For example:" (class: #final (TestClass A) [Runnable] ## Fields (#private foo boolean) (#private bar A) (#private baz java/lang/Object) ## Methods (#public [] (new [value A]) [] (exec (:= ::foo #1) (:= ::bar value) (:= ::baz "") [])) (#public (virtual) java/lang/Object "") (#public #static (static) java/lang/Object "") (Runnable [] (run) void []) ) "The tuple corresponds to parent interfaces." "An optional super-class can be specified before the tuple. 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 #1) for modifying it." "(::new! []) for calling the class's constructor." "(::resolve! container [value]) for calling the 'resolve' method." )} (do meta.monad [current-module meta.current-module-name #let [fully-qualified-class-name (format (sanitize current-module) "." full-class-name) field-parsers (list\map (field->parser fully-qualified-class-name) fields) method-parsers (list\map (method->parser (product.right class-decl) fully-qualified-class-name) methods) replacer (parser->replacer (list\fold p.either (p.fail "") (list\compose field-parsers method-parsers))) def-code (format "jvm class:" (spaced (list (class-decl$ class-decl) (super-class-decl$ super) (with-brackets (spaced (list\map super-class-decl$ interfaces))) (inheritance-modifier$ im) (with-brackets (spaced (list\map annotation$ annotations))) (with-brackets (spaced (list\map field-decl$ fields))) (with-brackets (spaced (list\map (method-def$ replacer super) methods))))))]] (wrap (list (` ((~ (code.text def-code)))))))) (syntax: #export (interface: {class-decl ..class-decl^} {#let [class-vars (product.right class-decl)]} {supers (p.default (list) (s.tuple (p.some (..super-class-decl^ class-vars))))} {annotations ..annotations^} {members (p.some (..method-decl^ class-vars))}) {#.doc (doc "Allows defining JVM interfaces." (interface: TestInterface ([] foo [boolean String] void #throws [Exception])))} (let [def-code (format "jvm interface:" (spaced (list (class-decl$ class-decl) (with-brackets (spaced (list\map super-class-decl$ supers))) (with-brackets (spaced (list\map annotation$ annotations))) (spaced (list\map method-decl$ members)))))] (wrap (list (` ((~ (code.text def-code)))))) )) (syntax: #export (object {class-vars (s.tuple (p.some ..type-param^))} {super (p.default object-super-class (..super-class-decl^ class-vars))} {interfaces (p.default (list) (s.tuple (p.some (..super-class-decl^ class-vars))))} {constructor-args (..constructor-args^ class-vars)} {methods (p.some ..overriden-method-def^)}) {#.doc (doc "Allows defining anonymous classes." "The 1st tuple corresponds to class-level type-variables." "The 2nd tuple corresponds to parent interfaces." "The 3rd tuple corresponds to arguments to the super class constructor." "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed." (object [] [Runnable] [] (Runnable [] (run self) void (exec (do-something some-value) []))) )} (let [def-code (format "jvm anon-class:" (spaced (list (super-class-decl$ super) (with-brackets (spaced (list\map super-class-decl$ interfaces))) (with-brackets (spaced (list\map constructor-arg$ constructor-args))) (with-brackets (spaced (list\map (method-def$ function.identity super) methods))))))] (wrap (list (` ((~ (code.text def-code)))))))) (syntax: #export (null) {#.doc (doc "Null object reference." (null))} (wrap (list (` ("jvm object null"))))) (def: #export (null? obj) {#.doc (doc "Test for null object reference." (= (null? (null)) true) (= (null? "YOLO") false))} (-> (primitive "java.lang.Object") Bit) ("jvm object 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 ("jvm object 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)." (= (null) (!!! (??? (: java/lang/Thread (null))))) (= "foo" (!!! (??? "foo"))))} (with-gensyms [g!value] (wrap (list (` ({(#.Some (~ g!value)) (~ g!value) #.None ("jvm object null")} (~ expr))))))) (syntax: #export (try expression) {#.doc (doc (case (try (risky-computation input)) (#.Right success) (do-something success) (#.Left error) (recover-from-failure error)))} (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) (syntax: #export (check {class (..generic-type^ (list))} {unchecked (p.maybe 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." (case (check String "YOLO") (#.Some value-as-string) #.None))} (with-gensyms [g!_ g!unchecked] (let [class-name (simple-class$ (list) class) class-type (` (.primitive (~ (code.text class-name)))) check-type (` (.Maybe (~ class-type))) check-code (` (if ((~ (code.text (format "jvm instanceof" ":" class-name))) (~ g!unchecked)) (#.Some (.:coerce (~ class-type) (~ g!unchecked))) #.None))] (case unchecked (#.Some unchecked) (wrap (list (` (: (~ check-type) (let [(~ g!unchecked) (~ unchecked)] (~ check-code)))))) #.None (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check-type)) (function ((~ g!_) (~ g!unchecked)) (~ check-code)))))) )))) (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 (` ("jvm object 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 object (ClassName::method1 arg0 arg1 arg2) (ClassName::method2 arg3 arg4 arg5)))} (with-gensyms [g!obj] (wrap (list (` (let [(~ g!obj) (~ obj)] (exec (~+ (list\map (complete-call$ g!obj) methods)) (~ g!obj)))))))) (def: (class-import$ [full-name params]) (-> Class-Declaration Code) (let [params' (list\map (|>> product.left code.local-identifier) params)] (` (def: (~ (code.identifier ["" full-name])) {#..jvm-class (~ (code.text full-name))} Type (All [(~+ params')] (primitive (~ (code.text (sanitize full-name))) [(~+ params')])))))) (def: (member-type-vars class-tvars member) (-> (List Type-Parameter) Import-Member-Declaration (List Type-Parameter)) (case member (#ConstructorDecl [commons _]) (list\compose class-tvars (get@ #import-member-tvars commons)) (#MethodDecl [commons _]) (case (get@ #import-member-kind commons) #StaticIMK (get@ #import-member-tvars commons) _ (list\compose class-tvars (get@ #import-member-tvars commons))) _ class-tvars)) (def: (member-def-arg-bindings type-params class member) (-> (List Type-Parameter) Class-Declaration Import-Member-Declaration (Meta [(List [Bit Code]) (List Text) (List Code)])) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (let [(^slots [#import-member-tvars #import-member-args]) commons] (do {! meta.monad} [arg-inputs (monad.map ! (: (-> [Bit GenericType] (Meta [Bit Code])) (function (_ [maybe? _]) (with-gensyms [arg-name] (wrap [maybe? arg-name])))) import-member-args) #let [arg-classes (: (List Text) (list\map (|>> product.right (simple-class$ (list\compose type-params import-member-tvars))) import-member-args)) arg-types (list\map (: (-> [Bit 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)]] (wrap [arg-inputs arg-classes arg-types]))) _ (:: meta.monad wrap [(list) (list) (list)]))) (def: (decorate-return-maybe member return-term) (-> Import-Member-Declaration Code Code) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (if (get@ #import-member-maybe? commons) (` (??? (~ return-term))) (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))] (` (let [(~ g!temp) (~ return-term)] (if (not (..null? (:coerce (primitive "java.lang.Object") (~ g!temp)))) (~ g!temp) (error! "Cannot produce null references from method calls.")))))) _ return-term)) (template [ ] [(def: ( member return-term) (-> Import-Member-Declaration Code Code) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (if (get@ commons) return-term) _ return-term))] [decorate-return-try #import-member-try? (` (..try (~ return-term)))] [decorate-return-io #import-member-io? (` ((~! io.io) (~ return-term)))] ) (def: (free-type-param? [name bounds]) (-> Type-Parameter Bit) (case bounds #.Nil #1 _ #0)) (def: (type-param->type-arg [name _]) (-> Type-Parameter Code) (code.identifier ["" name])) (template [ ] [(def: ( mode [class expression]) (-> Primitive-Mode [Text Code] Code) (case mode #ManualPrM expression #AutoPrM (case class "byte" (` ( (~ expression))) "short" (` ( (~ expression))) "int" (` ( (~ expression))) "float" (` ( (~ expression))) _ expression)))] [auto-convert-input long-to-byte long-to-short long-to-int double-to-float] [auto-convert-output byte-to-long short-to-long int-to-long float-to-double] ) (def: (un-quote quoted) (-> Code Code) (` ((~' ~) (~ quoted)))) (def: (jvm-extension-inputs mode classes inputs) (-> Primitive-Mode (List Text) (List [Bit Code]) (List Code)) (|> inputs (list\map (function (_ [maybe? input]) (if maybe? (` ((~! !!!) (~ (un-quote input)))) (un-quote input)))) (list.zip/2 classes) (list\map (auto-convert-input mode)))) (def: (import-name format class member) (-> Text Text Text Text) (|> format (text.replace-all "#" class) (text.replace-all "." member))) (def: (member-def-interop type-params kind class [arg-function-inputs arg-classes arg-types] member method-prefix import-format) (-> (List Type-Parameter) Class-Kind Class-Declaration [(List [Bit Code]) (List Text) (List Code)] Import-Member-Declaration Text Text (Meta (List Code))) (let [[full-name class-tvars] class full-name (sanitize full-name) all-params (|> (member-type-vars class-tvars member) (list.filter free-type-param?) (list\map type-param->type-arg))] (case member (#EnumDecl enum-members) (do {! meta.monad} [#let [enum-type (: Code (case class-tvars #.Nil (` (primitive (~ (code.text full-name)))) _ (let [=class-tvars (|> class-tvars (list.filter free-type-param?) (list\map type-param->type-arg))] (` (All [(~+ =class-tvars)] (primitive (~ (code.text full-name)) [(~+ =class-tvars)])))))) getter-interop (: (-> Text Code) (function (_ name) (let [getter-name (code.identifier ["" (..import-name import-format method-prefix name)])] (` (def: (~ getter-name) (~ enum-type) ((~ (code.text (format "jvm getstatic" ":" full-name ":" name)))))))))]] (wrap (list\map getter-interop enum-members))) (#ConstructorDecl [commons _]) (do meta.monad [#let [def-name (code.identifier ["" (..import-name import-format method-prefix (get@ #import-member-alias commons))]) jvm-extension (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes))) jvm-interop (|> (` ((~ jvm-extension) (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs)))) (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list\map product.right arg-function-inputs))) ((~' wrap) (.list (.` (~ jvm-interop))))))))) (#MethodDecl [commons method]) (with-gensyms [g!obj] (do meta.monad [#let [def-name (code.identifier ["" (..import-name import-format method-prefix (get@ #import-member-alias commons))]) (^slots [#import-member-kind]) commons (^slots [#import-method-name]) method [jvm-op object-ast] (: [Text (List Code)] (case import-member-kind #StaticIMK ["invokestatic" (list)] #VirtualIMK (case kind #Class ["invokevirtual" (list g!obj)] #Interface ["invokeinterface" (list g!obj)] ))) jvm-extension (code.text (format "jvm " jvm-op ":" full-name ":" import-method-name ":" (text.join-with "," arg-classes))) jvm-interop (|> [(simple-class$ (list) (get@ #import-method-return method)) (` ((~ jvm-extension) (~+ (list\map un-quote object-ast)) (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs))))] (auto-convert-output (get@ #import-member-mode commons)) (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list\map product.right arg-function-inputs)) (~+ object-ast)) ((~' wrap) (.list (.` (~ jvm-interop)))))))))) (#FieldAccessDecl fad) (do meta.monad [#let [(^open ".") fad base-gtype (class->type import-field-mode type-params import-field-type) classC (class-decl-type$ class) typeC (if import-field-maybe? (` (Maybe (~ base-gtype))) base-gtype) tvar-asts (: (List Code) (|> class-tvars (list.filter free-type-param?) (list\map type-param->type-arg))) getter-name (code.identifier ["" (..import-name import-format method-prefix import-field-name)]) setter-name (code.identifier ["" (..import-name import-format method-prefix (format import-field-name "!"))])] getter-interop (with-gensyms [g!obj] (let [getter-call (if import-field-static? (` ((~ getter-name))) (` ((~ getter-name) (~ g!obj)))) getter-body (<| (auto-convert-output import-field-mode) [(simple-class$ (list) import-field-type) (if import-field-static? (let [jvm-extension (code.text (format "jvm getstatic" ":" full-name ":" import-field-name))] (` ((~ jvm-extension)))) (let [jvm-extension (code.text (format "jvm getfield" ":" full-name ":" import-field-name))] (` ((~ jvm-extension) (~ (un-quote g!obj))))))]) getter-body (if import-field-maybe? (` ((~! ???) (~ getter-body))) getter-body) getter-body (if import-field-setter? (` ((~! io.io) (~ getter-body))) getter-body)] (wrap (` ((~! syntax:) (~ getter-call) ((~' wrap) (.list (.` (~ getter-body))))))))) setter-interop (: (Meta (List Code)) (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-value (auto-convert-input import-field-mode [(simple-class$ (list) import-field-type) (un-quote g!value)]) setter-value (if import-field-maybe? (` ((~! !!!) (~ setter-value))) setter-value) setter-command (format (if import-field-static? "jvm putstatic" "jvm putfield") ":" full-name ":" import-field-name) g!obj+ (: (List Code) (if import-field-static? (list) (list (un-quote g!obj))))] (wrap (list (` ((~! syntax:) (~ setter-call) ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter-command)) (~+ g!obj+) (~ setter-value)))))))))))) (wrap (list))))] (wrap (list& getter-interop setter-interop))) ))) (def: (member-import$ type-params kind class [import-format member]) (-> (List Type-Parameter) Class-Kind Class-Declaration [Text Import-Member-Declaration] (Meta (List Code))) (let [[method-prefix _] class] (do meta.monad [=args (member-def-arg-bindings type-params class member)] (member-def-interop type-params kind class =args member method-prefix import-format)))) (def: (interface? class) (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) ("jvm invokevirtual:java.lang.Class:isInterface:" class)) (def: (load-class class-name) (-> Text (Try (primitive "java.lang.Class" [Any]))) (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class-name))) (def: (class-kind [class-name _]) (-> Class-Declaration (Meta Class-Kind)) (let [class-name (sanitize class-name)] (case (load-class class-name) (#.Right class) (:: meta.monad wrap (if (interface? class) #Interface #Class)) (#.Left _) (meta.fail (format "Unknown class: " class-name))))) (syntax: #export (import: {class-decl ..class-decl^} {bundles (p.some (..bundle (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." (import: java/lang/Object ["#::." (new []) (equals [java/lang/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 Try 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)." (import: java/lang/String ["#::." (new [[byte]]) (#static valueOf [char] java/lang/String) (#static valueOf #as int-valueOf [int] java/lang/String)]) (import: (java/util/List e) ["#::." (size [] int) (get [int] e)]) (import: (java/util/ArrayList a) ["#::." ([T] toArray [[T]] [T])]) "The class-type that is generated is of the fully-qualified name." "This avoids a clash between the java.util.List type, and Lux's own List type." "All enum options to be imported must be specified." (import: java/lang/Character$UnicodeScript ["#::." (#enum ARABIC CYRILLIC LATIN)]) "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)." (import: (lux/concurrency/promise/JvmPromise A) ["#::." (resolve [A] boolean) (poll [] A) (wasResolved [] boolean) (waitOn [lux/Function] void) (#static [A] make [A] (lux/concurrency/promise/JvmPromise A))]) "Also, the names of the imported members will look like Class::member" (java/lang/Object::new []) (java/lang/Object::equals [other-object] my-object) (java/util/List::size [] my-list) java/lang/Character$UnicodeScript::LATIN )} (do {! meta.monad} [kind (class-kind class-decl) =members (|> bundles (list\map (function (_ [import-format members]) (list\map (|>> [import-format]) members))) list.concat (monad.map ! (member-import$ (product.right class-decl) kind class-decl)))] (wrap (list& (class-import$ class-decl) (list\join =members))))) (syntax: #export (array {type (..generic-type^ (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 (` ( (~ size)))))]) (["boolean" "jvm znewarray"] ["byte" "jvm bnewarray"] ["short" "jvm snewarray"] ["int" "jvm inewarray"] ["long" "jvm lnewarray"] ["float" "jvm fnewarray"] ["double" "jvm dnewarray"] ["char" "jvm cnewarray"]) _ (wrap (list (` ("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 (` ("jvm arraylength" (~ array)))))) (def: (type->class-name type) (-> Type (Meta Text)) (if (type\= Any type) (:: meta.monad wrap "java.lang.Object") (case type (#.Primitive name params) (:: meta.monad wrap name) (#.Apply A F) (case (type.apply (list A) F) #.None (meta.fail (format "Cannot apply type: " (type.format F) " to " (type.format A))) (#.Some type') (type->class-name type')) (#.Named _ type') (type->class-name type') _ (meta.fail (format "Cannot convert to JvmType: " (type.format type)))))) (syntax: #export (array-read idx array) {#.doc (doc "Loads an element from an array." (array-read 10 my-array))} (case array [_ (#.Identifier array-name)] (do meta.monad [array-type (meta.find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] [ (wrap (list (` ( (~ array) (~ idx)))))]) (["[Z" "jvm zaload"] ["[B" "jvm baload"] ["[S" "jvm saload"] ["[I" "jvm iaload"] ["[J" "jvm jaload"] ["[F" "jvm faload"] ["[D" "jvm daload"] ["[C" "jvm caload"]) _ (wrap (list (` ("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 [_ (#.Identifier array-name)] (do meta.monad [array-type (meta.find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type (^template [ ] [ (wrap (list (` ( (~ array) (~ idx) (~ value)))))]) (["[Z" "jvm zastore"] ["[B" "jvm bastore"] ["[S" "jvm sastore"] ["[I" "jvm iastore"] ["[J" "jvm jastore"] ["[F" "jvm fastore"] ["[D" "jvm dastore"] ["[C" "jvm castore"]) _ (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) _ (with-gensyms [g!array] (wrap (list (` (let [(~ g!array) (~ array)] (..array-write (~ idx) (~ value) (~ g!array))))))))) (syntax: #export (class-for {type (..generic-type^ (list))}) {#.doc (doc "Loads the class as a java.lang.Class object." (class-for java/lang/String))} (wrap (list (` ("jvm object class" (~ (code.text (simple-class$ (list) type)))))))) (syntax: #export (type {type (..generic-type^ (list))}) (wrap (list (class->type #ManualPrM (list) type))))