From 5c270277bde8ee70e065173ebb6b95aab5223de8 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 26 Dec 2018 17:38:50 -0400
Subject: WIP: JVM bytecode generation in pure Lux.

---
 stdlib/source/lux/data/format/binary.lux    | 62 +++++++++++++++-----------
 stdlib/source/lux/host/jvm.lux              | 69 +++++++++++++++++++++++++++++
 stdlib/source/lux/host/jvm/access.lux       | 57 ++++++++++++++++++++++++
 stdlib/source/lux/host/jvm/constant.lux     | 43 ++++++++++++++++++
 stdlib/source/lux/host/jvm/constant/tag.lux | 49 ++++++++++++++++++++
 stdlib/source/lux/host/jvm/encoding.lux     | 49 ++++++++++++++++++++
 stdlib/source/lux/host/jvm/index.lux        | 17 +++++++
 stdlib/source/lux/host/jvm/magic.lux        | 19 ++++++++
 stdlib/source/lux/host/jvm/name.lux         | 30 +++++++++++++
 stdlib/source/lux/host/jvm/version.lux      | 38 ++++++++++++++++
 10 files changed, 406 insertions(+), 27 deletions(-)
 create mode 100644 stdlib/source/lux/host/jvm.lux
 create mode 100644 stdlib/source/lux/host/jvm/access.lux
 create mode 100644 stdlib/source/lux/host/jvm/constant.lux
 create mode 100644 stdlib/source/lux/host/jvm/constant/tag.lux
 create mode 100644 stdlib/source/lux/host/jvm/encoding.lux
 create mode 100644 stdlib/source/lux/host/jvm/index.lux
 create mode 100644 stdlib/source/lux/host/jvm/magic.lux
 create mode 100644 stdlib/source/lux/host/jvm/name.lux
 create mode 100644 stdlib/source/lux/host/jvm/version.lux

diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
index f6145f59f..1be3e7a52 100644
--- a/stdlib/source/lux/data/format/binary.lux
+++ b/stdlib/source/lux/data/format/binary.lux
@@ -219,25 +219,24 @@
 (do-template [<name> <bits> <size> <write>]
   [(def: #export <name>
      (Format Binary)
-     {#reader (do parser.Monad<Parser>
-                [size (:coerce (Reader Nat)
-                               ## TODO: Remove coercion.
-                               (get@ #reader <bits>))]
-                (function (_ [offset binary])
-                  (do error.Monad<Error>
-                    [#let [end (n/+ size offset)]
-                     output (binary.slice offset end binary)]
-                    (wrap [[end binary] output]))))
-      #writer (function (_ value)
-                (let [size (|> value
-                               binary.size
-                               (i64.and (..mask <size>)))]
-                  [(n/+ <size> size)
-                   (function (_ offset binary)
-                     (error.assume
-                      (do error.Monad<Error>
-                        [_ (<write> offset size binary)]
-                        (binary.copy size 0 value (n/+ <size> offset) binary))))]))})]
+     (let [mask (..mask <size>)]
+       {#reader (do parser.Monad<Parser>
+                  [size (:coerce (Reader Nat)
+                                 ## TODO: Remove coercion.
+                                 (get@ #reader <bits>))]
+                  (function (_ [offset binary])
+                    (do error.Monad<Error>
+                      [#let [end (n/+ size offset)]
+                       output (binary.slice offset 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<Error>
+                          [_ (<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]
@@ -245,6 +244,23 @@
   [binary/64 ..bits/64 ..size/64 binary.write/64]
   )
 
+(do-template [<name> <binary>]
+  [(def: #export <name>
+     (Format Text)
+     (let [(^open "binary/.") <binary>]
+       {#reader (do parser.Monad<Parser>
+                  [utf8 binary/reader]
+                  (parser.lift (encoding.from-utf8 utf8)))
+        #writer (|>> encoding.to-utf8 binary/writer)}))]
+
+  [utf8/8  ..binary/8]
+  [utf8/16 ..binary/16]
+  [utf8/32 ..binary/32]
+  [utf8/64 ..binary/64]
+  )
+
+(def: #export text ..utf8/64)
+
 (do-template [<name> <with-offset> <bits> <size> <write>]
   [(def: #export (<with-offset> extra-count valueF)
      (All [v] (-> Nat (Format v) (Format (Row v))))
@@ -296,14 +312,6 @@
   [row/64 row/64' ..bits/64 ..size/64 binary.write/64]
   )
 
-(def: #export text
-  (Format Text)
-  (let [(^slots [#reader #writer]) ..binary/64]
-    {#reader (do parser.Monad<Parser>
-               [utf8 reader]
-               (parser.lift (encoding.from-utf8 utf8)))
-     #writer (|>> encoding.to-utf8 writer)}))
-
 (def: #export maybe
   (All [a] (-> (Format a) (Format (Maybe a))))
   (..or ..any))
diff --git a/stdlib/source/lux/host/jvm.lux b/stdlib/source/lux/host/jvm.lux
new file mode 100644
index 000000000..bf9688d66
--- /dev/null
+++ b/stdlib/source/lux/host/jvm.lux
@@ -0,0 +1,69 @@
+(.module:
+  [lux (#- Name)
+   [data
+    [format
+     ["." binary (#+ Format)]]
+    [collection
+     ["." row (#+ Row)]]]]
+  [/
+   ["/." version (#+ Version Minor Major)]
+   ["/." name (#+ Name)]
+   ["/." access (#+ Access)]
+   ["/." magic (#+ Magic)]
+   ["/." constant (#+ Constant)]
+   ["/." index (#+ Index)]])
+
+(type: #export Field
+  Any)
+
+(type: #export Method
+  Any)
+
+(type: #export Attribute
+  Any)
+
+(type: #export Class
+  {#magic Magic
+   #minor-version Minor
+   #major-version Major
+   #constant-pool (Row Constant)
+   #access-flags Access
+   #this Index
+   #super Index
+   #interfaces (Row Index)
+   #fields (Row Field)
+   #methods (Row Method)
+   #attributes (Row Attribute)})
+
+(def: #export (class version access super this)
+  (-> Major Access Name Name Class)
+  {#magic /magic.code
+   #minor-version (/version.version 0)
+   #major-version version
+   #constant-pool (|> row.empty
+                      (row.add (#/constant.UTF8 (/name.read this)))
+                      (row.add (#/constant.Class (/index.index 1)))
+                      (row.add (#/constant.UTF8 (/name.read super)))
+                      (row.add (#/constant.Class (/index.index 3))))
+   #access-flags access
+   #this (/index.index 2)
+   #super (/index.index 4)
+   #interfaces row.empty
+   #fields row.empty
+   #methods row.empty
+   #attributes row.empty})
+
+(def: #export classF
+  (Format Class)
+  ($_ binary.and
+      /magic.format
+      /version.format
+      /version.format
+      (binary.row/16' 1 /constant.format)
+      /access.format
+      /index.format
+      /index.format
+      (binary.row/16 (binary.ignore (/index.index 0)))
+      (binary.row/16 (binary.ignore []))
+      (binary.row/16 (binary.ignore []))
+      (binary.row/16 (binary.ignore []))))
diff --git a/stdlib/source/lux/host/jvm/access.lux b/stdlib/source/lux/host/jvm/access.lux
new file mode 100644
index 000000000..f0d088a97
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/access.lux
@@ -0,0 +1,57 @@
+(.module:
+  [lux #*
+   [control
+    [monoid (#+ Monoid)]
+    [parser ("parser/." Functor<Parser>)]]
+   [data
+    [number (#+ hex)
+     ["." i64]]
+    [format
+     ["." binary (#+ Format)]]]
+   [type
+    abstract]]
+  [//
+   ["//." encoding (#+ U2)]])
+
+(abstract: #export Access
+  {}
+
+  U2
+
+  (def: #export code
+    (-> Access U2)
+    (|>> :representation))
+
+  (def: #export (combine parameter subject)
+    (-> Access Access Access)
+    (let [parameter' (//encoding.from-u2 (:representation parameter))
+          subject' (//encoding.from-u2 (:representation subject))]
+      (:abstraction (//encoding.to-u2 (i64.and parameter'
+                                               subject')))))
+
+  (do-template [<name> <code>]
+    [(def: #export <name>
+       Access
+       (|> (hex <code>) //encoding.to-u2 :abstraction))]
+
+    [empty      "0000"]
+    [public     "0001"]
+    [final      "0010"]
+    [super      "0020"]
+    [interface  "0200"]
+    [abstract   "0400"]
+    [synthetic  "1000"]
+    [annotation "2000"]
+    [enum       "4000"]
+    )
+
+  (def: #export format
+    (Format Access)
+    (let [(^open "_/.") //encoding.u2-format]
+      {#binary.reader (|> _/reader (parser/map (|>> :abstraction)))
+       #binary.writer (|>> :representation _/writer)}))
+  )
+
+(structure: #export _ (Monoid Access)
+  (def: identity ..empty)
+  (def: compose ..combine))
diff --git a/stdlib/source/lux/host/jvm/constant.lux b/stdlib/source/lux/host/jvm/constant.lux
new file mode 100644
index 000000000..d20e34d31
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/constant.lux
@@ -0,0 +1,43 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ do)]
+    ["." parser]]
+   [data
+    [format
+     ["." binary (#+ Format) ("mutation/." Monoid<Mutation>)]]
+    [collection
+     ["." row (#+ Row)]]]
+   [type
+    abstract]]
+  [//
+   ["//." index (#+ Index)]]
+  [/
+   ["/." tag ("tag/." Equivalence<Tag>)]])
+
+(type: #export Constant
+  (#UTF8 Text)
+  (#Class Index))
+
+(def: #export format
+  (Format Constant)
+  (with-expansions [<constants> (as-is [#UTF8  /tag.utf8  binary.utf8/16]
+                                       [#Class /tag.class //index.format])]
+    {#binary.reader (do parser.Monad<Parser>
+                      [tag (get@ #binary.reader /tag.format)]
+                      (`` (cond (~~ (do-template [<case> <tag> <format>]
+                                      [(tag/= <tag> tag)
+                                       (:: @ map (|>> <case>) (get@ #binary.reader <format>))]
+
+                                      <constants>))
+                                
+                                ## else
+                                (parser.fail "Cannot parse constant."))))
+     #binary.writer (function (_ value)
+                      (case value
+                        (^template [<case> <tag> <format>]
+                          (<case> value)
+                          (mutation/compose ((get@ #binary.writer /tag.format) <tag>)
+                                            ((get@ #binary.writer <format>) value)))
+                        (<constants>)
+                        ))}))
diff --git a/stdlib/source/lux/host/jvm/constant/tag.lux b/stdlib/source/lux/host/jvm/constant/tag.lux
new file mode 100644
index 000000000..57fd6d92e
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/constant/tag.lux
@@ -0,0 +1,49 @@
+(.module:
+  [lux #*
+   [control
+    [equivalence (#+ Equivalence)]]
+   [data
+    [format
+     ["." binary (#+ Format)]]]
+   [type
+    abstract]]
+  [///
+   ["." encoding (#+ U1) ("u1/." Equivalence<U1>)]])
+
+(abstract: #export Tag
+  {}
+
+  U1
+
+  (structure: #export _ (Equivalence Tag)
+    (def: (= reference sample)
+      (u1/= (:representation reference)
+            (:representation sample))))
+
+  (do-template [<code> <name>]
+    [(def: #export <name>
+       Tag
+       (:abstraction (encoding.to-u1 <code>)))]
+
+    [01 utf8]
+    [03 integer]
+    [04 float]
+    [05 long]
+    [06 double]
+    [07 class]
+    [08 string]
+    [09 field]
+    [10 method]
+    [11 interface]
+    [12 name-and-type]
+    [15 method-handle]
+    [16 method-type]
+    [18 invoke-dynamic]
+    )
+
+  (def: #export format
+    (Format Tag)
+    (binary.adapt (|>> :abstraction)
+                  (|>> :representation)
+                  encoding.u1-format))
+  )
diff --git a/stdlib/source/lux/host/jvm/encoding.lux b/stdlib/source/lux/host/jvm/encoding.lux
new file mode 100644
index 000000000..6d8afe348
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/encoding.lux
@@ -0,0 +1,49 @@
+(.module:
+  [lux #*
+   [control
+    [equivalence (#+ Equivalence)]
+    [parser ("parser/." Functor<Parser>)]]
+   [data
+    [number
+     ["." i64]]
+    [format
+     ["." binary (#+ Format)]]]
+   [type
+    abstract]])
+
+(do-template [<name> <bytes> <to> <from>]
+  [(abstract: #export <name>
+     {}
+
+     (I64 Any)
+
+     (def: #export <to>
+       (-> (I64 Any) <name>)
+       (let [mask (|> <bytes>
+                      (n/* i64.bits-per-byte)
+                      i64.mask)]
+         (|>> (i64.and mask) :abstraction)))
+
+     (def: #export <from>
+       (-> <name> (I64 Any))
+       (|>> :representation))
+
+     (structure: #export _ (Equivalence <name>)
+       (def: (= reference sample)
+         ("lux i64 =" (:representation reference) (:representation sample))))
+     )]
+
+  [U1 1 to-u1 from-u1]
+  [U2 2 to-u2 from-u2]
+  [U4 4 to-u4 from-u4]
+  )
+
+(do-template [<name> <type> <format> <pre-write> <post-read>]
+  [(def: #export <name>
+     (Format <type>)
+     (binary.adapt <post-read> <pre-write> <format>))]
+
+  [u1-format U1 binary.bits/8  ..from-u1 ..to-u1]
+  [u2-format U2 binary.bits/16 ..from-u2 ..to-u2]
+  [u4-format U4 binary.bits/32 ..from-u4 ..to-u4]
+  )
diff --git a/stdlib/source/lux/host/jvm/index.lux b/stdlib/source/lux/host/jvm/index.lux
new file mode 100644
index 000000000..60d6211c6
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/index.lux
@@ -0,0 +1,17 @@
+(.module:
+  [lux #*
+   [data
+    [format
+     [binary (#+ Format)]]]]
+  [//
+   ["//." encoding (#+ U2)]])
+
+(type: #export Index U2)
+
+(def: #export index
+  (-> Nat Index)
+  //encoding.to-u2)
+
+(def: #export format
+  (Format Index)
+  //encoding.u2-format)
diff --git a/stdlib/source/lux/host/jvm/magic.lux b/stdlib/source/lux/host/jvm/magic.lux
new file mode 100644
index 000000000..e32259529
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/magic.lux
@@ -0,0 +1,19 @@
+(.module:
+  [lux #*
+   [data
+    [number (#+ hex)]
+    [format
+     [binary (#+ Format)]]]]
+  [//
+   ["//." encoding (#+ U4)]])
+
+(type: #export Magic
+  U4)
+
+(def: #export code
+  Magic
+  (//encoding.to-u4 (hex "CAFEBABE")))
+
+(def: #export format
+  (Format Magic)
+  //encoding.u4-format)
diff --git a/stdlib/source/lux/host/jvm/name.lux b/stdlib/source/lux/host/jvm/name.lux
new file mode 100644
index 000000000..d609b627d
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/name.lux
@@ -0,0 +1,30 @@
+(.module:
+  [lux (#- Name)
+   [data
+    ["." text]]
+   [type
+    abstract]])
+
+(def: #export internal-separator "/")
+(def: #export external-separator ".")
+
+(abstract: #export Name
+  {}
+
+  Text
+
+  (def: #export internal
+    (-> Text Name)
+    (|>> (text.replace-all ..external-separator
+                           ..internal-separator)
+         :abstraction))
+
+  (def: #export read
+    (-> Name Text)
+    (|>> :representation))
+
+  (def: #export external
+    (-> Name Text)
+    (|>> :representation
+         (text.replace-all ..internal-separator
+                           ..external-separator))))
diff --git a/stdlib/source/lux/host/jvm/version.lux b/stdlib/source/lux/host/jvm/version.lux
new file mode 100644
index 000000000..aca98e990
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/version.lux
@@ -0,0 +1,38 @@
+(.module:
+  [lux #*
+   [data
+    [format
+     ["." binary (#+ Format)]]]]
+  [//
+   ["//." encoding (#+ U2)]])
+
+(type: #export Version U2)
+(type: #export Minor Version)
+(type: #export Major Version)
+
+(def: #export version
+  (-> Nat Version)
+  //encoding.to-u2)
+
+(do-template [<name> <number>]
+  [(def: #export <name>
+     Major
+     (..version <number>))]
+
+  [v1_1 45]
+  [v1_2 46]
+  [v1_3 47]
+  [v1_4 48]
+  [v5_0 49]
+  [v6_0 50]
+  [v7 51]
+  [v8 52]
+  [v9 53]
+  [v10 54]
+  [v11 55]
+  [v12 56]
+  )
+
+(def: #export format
+  (Format Version)
+  //encoding.u2-format)
-- 
cgit v1.2.3