From bf84fa3eb63fad7f2360b863e7f26005ee2d5aa8 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 22 Aug 2019 22:21:59 -0400
Subject: Parser for JVM types.

---
 stdlib/source/lux/target/jvm/type.lux            | 257 ++++++++++++++---------
 stdlib/source/lux/target/jvm/type/descriptor.lux |   8 +-
 stdlib/source/lux/target/jvm/type/lux.lux        |  16 +-
 stdlib/source/lux/target/jvm/type/reflection.lux |  16 +-
 stdlib/source/lux/target/jvm/type/signature.lux  |  31 ++-
 5 files changed, 196 insertions(+), 132 deletions(-)

(limited to 'stdlib/source')

diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
index e28e9633a..83a9d017a 100644
--- a/stdlib/source/lux/target/jvm/type.lux
+++ b/stdlib/source/lux/target/jvm/type.lux
@@ -1,10 +1,11 @@
 (.module:
   [lux (#- Type int char)
    [abstract
-    [equivalence (#+ Equivalence)]]
+    [equivalence (#+ Equivalence)]
+    [monad (#+ do)]]
    [control
     ["." function]
-    ["<>" parser
+    ["<>" parser ("#@." monad)
      ["<t>" text (#+ Parser)]]]
    [data
     ["." product]
@@ -24,14 +25,14 @@
    ["#." descriptor (#+ Descriptor)]
    ["#." reflection (#+ Reflection)]])
 
-(abstract: #export (Type brand)
+(abstract: #export (Type category)
   {}
 
-  [(Signature Any) (Descriptor Any) (Reflection Any)]
+  [(Signature category) (Descriptor category) (Reflection category)]
 
   (template [<name> <style>]
     [(def: #export (<name> type)
-       (-> (Type Any) (<style> Any))
+       (All [category] (-> (Type category) (<style> category)))
        (let [[signature descriptor reflection] (:representation type)]
          <name>))]
 
@@ -40,9 +41,9 @@
     [reflection Reflection]
     )
 
-  (template [<brand> <name> <signature> <descriptor> <reflection>]
+  (template [<category> <name> <signature> <descriptor> <reflection>]
     [(def: #export <name>
-       (Type <brand>)
+       (Type <category>)
        (:abstraction [<signature> <descriptor> <reflection>]))]
 
     [Void void /signature.void /descriptor.void /reflection.void]
@@ -102,99 +103,153 @@
     (-> [(List (Type Value))
          (Type Return)
          (List (Type Class))]
-        (Type Method))
-    (:abstraction
-     [(/signature.method [(list@map ..signature inputs)
-                          (..signature output)
-                          (list@map ..signature exceptions)])
-      (/descriptor.method [(list@map ..descriptor inputs)
-                           (..descriptor output)])
-      (/reflection.method [(list@map ..reflection inputs)
-                           (..reflection output)])]))
+        [(Signature Method)
+         (Descriptor Method)])
+    [(/signature.method [(list@map ..signature inputs)
+                         (..signature output)
+                         (list@map ..signature exceptions)])
+     (/descriptor.method [(list@map ..descriptor inputs)
+                          (..descriptor output)])])
+
+  (structure: #export equivalence
+    (All [category] (Equivalence (Type category)))
+
+    (def: (= parameter subject)
+      (:: /signature.equivalence =
+          (..signature parameter)
+          (..signature subject))))
+  )
+
+(template [<category> <name> <signature> <type>]
+  [(def: <name>
+     (Parser (Type <category>))
+     (<>.after (<t>.this (/signature.signature <signature>))
+               (<>@wrap <type>)))]
+
+  [Void void-parser /signature.void ..void]
+  [Primitive boolean-parser /signature.boolean ..boolean]
+  [Primitive byte-parser /signature.byte ..byte]
+  [Primitive short-parser /signature.short ..short]
+  [Primitive int-parser /signature.int ..int]
+  [Primitive long-parser /signature.long ..long]
+  [Primitive float-parser /signature.float ..float]
+  [Primitive double-parser /signature.double ..double]
+  [Primitive char-parser /signature.char ..char]
+  [Parameter wildcard-parser /signature.wildcard ..wildcard]
+  )
+
+(def: primitive-parser
+  (Parser (Type Primitive))
+  ($_ <>.either
+      ..boolean-parser
+      ..byte-parser
+      ..short-parser
+      ..int-parser
+      ..long-parser
+      ..float-parser
+      ..double-parser
+      ..char-parser))
+
+(def: valid-var-characters/head
+  (format "abcdefghijklmnopqrstuvwxyz"
+          "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+          "_"))
+
+(def: valid-var-characters/tail
+  (format valid-var-characters/head
+          "0123456789"))
+
+(def: valid-class-characters/head
+  (format valid-var-characters/head //name.internal-separator))
+
+(def: valid-class-characters/tail
+  (format valid-var-characters/tail //name.internal-separator))
+
+(template [<type> <name> <head> <tail> <adapter>]
+  [(def: <name>
+     (Parser <type>)
+     (:: <>.functor map <adapter>
+         (<t>.slice (<t>.and! (<t>.one-of! <head>)
+                              (<t>.some! (<t>.one-of! <tail>))))))]
+
+  [External class-name-parser valid-class-characters/head valid-class-characters/tail (|>> //name.internal //name.external)]
+  [Text var-name-parser   valid-var-characters/head   valid-var-characters/tail   function.identity]
+  )
+
+(def: var-parser
+  (Parser (Type Parameter))
+  (|> ..var-name-parser
+      (<>.after (<t>.this /signature.var-prefix))
+      (<>.before (<t>.this /descriptor.class-suffix))
+      (<>@map ..var)))
+
+(template [<name> <prefix> <constructor>]
+  [(def: <name>
+     (-> (Parser (Type Class)) (Parser (Type Parameter)))
+     (|>> (<>.after (<t>.this <prefix>))
+          (<>@map <constructor>)))]
+
+  [lower-parser /signature.lower-prefix ..lower]
+  [upper-parser /signature.upper-prefix ..upper]
   )
 
-## (def: valid-var-characters/head
-##   (format "abcdefghijklmnopqrstuvwxyz"
-##           "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
-##           "_"))
-
-## (def: valid-var-characters/tail
-##   (format valid-var-characters/head
-##           "0123456789"))
-
-## (def: valid-class-characters/head
-##   (format valid-var-characters/head //name.internal-separator))
-
-## (def: valid-class-characters/tail
-##   (format valid-var-characters/tail //name.internal-separator))
-
-## (type: #export Parameter
-##   [Text Class (List Class)])
-
-## (type: #export Argument
-##   [Text Type])
-
-## (type: #export (Typed a)
-##   [Type a])
-
-## (template [<name> <head> <tail> <adapter>]
-##   [(def: <name>
-##      (Parser Text)
-##      (:: <>.functor map <adapter>
-##          (<t>.slice (<t>.and! (<t>.one-of! <head>)
-##                               (<t>.some! (<t>.one-of! <tail>))))))]
-
-##   [parse-class-name valid-class-characters/head valid-class-characters/tail (|>> //name.internal //name.external)]
-##   [parse-var-name valid-var-characters/head valid-var-characters/tail function.identity]
-##   )
-
-## (def: parse-var
-##   (Parser Var)
-##   (|> ..parse-var-name
-##       (<>.after (<t>.this ..var-prefix))
-##       (<>.before (<t>.this ..object-suffix))))
-
-## (def: parse-bound
-##   (Parser Bound)
-##   ($_ <>.or
-##       (<t>.this ..lower-prefix)
-##       (<t>.this ..upper-prefix)))
-
-## (def: parse-generic
-##   (Parser Generic)
-##   (<>.rec
-##    (function (_ recur)
-##      ($_ <>.or
-##          ..parse-var
-##          ($_ <>.or
-##              (<t>.this ..wildcard-signature)
-##              (<>.and ..parse-bound recur)
-##              )
-##          (|> (<>.and ..parse-class-name
-##                      (|> (<>.some recur)
-##                          (<>.after (<t>.this "<"))
-##                          (<>.before (<t>.this ">"))
-##                          (<>.default (list))))
-##              (<>.after (<t>.this ..object-prefix))
-##              (<>.before (<t>.this ..object-suffix)))
-##          ))))
-
-## (def: #export parse-signature
-##   (Parser Type)
-##   (<>.rec
-##    (function (_ recur)
-##      ($_ <>.or
-##          ($_ <>.or
-##              (<t>.this ..boolean-descriptor)
-##              (<t>.this ..byte-descriptor)
-##              (<t>.this ..short-descriptor)
-##              (<t>.this ..int-descriptor)
-##              (<t>.this ..long-descriptor)
-##              (<t>.this ..float-descriptor)
-##              (<t>.this ..double-descriptor)
-##              (<t>.this ..char-descriptor)
-##              )
-##          ..parse-generic
-##          (<>.after (<t>.this ..array-prefix)
-##                    recur)
-##          ))))
+(def: (class-parser parameter-parser)
+  (-> (Parser (Type Parameter)) (Parser (Type Class)))
+  (|> (do <>.monad
+        [_ (<t>.this /descriptor.class-prefix)
+         name ..class-name-parser
+         parameters (|> (<>.some parameter-parser)
+                        (<>.after (<t>.this /signature.parameters-start))
+                        (<>.before (<t>.this /signature.parameters-end))
+                        (<>.default (list)))
+         _ (<t>.this /descriptor.class-suffix)]
+        (wrap (..class name parameters)))
+      (<>.after (<t>.this /descriptor.class-prefix))
+      (<>.before (<t>.this /descriptor.class-suffix))))
+
+(def: generic-parser
+  (Parser (Type Parameter))
+  (<>.rec
+   (function (_ generic-parser)
+     (let [class-parser (..class-parser generic-parser)]
+       ($_ <>.either
+           ..var-parser
+           ..wildcard-parser
+           (..lower-parser class-parser)
+           (..upper-parser class-parser)
+           class-parser
+           )))))
+
+(def: array-parser
+  (-> (Parser (Type Value)) (Parser (Type Array)))
+  (|>> (<>.after (<t>.this /descriptor.array-prefix))
+       (<>@map ..array)))
+
+(def: #export value-parser
+  (Parser (Type Value))
+  (<>.rec
+   (function (_ parser)
+     ($_ <>.either
+         ..primitive-parser
+         ..generic-parser
+         (..array-parser parser)
+         ))))
+
+(def: #export method-parser
+  (Parser [(Signature Method)
+           (Descriptor Method)])
+  (let [parameters-parser (: (Parser (List (Type Value)))
+                             (|> (<>.some ..value-parser)
+                                 (<>.after (<t>.this /signature.arguments-start))
+                                 (<>.before (<t>.this /signature.arguments-end))))
+        return-parser (: (Parser (Type Return))
+                         (<>.either ..void-parser
+                                    ..value-parser))
+        exception-parser (: (Parser (Type Class))
+                            (|> (..class-parser ..generic-parser)
+                                (<>.after (<t>.this /signature.exception-prefix))))]
+    (do <>.monad
+      [parameters parameters-parser
+       return return-parser
+       exceptions (<>.some exception-parser)]
+      (wrap (..method [parameters return exceptions])))))
diff --git a/stdlib/source/lux/target/jvm/type/descriptor.lux b/stdlib/source/lux/target/jvm/type/descriptor.lux
index 4a46b5caa..e16693ff4 100644
--- a/stdlib/source/lux/target/jvm/type/descriptor.lux
+++ b/stdlib/source/lux/target/jvm/type/descriptor.lux
@@ -18,7 +18,7 @@
     [encoding
      ["#." name (#+ External)]]]])
 
-(abstract: #export (Descriptor brand)
+(abstract: #export (Descriptor category)
   {}
 
   Text
@@ -27,9 +27,9 @@
     (-> (Descriptor Any) Text)
     (|>> :representation))
 
-  (template [<sigil> <brand> <name>]
+  (template [<sigil> <category> <name>]
     [(def: #export <name>
-       (Descriptor <brand>)
+       (Descriptor <category>)
        (:abstraction <sigil>))]
 
     ["V" Void void]
@@ -92,7 +92,7 @@
              (:representation output))))
 
   (structure: #export equivalence
-    (All [brand] (Equivalence (Descriptor brand)))
+    (All [category] (Equivalence (Descriptor category)))
     
     (def: (= parameter subject)
       (text@= (:representation parameter) (:representation subject))))
diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux
index 243861bd4..c773856f5 100644
--- a/stdlib/source/lux/target/jvm/type/lux.lux
+++ b/stdlib/source/lux/target/jvm/type/lux.lux
@@ -83,14 +83,14 @@
   (case input
     (#//.Primitive primitive)
     (check@wrap (case primitive
-                  #//.Boolean (#.Primitive //reflection.boolean #.Nil)
-                  #//.Byte (#.Primitive //reflection.byte #.Nil)
-                  #//.Short (#.Primitive //reflection.short #.Nil)
-                  #//.Int (#.Primitive //reflection.int #.Nil)
-                  #//.Long (#.Primitive //reflection.long #.Nil)
-                  #//.Float (#.Primitive //reflection.float #.Nil)
-                  #//.Double (#.Primitive //reflection.double #.Nil)
-                  #//.Char (#.Primitive //reflection.char #.Nil)))
+                  #//.Boolean (#.Primitive (//reflection.reflection //reflection.boolean) #.Nil)
+                  #//.Byte (#.Primitive (//reflection.reflection //reflection.byte) #.Nil)
+                  #//.Short (#.Primitive (//reflection.reflection //reflection.short) #.Nil)
+                  #//.Int (#.Primitive (//reflection.reflection //reflection.int) #.Nil)
+                  #//.Long (#.Primitive (//reflection.reflection //reflection.long) #.Nil)
+                  #//.Float (#.Primitive (//reflection.reflection //reflection.float) #.Nil)
+                  #//.Double (#.Primitive (//reflection.reflection //reflection.double) #.Nil)
+                  #//.Char (#.Primitive (//reflection.reflection //reflection.char) #.Nil)))
     
     (#//.Generic generic)
     (..generic mapping generic)
diff --git a/stdlib/source/lux/target/jvm/type/reflection.lux b/stdlib/source/lux/target/jvm/type/reflection.lux
index 08c51b391..65ee1aa90 100644
--- a/stdlib/source/lux/target/jvm/type/reflection.lux
+++ b/stdlib/source/lux/target/jvm/type/reflection.lux
@@ -5,14 +5,14 @@
      ["%" format (#+ format)]]]
    [type
     abstract]]
-  ["." //
+  ["." // #_
    [category (#+ Void Value Return Method Primitive Object Class Array Parameter)]
    ["#." descriptor]
    [//
     [encoding
      ["#." name (#+ External)]]]])
 
-(abstract: #export (Reflection brand)
+(abstract: #export (Reflection category)
   {}
 
   Text
@@ -21,9 +21,9 @@
     (-> (Reflection Any) Text)
     (|>> :representation))
 
-  (template [<brand> <name> <reflection>]
+  (template [<category> <name> <reflection>]
     [(def: #export <name>
-       (Reflection <brand>)
+       (Reflection <category>)
        (:abstraction <reflection>))]
 
     [Void void "void"]
@@ -42,7 +42,7 @@
     (|>> :abstraction))
 
   (def: #export array
-    (-> (Reflection Class) (Reflection Array))
+    (-> (Reflection Value) (Reflection Array))
     (|>> :representation
          (format //descriptor.array-prefix)
          :abstraction))
@@ -57,11 +57,11 @@
     [wildcard]
     )
 
-  (def: #export (lower descriptor)
-    (-> (Descriptor Class) (Descriptor Parameter))
+  (def: #export (lower reflection)
+    (-> (Reflection Class) (Reflection Parameter))
     ..wildcard)
 
   (def: #export upper
-    (-> (Descriptor Class) (Descriptor Parameter))
+    (-> (Reflection Class) (Reflection Parameter))
     (|>> :transmutation))
   )
diff --git a/stdlib/source/lux/target/jvm/type/signature.lux b/stdlib/source/lux/target/jvm/type/signature.lux
index bfb3a14ba..260c564db 100644
--- a/stdlib/source/lux/target/jvm/type/signature.lux
+++ b/stdlib/source/lux/target/jvm/type/signature.lux
@@ -16,7 +16,7 @@
     [encoding
      ["#." name (#+ External)]]]])
 
-(abstract: #export (Signature brand)
+(abstract: #export (Signature category)
   {}
 
   Text
@@ -25,9 +25,9 @@
     (-> (Signature Any) Text)
     (|>> :representation))
 
-  (template [<brand> <name> <descriptor>]
+  (template [<category> <name> <descriptor>]
     [(def: #export <name>
-       (Signature <brand>)
+       (Signature <category>)
        (:abstraction (//descriptor.descriptor <descriptor>)))]
 
     [Void void //descriptor.void]
@@ -51,15 +51,15 @@
     (Signature Parameter)
     (:abstraction "*"))
 
-  (def: var-prefix "T")
+  (def: #export var-prefix "T")
   
   (def: #export var
     (-> Text (Signature Parameter))
     (|>> (text.enclose [..var-prefix //descriptor.class-suffix])
          :abstraction))
 
-  (def: lower-prefix "-")
-  (def: upper-prefix "+")
+  (def: #export lower-prefix "-")
+  (def: #export upper-prefix "+")
   
   (template [<name> <prefix>]
     [(def: #export <name>
@@ -70,6 +70,9 @@
     [upper ..upper-prefix]
     )
 
+  (def: #export parameters-start "<")
+  (def: #export parameters-end ">")
+
   (def: #export (class name parameters)
     (-> External (List (Signature Parameter)) (Signature Class))
     (:abstraction
@@ -80,13 +83,18 @@
                ""
 
                _
-               (format "<"
+               (format ..parameters-start
                        (|> parameters
                            (list@map ..signature)
                            (text.join-with ""))
-                       ">"))
+                       ..parameters-end))
              //descriptor.class-suffix)))
 
+  (def: #export arguments-start "(")
+  (def: #export arguments-end ")")
+
+  (def: #export exception-prefix "^")
+
   (def: #export (method [inputs output exceptions])
     (-> [(List (Signature Value))
          (Signature Return)
@@ -96,14 +104,15 @@
      (format (|> inputs
                  (list@map ..signature)
                  (text.join-with "")
-                 (text.enclose ["(" ")"]))
+                 (text.enclose [..arguments-start
+                                ..arguments-end]))
              (:representation output)
              (|> exceptions
-                 (list@map (|>> :representation (format "^")))
+                 (list@map (|>> :representation (format ..exception-prefix)))
                  (text.join-with "")))))
 
   (structure: #export equivalence
-    (All [brand] (Equivalence (Signature brand)))
+    (All [category] (Equivalence (Signature category)))
     
     (def: (= parameter subject)
       (text@= (:representation parameter)
-- 
cgit v1.2.3