diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/format/binary.lux | 70 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/attribute.lux | 281 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/class.lux | 83 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/constant/pool.lux | 92 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/field.lux | 41 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/index.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/method.lux | 40 | ||||
| -rw-r--r-- | stdlib/source/test/lux/target/jvm.lux | 6 |
8 files changed, 498 insertions, 125 deletions
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index 771d9f693..4a2909272 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -7,8 +7,10 @@ [equivalence (#+ Equivalence)]] [control ["." parser (#+ Parser) ("#;." functor)] + ["." function] ["ex" exception (#+ exception:)]] [data + ["." product] ["." error (#+ Error)] [number ["." i64] @@ -48,11 +50,11 @@ (Parser [Offset Binary])) (type: #export Mutation - [Size (-> Offset Binary Binary)]) + [Size (-> [Offset Binary] [Offset Binary])]) (def: #export no-op Mutation - [0 (function (_ offset data) data)]) + [0 function.identity]) (structure: #export monoid (Monoid Mutation) @@ -61,10 +63,7 @@ (def: (compose [sizeL mutL] [sizeR mutR]) [(n/+ sizeL sizeR) - (function (_ offset data) - (|> data - (mutL offset) - (mutR (n/+ sizeL offset))))])) + (|>> mutL mutR)])) (type: #export (Writer a) (-> a Mutation)) @@ -98,7 +97,7 @@ (def: #export (write format value) (All [a] (-> (Format a) a Binary)) (let [[valueS valueT] ((get@ #writer format) value)] - (|> valueS binary.create (valueT 0)))) + (|> valueS binary.create [0] valueT product.right))) (template [<name> <size> <read> <write>] [(def: #export <name> @@ -112,10 +111,11 @@ (#error.Failure error))) #writer (function (_ value) [<size> - (function (_ offset binary) - (|> binary - (<write> offset value) - error.assume))])})] + (function (_ [offset binary]) + [(n/+ <size> offset) + (|> binary + (<write> offset value) + error.assume)])])})] [bits/8 size/8 binary.read/8 binary.write/8] [bits/16 size/16 binary.read/16 binary.write/16] @@ -136,32 +136,31 @@ (#.Left leftV) (let [[leftS leftT] ((get@ #writer leftB) leftV)] [(.inc leftS) - (function (_ offset binary) + (function (_ [offset binary]) (|> binary (binary.write/8 offset 0) error.assume - (leftT (.inc offset))))]) + [(.inc offset)] + leftT))]) (#.Right rightV) (let [[rightS rightT] ((get@ #writer rightB) rightV)] [(.inc rightS) - (function (_ offset binary) + (function (_ [offset binary]) (|> binary (binary.write/8 offset 1) error.assume - (rightT (.inc offset))))]) + [(.inc offset)] + rightT))]) ))}) (def: #export (and preB postB) (All [a b] (-> (Format a) (Format b) (Format [a b]))) {#reader (parser.and (get@ #reader preB) (get@ #reader postB)) #writer (function (_ [preV postV]) - (let [[preS preT] ((get@ #writer preB) preV) - [postS postT] ((get@ #writer postB) postV)] - [(n/+ preS postS) - (function (_ offset) - (|>> (preT offset) - (postT (n/+ preS offset))))]))}) + (:: ..monoid compose + ((get@ #writer preB) preV) + ((get@ #writer postB) postV)))}) (def: #export (rec body) (All [a] (-> (-> (Format a) (Format a)) (Format a))) @@ -201,10 +200,11 @@ (#error.Failure error))) #writer (function (_ value) [1 - (function (_ offset binary) - (|> binary - (binary.write/8 offset (if value 1 0)) - error.assume))])}) + (function (_ [offset binary]) + [(n/+ 1 offset) + (|> binary + (binary.write/8 offset (if value 1 0)) + error.assume)])])}) (def: #export nat (Format Nat) (:assume ..bits/64)) (def: #export int (Format Int) (:assume ..bits/64)) @@ -230,13 +230,15 @@ output (binary.slice offset (.dec end) binary)] (wrap [[end binary] output])))) #writer (function (_ value) - (let [size (|> value binary.size (i64.and mask))] - [(n/+ <size> size) - (function (_ offset binary) - (error.assume - (do error.monad - [_ (<write> offset size binary)] - (binary.copy size 0 value (n/+ <size> offset) binary))))]))}))] + (let [size (|> value binary.size (i64.and mask)) + size' (n/+ <size> size)] + [size' + (function (_ [offset binary]) + [(n/+ size' offset) + (error.assume + (do error.monad + [_ (<write> offset size binary)] + (binary.copy size 0 value (n/+ <size> offset) binary)))])]))}))] [binary/8 ..bits/8 ..size/8 binary.write/8] [binary/16 ..bits/16 ..size/16 binary.write/16] @@ -296,11 +298,11 @@ (mutation;compose pre post)) mutation;identity))] [(n/+ <size> size) - (function (_ offset binary) + (function (_ [offset binary]) (error.assume (do error.monad [_ (<write> offset (n/+ extra-count capped-count) binary)] - (wrap (mutation (n/+ <size> offset) binary)))))]))}) + (wrap (mutation [(n/+ <size> offset) binary])))))]))}) (def: #export <name> (All [v] (-> (Format v) (Format (Row v)))) diff --git a/stdlib/source/lux/target/jvm/attribute.lux b/stdlib/source/lux/target/jvm/attribute.lux index 024f0ec3f..c867f1e57 100644 --- a/stdlib/source/lux/target/jvm/attribute.lux +++ b/stdlib/source/lux/target/jvm/attribute.lux @@ -1,17 +1,21 @@ (.module: [lux (#- Info Code' Code) [abstract - ["." equivalence (#+ Equivalence)] - [monad (#+ do)]] + [monad (#+ do)] + ["." equivalence (#+ Equivalence)]] [control - ["." state (#+ State)]] + ["." state (#+ State)] + ["." exception (#+ exception:)] + ["<>" parser]] [data + ["." product] + ["." error] [format - ["." binary (#+ Format)]] + [".F" binary (#+ Reader Writer Format) ("#@." monoid)]] [collection - ["." row (#+ Row)]]] + ["." row (#+ Row) ("#@." functor fold)]]] [world - [binary (#+ Binary)]]] + ["." binary (#+ Binary)]]] ["." // #_ ["#." encoding (#+ U2 U4)] ["#." index (#+ Index)] @@ -32,34 +36,62 @@ //encoding.u4-equivalence Equivalence<about>)) -(def: (info-format about) +(def: (info-writer writer) (All [about] - (-> (Format about) - (Format (Info about)))) - ($_ binary.and - //index.format - //encoding.u4-format - about)) + (-> (Writer about) + (Writer (Info about)))) + (function (_ [name length info]) + (let [[nameS nameT] ((get@ #binaryF.writer //index.format) name) + [lengthS lengthT] ((get@ #binaryF.writer //encoding.u4-format) length) + [infoS infoT] (writer info)] + [($_ n/+ nameS lengthS infoS) + (|>> nameT lengthT infoT)]))) (type: #export Constant - (Info (Index (Value Any)))) + (Index (Value Any))) (def: #export constant-equivalence (Equivalence Constant) - (..info-equivalence //index.equivalence)) + //index.equivalence) (def: constant-format (Format Constant) - (..info-format //index.format)) + //index.format) (type: #export Label U2) +(def: #export label-equivalence + (Equivalence Label) + //encoding.u2-equivalence) + +(def: #export label-format + (Format Label) + //encoding.u2-format) + (type: #export Exception {#start-pc Label #end-pc Label #handler-pc Label #catch-type (Index Class)}) +(def: #export exception-equivalence + (Equivalence Exception) + ($_ equivalence.product + ..label-equivalence + ..label-equivalence + ..label-equivalence + //index.equivalence + )) + +(def: exception-format + (Format Exception) + ($_ binaryF.and + ..label-format + ..label-format + ..label-format + //index.format + )) + (type: #export (Code' Attribute) {#max-stack U2 #max-locals U2 @@ -67,37 +99,204 @@ #exception-table (Row Exception) #attributes (Row Attribute)}) -(with-expansions [<Code> (as-is (Info (Code' Attribute)))] +(def: (code'-equivalence attribute-equivalence) + (All [attribute] + (-> (Equivalence attribute) (Equivalence (Code' attribute)))) + ($_ equivalence.product + //encoding.u2-equivalence + //encoding.u2-equivalence + binary.equivalence + (row.equivalence ..exception-equivalence) + (row.equivalence attribute-equivalence) + )) + +(with-expansions [<Code> (as-is (Code' Attribute))] (type: #export #rec Attribute - (#Constant Constant) - ## (#Code <Code>) - ) + (#Constant (Info Constant)) + (#Code (Info <Code>))) - ## (type: #export Code - ## <Code>) + (type: #export Code + <Code>) ) +## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 +(def: (code-reader reader) + (-> (Reader Attribute) (Reader Code)) + (let [u2-reader (get@ #binaryF.reader + //encoding.u2-format)] + ($_ <>.and + ## u2 max_stack; + u2-reader + ## u2 max_locals; + u2-reader + ## u4 code_length; + ## u1 code[code_length]; + (get@ #binaryF.reader + binaryF.binary/32) + ## u2 exception_table_length; + ## exception_table[exception_table_length]; + (get@ #binaryF.reader + (binaryF.row/16 ..exception-format)) + ## u2 attributes_count; + ## attribute_info attributes[attributes_count]; + (get@ #binaryF.reader + (binaryF.row/16 {#binaryF.reader reader + ## TODO: Get rid of this dirty hack ASAP + #binaryF.writer (function (_ _value) + binaryF.no-op)})) + ))) + (def: #export equivalence (Equivalence Attribute) - ..constant-equivalence) + (equivalence.rec + (function (_ equivalence) + ($_ equivalence.sum + (info-equivalence ..constant-equivalence) + (info-equivalence (..code'-equivalence equivalence)))))) + +(def: #export code-equivalence + (Equivalence Code) + (code'-equivalence ..equivalence)) + +## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 +(def: exception-frame-length + ($_ n/+ + ## u2 start_pc; + //encoding.u2-bytes + ## u2 end_pc; + //encoding.u2-bytes + ## u2 handler_pc; + //encoding.u2-bytes + ## u2 catch_type; + //encoding.u2-bytes + )) + +(def: fixed-attribute-length + ($_ n/+ + ## u2 attribute_name_index; + //encoding.u2-bytes + ## u4 attribute_length; + //encoding.u4-bytes + )) + +(def: constant-length + //encoding.u2-bytes) + +(def: (length attribute) + (-> Attribute Nat) + (case attribute + (^template [<tag>] + (<tag> [name length info]) + (|> length //encoding.from-u4 .nat (n/+ fixed-attribute-length))) + ([#Constant] [#Code]))) + +(def: constant-name "ConstantValue") + +(def: (constant' @name index) + (-> (Index UTF8) Constant Attribute) + (#Constant {#name @name + #length (//encoding.to-u4 ..constant-length) + #info index})) (def: #export (constant index) - (-> (Index (Value Any)) - (State Pool Attribute)) + (-> Constant (State Pool Attribute)) + (do state.monad + [@name (//constant/pool.utf8 ..constant-name)] + (wrap (constant' @name index)))) + +(def: code-name "Code") + +(def: (code' @name specification) + (-> (Index UTF8) Code Attribute) + (#Code {#name @name + ## https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 + #length (//encoding.to-u4 + ($_ n/+ + ## u2 max_stack; + //encoding.u2-bytes + ## u2 max_locals; + //encoding.u2-bytes + ## u4 code_length; + //encoding.u4-bytes + ## u1 code[code_length]; + (binary.size (get@ #code specification)) + ## u2 exception_table_length; + //encoding.u2-bytes + ## exception_table[exception_table_length]; + (|> specification + (get@ #exception-table) + row.size + (n/* exception-frame-length)) + ## u2 attributes_count; + //encoding.u2-bytes + ## attribute_info attributes[attributes_count]; + (|> specification + (get@ #attributes) + (row@map ..length) + (row@fold n/+ 0)))) + #info specification})) + +(def: #export (code specification) + (-> Code (State Pool Attribute)) (do state.monad - [@name (//constant/pool.utf8 "ConstantValue")] - (wrap {#name @name - #length (//encoding.to-u4 //encoding.u2-bytes) - #info index}))) - -## (def: #export (code specification) -## (-> Code' (State Pool Attribute)) -## (do state.monad -## [@name (//constant/pool.utf8 "Code")] -## (wrap (#Code {#name @name -## #length (undefined) -## #info specification})))) - -(def: #export format - (Format Attribute) - ..constant-format) + [@name (//constant/pool.utf8 ..code-name)] + (wrap (code' @name specification)))) + +(exception: #export invalid-attribute) + +(def: #export (reader pool) + (-> Pool (Reader Attribute)) + (let [?@constant (|> ..constant-name + //constant/pool.find-utf8 + (state.run pool) + product.right) + ?@code (|> ..code-name + //constant/pool.find-utf8 + (state.run pool) + product.right) + (^open "_@.") (error.equivalence //index.equivalence)] + (<>.rec + (function (_ reader) + (do <>.monad + [@name (get@ #binaryF.reader //index.format) + length (get@ #binaryF.reader //encoding.u4-format)] + (cond (_@= ?@constant (#error.Success @name)) + (:: @ map (..constant' @name) (get@ #binaryF.reader ..constant-format)) + + (_@= ?@code (#error.Success @name)) + (:: @ map (..code' @name) (code-reader reader)) + + ## else + (<>.fail (exception.construct ..invalid-attribute [])))))))) + +(def: constant-writer + (Writer Constant) + (get@ #binaryF.writer //index.format)) + +(def: (code-writer' writer code) + (-> (Writer Attribute) (Writer Code)) + (let [format (: (Format Attribute) + {## TODO: Get rid of this dirty hack ASAP + #binaryF.reader (<>.fail "") + #binaryF.writer writer})] + ($_ binaryF@compose + ((get@ #binaryF.writer //encoding.u2-format) + (get@ #max-stack code)) + ((get@ #binaryF.writer //encoding.u2-format) + (get@ #max-locals code)) + ((get@ #binaryF.writer binaryF.binary/32) + (get@ #code code)) + ((get@ #binaryF.writer (binaryF.row/16 exception-format)) + (get@ #exception-table code)) + ((get@ #binaryF.writer (binaryF.row/16 format)) + (get@ #attributes code)) + ))) + +(def: #export (writer value) + (Writer Attribute) + (case value + (#Constant attribute) + ((info-writer constant-writer) attribute) + + (#Code attribute) + ((info-writer (code-writer' writer)) attribute))) diff --git a/stdlib/source/lux/target/jvm/class.lux b/stdlib/source/lux/target/jvm/class.lux index 15b2f5392..4677f33e4 100644 --- a/stdlib/source/lux/target/jvm/class.lux +++ b/stdlib/source/lux/target/jvm/class.lux @@ -1,17 +1,17 @@ (.module: [lux #* [abstract - ["." equivalence (#+ Equivalence)] [monoid (#+)] + ["." equivalence (#+ Equivalence)] ["." monad (#+ do)]] [control - [parser (#+)] + ["<>" parser] ["." state (#+ State)]] [data [number (#+) [i64 (#+)]] [format - ["." binary (#+ Format)]] + [".F" binary (#+ Reader Writer Format) ("#@." monoid)]] [collection ["." row (#+ Row)]]] [type @@ -112,17 +112,70 @@ #methods methods #attributes attributes})) +(def: #export reader + (Reader Class) + (do <>.monad + [magic (get@ #binaryF.reader //magic.format) + minor-version (get@ #binaryF.reader //version.format) + major-version (get@ #binaryF.reader //version.format) + constant-pool (get@ #binaryF.reader //constant/pool.format) + modifier (get@ #binaryF.reader ..modifier-format) + this (get@ #binaryF.reader //index.format) + super (get@ #binaryF.reader //index.format) + interfaces (get@ #binaryF.reader (binaryF.row/16 //index.format)) + fields (get@ #binaryF.reader (binaryF.row/16 (: (Format Field) + {#binaryF.reader (//field.reader constant-pool) + ## TODO: Get rid of this dirty hack ASAP + #binaryF.writer (function (_ _) binaryF.no-op)}))) + methods (get@ #binaryF.reader (binaryF.row/16 (: (Format Method) + {#binaryF.reader (//method.reader constant-pool) + ## TODO: Get rid of this dirty hack ASAP + #binaryF.writer (function (_ _) binaryF.no-op)}))) + attributes (get@ #binaryF.reader (binaryF.row/16 (: (Format Attribute) + {#binaryF.reader (//attribute.reader constant-pool) + ## TODO: Get rid of this dirty hack ASAP + #binaryF.writer (function (_ _) binaryF.no-op)})))] + (wrap {#magic magic + #minor-version minor-version + #major-version major-version + #constant-pool constant-pool + #modifier modifier + #this this + #super super + #interfaces interfaces + #fields fields + #methods methods + #attributes attributes}))) + +(def: #export (writer class) + (Writer Class) + (`` ($_ binaryF@compose + (~~ (template [<format> <slot>] + [((get@ #binaryF.writer <format>) (get@ <slot> class))] + + [//magic.format #magic] + [//version.format #minor-version] + [//version.format #major-version] + [//constant/pool.format #constant-pool] + [..modifier-format #modifier] + [//index.format #this] + [//index.format #super] + [(binaryF.row/16 //index.format) #interfaces])) + (~~ (template [<type> <writer> <slot>] + [((get@ #binaryF.writer + (binaryF.row/16 (: (Format <type>) + {## TODO: Get rid of this dirty hack ASAP + #binaryF.reader (<>.fail "") + #binaryF.writer <writer>}))) + (get@ <slot> class))] + + [Field //field.writer #fields] + [Method //method.writer #methods] + [Attribute //attribute.writer #attributes] + )) + ))) + (def: #export format (Format Class) - ($_ binary.and - //magic.format - //version.format - //version.format - //constant/pool.format - ..modifier-format - //index.format - //index.format - (binary.row/16 //index.format) - (binary.row/16 //field.format) - (binary.row/16 //method.format) - (binary.row/16 //attribute.format))) + {#binaryF.reader ..reader + #binaryF.writer ..writer}) diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux index a304d5ac4..8fbf5550e 100644 --- a/stdlib/source/lux/target/jvm/constant/pool.lux +++ b/stdlib/source/lux/target/jvm/constant/pool.lux @@ -4,9 +4,12 @@ ["." equivalence (#+ Equivalence)] [monad (#+ do)]] [control - ["." state (#+ State)]] + ["." state (#+ State)] + ["." exception (#+ exception:)]] [data - ["." text ("#;." equivalence)] + ["." error (#+ Error)] + ["." text ("#;." equivalence) + ["%" format]] [format ["." binary (#+ Format)]] [collection @@ -28,7 +31,7 @@ (Equivalence Pool) (row.equivalence //.equivalence)) -(template: (!add <value> <tag> <=>) +(template: (!add <tag> <=> <value>) (function (_ pool) (with-expansions [<index> (as-is (index.index (encoding.to-u2 (n/+ offset idx)))) <try-again> (as-is (recur (.inc idx)))] @@ -49,13 +52,86 @@ [(row.add (<tag> <value>) pool) <index>]))))) +(template: (!raw-index <index>) + (|> <index> index.number encoding.from-u2 .nat)) + +(exception: #export (invalid-index {index (Index Any)} + {maximum Nat}) + (exception.report + ["Index" (|> index !raw-index %.%n)] + ["Maximum" (%.%n maximum)])) + +(exception: #export (invalid-constant {index (Index Any)} + {tag Name}) + (exception.report + ["Index" (|> index !raw-index %.%n)] + ["Expected tag" (%.%name tag)])) + +(template: (!fetch <tag> <index>) + (function (_ pool) + (case (row.nth (|> <index> !raw-index (n/- offset)) + pool) + (#.Some entry) + (case entry + (<tag> value) + [pool (#error.Success value)] + + _ + [pool (exception.throw ..invalid-constant [<index> (name-of <tag>)])]) + + #.None + [pool (exception.throw ..invalid-index [<index> (row.size pool)])]))) + +(exception: #export (cannot-find {tag Name} {value Text}) + (exception.report + ["Expected tag" (%.%name tag)] + ["Value" value])) + +(template: (!find <tag> <=> <%> <expected>) + (function (_ pool) + (with-expansions [<index> (as-is (index.index (encoding.to-u2 (n/+ offset idx)))) + <try-again> (as-is (recur (.inc idx)))] + (loop [idx 0] + (case (row.nth idx pool) + (#.Some entry) + (case entry + (<tag> actual) + (if (<=> actual <expected>) + [pool + (#error.Success <index>)] + <try-again>) + + _ + <try-again>) + + #.None + [pool + (exception.throw ..cannot-find [(name-of <tag>) (<%> <expected>)])]))))) + +(type: (Adder of) + (-> of (State Pool (Index of)))) + +(type: (Fetcher of) + (-> (Index of) (State Pool (Error of)))) + +(type: (Finder of) + (-> of (State Pool (Error (Index of))))) + (def: #export (utf8 value) - (-> UTF8 (State Pool (Index UTF8))) - (!add value #//.UTF8 text;=)) + (Adder UTF8) + (!add #//.UTF8 text;= value)) + +(def: #export (fetch-utf8 index) + (Fetcher UTF8) + (!fetch #//.UTF8 index)) + +(def: #export (find-utf8 reference) + (Finder UTF8) + (!find #//.UTF8 text;= %.%t reference)) (def: (class' value) - (-> Class (State Pool (Index Class))) - (!add value #//.Class //;=)) + (Adder Class) + (!add #//.Class //;= value)) (def: #export (class name) (-> UTF8 (State Pool (Index Class))) @@ -68,7 +144,7 @@ (-> (Descriptor kind) (State Pool (Index (Descriptor kind))))) (let [value (descriptor.descriptor value)] - (!add value #//.UTF8 text;=))) + (!add #//.UTF8 text;= value))) (def: #export format (Format Pool) diff --git a/stdlib/source/lux/target/jvm/field.lux b/stdlib/source/lux/target/jvm/field.lux index 930ca97d8..2e0082fe2 100644 --- a/stdlib/source/lux/target/jvm/field.lux +++ b/stdlib/source/lux/target/jvm/field.lux @@ -1,17 +1,17 @@ (.module: [lux (#- static) [abstract - ["." equivalence (#+ Equivalence)] [monoid (#+)] + ["." equivalence (#+ Equivalence)] ["." monad (#+ do)]] [control - [parser (#+)] - ["." state (#+ State)]] + ["." state (#+ State)] + ["<>" parser]] [data [number (#+) [i64 (#+)]] [format - ["." binary (#+ Format)]] + [".F" binary (#+ Reader Writer Format) ("#@." monoid)]] [collection ["." row (#+ Row)]]] [type @@ -51,13 +51,32 @@ //index.equivalence (row.equivalence //attribute.equivalence))) -(def: #export format - (Format Field) - ($_ binary.and - ..modifier-format - //index.format - //index.format - (binary.row/16 //attribute.format))) +(def: #export (reader pool) + (-> Pool (Reader Field)) + ($_ <>.and + (get@ #binaryF.reader ..modifier-format) + (get@ #binaryF.reader //index.format) + (get@ #binaryF.reader //index.format) + (get@ #binaryF.reader + (binaryF.row/16 {#binaryF.reader (//attribute.reader pool) + ## TODO: Get rid of this dirty hack ASAP + #binaryF.writer (function (_ _) binaryF.no-op)})))) + +(def: #export (writer field) + (Writer Field) + (let [attribute-format (: (Format Attribute) + {## TODO: Get rid of this dirty hack ASAP + #binaryF.reader (<>.fail "") + #binaryF.writer //attribute.writer})] + (`` ($_ binaryF@compose + (~~ (template [<format> <slot>] + [((get@ #binaryF.writer <format>) (get@ <slot> field))] + + [..modifier-format #modifier] + [//index.format #name] + [//index.format #descriptor] + [(binaryF.row/16 attribute-format) #attributes])) + )))) (def: #export (field modifier name descriptor attributes) (-> Modifier UTF8 (Descriptor (Value Any)) (Row Attribute) diff --git a/stdlib/source/lux/target/jvm/index.lux b/stdlib/source/lux/target/jvm/index.lux index 3a425dd32..6e3d070ff 100644 --- a/stdlib/source/lux/target/jvm/index.lux +++ b/stdlib/source/lux/target/jvm/index.lux @@ -19,15 +19,19 @@ (All [kind] (-> U2 (Index kind))) (|>> :abstraction)) + (def: #export number + (-> (Index Any) U2) + (|>> :representation)) + (def: #export equivalence (All [kind] (Equivalence (Index kind))) (:: equivalence.contravariant map-1 - (|>> :representation) + ..number //encoding.u2-equivalence)) (def: #export format (All [kind] (Format (Index kind))) - (binary.adapt (|>> :abstraction) - (|>> :representation) + (binary.adapt ..index + ..number //encoding.u2-format)) ) diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux index e4f3cdea2..0141e0a2b 100644 --- a/stdlib/source/lux/target/jvm/method.lux +++ b/stdlib/source/lux/target/jvm/method.lux @@ -5,13 +5,13 @@ [monoid (#+)] ["." monad (#+ do)]] [control - [parser (#+)] + ["<>" parser] ["." state (#+ State)]] [data [number (#+) [i64 (#+)]] [format - ["." binary (#+ Format)]] + [".F" binary (#+ Reader Writer Format) ("#@." monoid)]] [collection ["." row (#+ Row)]]] [type @@ -19,7 +19,8 @@ ["." // #_ [encoding (#+)] [modifier (#+ modifiers:)] - ["#." constant (#+ UTF8)] + ["#." constant (#+ UTF8) + [pool (#+ Pool)]] ["#." index (#+ Index)] ["#." attribute (#+ Attribute)] ["#." descriptor (#+ Descriptor)]]) @@ -53,10 +54,29 @@ //index.equivalence (row.equivalence //attribute.equivalence))) -(def: #export format - (Format Method) - ($_ binary.and - ..modifier-format - //index.format - //index.format - (binary.row/16 //attribute.format))) +(def: #export (reader pool) + (-> Pool (Reader Method)) + ($_ <>.and + (get@ #binaryF.reader ..modifier-format) + (get@ #binaryF.reader //index.format) + (get@ #binaryF.reader //index.format) + (get@ #binaryF.reader + (binaryF.row/16 {#binaryF.reader (//attribute.reader pool) + ## TODO: Get rid of this dirty hack ASAP + #binaryF.writer (function (_ _) binaryF.no-op)})))) + +(def: #export (writer field) + (Writer Method) + (let [attribute-format (: (Format Attribute) + {## TODO: Get rid of this dirty hack ASAP + #binaryF.reader (<>.fail "") + #binaryF.writer //attribute.writer})] + (`` ($_ binaryF@compose + (~~ (template [<format> <slot>] + [((get@ #binaryF.writer <format>) (get@ <slot> field))] + + [..modifier-format #modifier] + [//index.format #name] + [//index.format #descriptor] + [(binaryF.row/16 attribute-format) #attributes])) + )))) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 191af99a7..acef6060f 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -12,7 +12,7 @@ ["." text format] [format - ["." binary]] + [".F" binary]] [collection ["." dictionary] ["." row]]] @@ -94,11 +94,11 @@ (/field.field /field.public field1 descriptor1 (row.row))) (row.row) (row.row)) - bytecode (binary.write /class.format input) + bytecode (binaryF.write /class.format input) loader (/loader.memory (/loader.new-library []))]] ($_ _.and (_.test "Can read a generated class." - (case (binary.read /class.format bytecode) + (case (binaryF.read /class.format bytecode) (#error.Success output) (:: /class.equivalence = input output) |