path: root/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux

(.module:
  lux
  (lux (control [monad #+ do]
                ["p" parser "parser/" Monad<Parser>]
                ["ex" exception #+ exception:])
       (data [product]
             ["e" error]
             [text "text/" Eq<Text>]
             (text format
                   ["l" lexer])
             (coll [list "list/" Functor<List>]
                   (dictionary ["dict" unordered #+ Dict])))
       [macro "macro/" Monad<Meta>]
       (macro [code]
              ["s" syntax #+ syntax:])
       [host])
  (luxc ["&" lang]
        (lang [".L" host]
              (host ["$" jvm]
                    (jvm ["$t" type]
                         ["$d" def]
                         ["$i" inst]))
              ["la" analysis]
              (extension (analysis ["&." host]))
              ["ls" synthesis]))
  (// ["@" common]))

(do-template [<name>]
  [(exception: #export (<name> {message Text})
     message)]

  [Invalid-Syntax-For-JVM-Type]
  [Invalid-Syntax-For-Argument-Generation]
  )

(do-template [<name> <inst>]
  [(def: <name>
     $.Inst
     <inst>)]

  [L2S (|>> $i.L2I $i.I2S)]
  [L2B (|>> $i.L2I $i.I2B)]
  [L2C (|>> $i.L2I $i.I2C)]
  )

(do-template [<name> <unwrap> <conversion> <wrap>]
  [(def: (<name> inputI)
     @.Unary
     (if (is? $i.NOP <conversion>)
       (|>> inputI
            ($i.unwrap <unwrap>)
            ($i.wrap <wrap>))
       (|>> inputI
            ($i.unwrap <unwrap>)
            <conversion>
            ($i.wrap <wrap>))))]
  
  [convert//double-to-float #$.Double $i.D2F #$.Float]
  [convert//double-to-int #$.Double $i.D2I #$.Int]
  [convert//double-to-long #$.Double $i.D2L #$.Long]
  [convert//float-to-double #$.Float $i.F2D #$.Double]
  [convert//float-to-int #$.Float $i.F2I #$.Int]
  [convert//float-to-long #$.Float $i.F2L #$.Long]
  [convert//int-to-byte #$.Int $i.I2B #$.Byte]
  [convert//int-to-char #$.Int $i.I2C #$.Char]
  [convert//int-to-double #$.Int $i.I2D #$.Double]
  [convert//int-to-float #$.Int $i.I2F #$.Float]
  [convert//int-to-long #$.Int $i.I2L #$.Long]
  [convert//int-to-short #$.Int $i.I2S #$.Short]
  [convert//long-to-double #$.Long $i.L2D #$.Double]
  [convert//long-to-float #$.Long $i.L2F #$.Float]
  [convert//long-to-int #$.Long $i.L2I #$.Int]
  [convert//long-to-short #$.Long L2S #$.Short]
  [convert//long-to-byte #$.Long L2B #$.Byte]
  [convert//long-to-char #$.Long L2C #$.Char]
  [convert//char-to-byte #$.Char $i.I2B #$.Byte]
  [convert//char-to-short #$.Char $i.I2S #$.Short]
  [convert//char-to-int #$.Char $i.NOP #$.Int]
  [convert//char-to-long #$.Char $i.I2L #$.Long]
  [convert//byte-to-long #$.Byte $i.I2L #$.Long]
  [convert//short-to-long #$.Short $i.I2L #$.Long]
  )

(def: conversion-procs
  @.Bundle
  (<| (@.prefix "convert")
      (|> (dict.new text.Hash<Text>)
          (@.install "double-to-float" (@.unary convert//double-to-float))
          (@.install "double-to-int" (@.unary convert//double-to-int))
          (@.install "double-to-long" (@.unary convert//double-to-long))
          (@.install "float-to-double" (@.unary convert//float-to-double))
          (@.install "float-to-int" (@.unary convert//float-to-int))
          (@.install "float-to-long" (@.unary convert//float-to-long))
          (@.install "int-to-byte" (@.unary convert//int-to-byte))
          (@.install "int-to-char" (@.unary convert//int-to-char))
          (@.install "int-to-double" (@.unary convert//int-to-double))
          (@.install "int-to-float" (@.unary convert//int-to-float))
          (@.install "int-to-long" (@.unary convert//int-to-long))
          (@.install "int-to-short" (@.unary convert//int-to-short))
          (@.install "long-to-double" (@.unary convert//long-to-double))
          (@.install "long-to-float" (@.unary convert//long-to-float))
          (@.install "long-to-int" (@.unary convert//long-to-int))
          (@.install "long-to-short" (@.unary convert//long-to-short))
          (@.install "long-to-byte" (@.unary convert//long-to-byte))
          (@.install "long-to-char" (@.unary convert//long-to-char))
          (@.install "char-to-byte" (@.unary convert//char-to-byte))
          (@.install "char-to-short" (@.unary convert//char-to-short))
          (@.install "char-to-int" (@.unary convert//char-to-int))
          (@.install "char-to-long" (@.unary convert//char-to-long))
          (@.install "byte-to-long" (@.unary convert//byte-to-long))
          (@.install "short-to-long" (@.unary convert//short-to-long))
          )))

(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
  [(def: (<name> [xI yI])
     @.Binary
     (|>> xI ($i.unwrap <unwrapX>)
          yI ($i.unwrap <unwrapY>)
          <op> ($i.wrap <wrap>)))]

  [int//+ $i.IADD #$.Int #$.Int #$.Int]
  [int//- $i.ISUB #$.Int #$.Int #$.Int]
  [int//* $i.IMUL #$.Int #$.Int #$.Int]
  [int/// $i.IDIV #$.Int #$.Int #$.Int]
  [int//% $i.IREM #$.Int #$.Int #$.Int]
  [int//and $i.IAND #$.Int #$.Int #$.Int]
  [int//or $i.IOR #$.Int #$.Int #$.Int]
  [int//xor $i.IXOR #$.Int #$.Int #$.Int]
  [int//shl $i.ISHL #$.Int #$.Int #$.Int]
  [int//shr $i.ISHR #$.Int #$.Int #$.Int]
  [int//ushr $i.IUSHR #$.Int #$.Int #$.Int]
  
  [long//+ $i.LADD #$.Long #$.Long #$.Long]
  [long//- $i.LSUB #$.Long #$.Long #$.Long]
  [long//* $i.LMUL #$.Long #$.Long #$.Long]
  [long/// $i.LDIV #$.Long #$.Long #$.Long]
  [long//% $i.LREM #$.Long #$.Long #$.Long]
  [long//and $i.LAND #$.Long #$.Long #$.Long]
  [long//or $i.LOR #$.Long #$.Long #$.Long]
  [long//xor $i.LXOR #$.Long #$.Long #$.Long]
  [long//shl $i.LSHL #$.Long #$.Int #$.Long]
  [long//shr $i.LSHR #$.Long #$.Int #$.Long]
  [long//ushr $i.LUSHR #$.Long #$.Int #$.Long]

  [float//+ $i.FADD #$.Float #$.Float #$.Float]
  [float//- $i.FSUB #$.Float #$.Float #$.Float]
  [float//* $i.FMUL #$.Float #$.Float #$.Float]
  [float/// $i.FDIV #$.Float #$.Float #$.Float]
  [float//% $i.FREM #$.Float #$.Float #$.Float]
  
  [double//+ $i.DADD #$.Double #$.Double #$.Double]
  [double//- $i.DSUB #$.Double #$.Double #$.Double]
  [double//* $i.DMUL #$.Double #$.Double #$.Double]
  [double/// $i.DDIV #$.Double #$.Double #$.Double]
  [double//% $i.DREM #$.Double #$.Double #$.Double]
  )

(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
  [(def: (<name> [xI yI])
     @.Binary
     (<| $i.with-label (function (_ @then))
         $i.with-label (function (_ @end))
         (|>> xI ($i.unwrap <unwrapX>)
              yI ($i.unwrap <unwrapY>)
              (<op> @then)
              ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
              ($i.GOTO @end)
              ($i.label @then)
              ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
              ($i.label @end))))]

  [int//= $i.IF_ICMPEQ #$.Int #$.Int #$.Boolean]
  [int//< $i.IF_ICMPLT #$.Int #$.Int #$.Boolean]

  [char//= $i.IF_ICMPEQ #$.Char #$.Char #$.Boolean]
  [char//< $i.IF_ICMPLT #$.Char #$.Char #$.Boolean]
  )

(do-template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>]
  [(def: (<name> [xI yI])
     @.Binary
     (<| $i.with-label (function (_ @then))
         $i.with-label (function (_ @end))
         (|>> xI ($i.unwrap <unwrapX>)
              yI ($i.unwrap <unwrapY>)
              <op>
              ($i.int <reference>)
              ($i.IF_ICMPEQ @then)
              ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
              ($i.GOTO @end)
              ($i.label @then)
              ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
              ($i.label @end))))]

  [long//= $i.LCMP  0 #$.Long #$.Long #$.Boolean]
  [long//< $i.LCMP -1 #$.Long #$.Long #$.Boolean]
  
  [float//= $i.FCMPG  0 #$.Float #$.Float #$.Boolean]
  [float//< $i.FCMPG -1 #$.Float #$.Float #$.Boolean]

  [double//= $i.DCMPG  0 #$.Double #$.Double #$.Boolean]
  [double//< $i.DCMPG -1 #$.Double #$.Double #$.Boolean]
  )

(def: int-procs
  @.Bundle
  (<| (@.prefix "int")
      (|> (dict.new text.Hash<Text>)
          (@.install "+" (@.binary int//+))
          (@.install "-" (@.binary int//-))
          (@.install "*" (@.binary int//*))
          (@.install "/" (@.binary int///))
          (@.install "%" (@.binary int//%))
          (@.install "=" (@.binary int//=))
          (@.install "<" (@.binary int//<))
          (@.install "and" (@.binary int//and))
          (@.install "or" (@.binary int//or))
          (@.install "xor" (@.binary int//xor))
          (@.install "shl" (@.binary int//shl))
          (@.install "shr" (@.binary int//shr))
          (@.install "ushr" (@.binary int//ushr))
          )))

(def: long-procs
  @.Bundle
  (<| (@.prefix "long")
      (|> (dict.new text.Hash<Text>)
          (@.install "+" (@.binary long//+))
          (@.install "-" (@.binary long//-))
          (@.install "*" (@.binary long//*))
          (@.install "/" (@.binary long///))
          (@.install "%" (@.binary long//%))
          (@.install "=" (@.binary long//=))
          (@.install "<" (@.binary long//<))
          (@.install "and" (@.binary long//and))
          (@.install "or" (@.binary long//or))
          (@.install "xor" (@.binary long//xor))
          (@.install "shl" (@.binary long//shl))
          (@.install "shr" (@.binary long//shr))
          (@.install "ushr" (@.binary long//ushr))
          )))

(def: float-procs
  @.Bundle
  (<| (@.prefix "float")
      (|> (dict.new text.Hash<Text>)
          (@.install "+" (@.binary float//+))
          (@.install "-" (@.binary float//-))
          (@.install "*" (@.binary float//*))
          (@.install "/" (@.binary float///))
          (@.install "%" (@.binary float//%))
          (@.install "=" (@.binary float//=))
          (@.install "<" (@.binary float//<))
          )))

(def: double-procs
  @.Bundle
  (<| (@.prefix "double")
      (|> (dict.new text.Hash<Text>)
          (@.install "+" (@.binary double//+))
          (@.install "-" (@.binary double//-))
          (@.install "*" (@.binary double//*))
          (@.install "/" (@.binary double///))
          (@.install "%" (@.binary double//%))
          (@.install "=" (@.binary double//=))
          (@.install "<" (@.binary double//<))
          )))

(def: char-procs
  @.Bundle
  (<| (@.prefix "char")
      (|> (dict.new text.Hash<Text>)
          (@.install "=" (@.binary char//=))
          (@.install "<" (@.binary char//<))
          )))

(def: (array//length arrayI)
  @.Unary
  (|>> arrayI
       $i.ARRAYLENGTH
       $i.I2L
       ($i.wrap #$.Long)))

(def: (array//new proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS))
    (do macro.Monad<Meta>
      [lengthI (translate lengthS)
       #let [arrayJT ($t.array level (case class
                                       "boolean" $t.boolean
                                       "byte" $t.byte
                                       "short" $t.short
                                       "int" $t.int
                                       "long" $t.long
                                       "float" $t.float
                                       "double" $t.double
                                       "char" $t.char
                                       _ ($t.class class (list))))]]
      (wrap (|>> lengthI
                 ($i.unwrap #$.Long)
                 $i.L2I
                 ($i.array arrayJT))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: (array//read proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)] idxS arrayS))
    (do macro.Monad<Meta>
      [arrayI (translate arrayS)
       idxI (translate idxS)
       #let [loadI (case class
                     "boolean" (|>> $i.BALOAD ($i.wrap #$.Boolean))
                     "byte" (|>> $i.BALOAD ($i.wrap #$.Byte))
                     "short" (|>> $i.SALOAD ($i.wrap #$.Short))
                     "int" (|>> $i.IALOAD ($i.wrap #$.Int))
                     "long" (|>> $i.LALOAD ($i.wrap #$.Long))
                     "float" (|>> $i.FALOAD ($i.wrap #$.Float))
                     "double" (|>> $i.DALOAD ($i.wrap #$.Double))
                     "char" (|>> $i.CALOAD ($i.wrap #$.Char))
                     _ $i.AALOAD)]]
      (wrap (|>> arrayI
                 idxI
                 ($i.unwrap #$.Long)
                 $i.L2I
                 loadI)))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: (array//write proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)] idxS valueS arrayS))
    (do macro.Monad<Meta>
      [arrayI (translate arrayS)
       idxI (translate idxS)
       valueI (translate valueS)
       #let [storeI (case class
                      "boolean" (|>> ($i.unwrap #$.Boolean) $i.BASTORE)
                      "byte" (|>> ($i.unwrap #$.Byte) $i.BASTORE)
                      "short" (|>> ($i.unwrap #$.Short) $i.SASTORE)
                      "int" (|>> ($i.unwrap #$.Int) $i.IASTORE)
                      "long" (|>> ($i.unwrap #$.Long) $i.LASTORE)
                      "float" (|>> ($i.unwrap #$.Float) $i.FASTORE)
                      "double" (|>> ($i.unwrap #$.Double) $i.DASTORE)
                      "char" (|>> ($i.unwrap #$.Char) $i.CASTORE)
                      _ $i.AASTORE)]]
      (wrap (|>> arrayI
                 $i.DUP
                 idxI
                 ($i.unwrap #$.Long)
                 $i.L2I
                 valueI
                 storeI)))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: array-procs
  @.Bundle
  (<| (@.prefix "array")
      (|> (dict.new text.Hash<Text>)
          (@.install "length" (@.unary array//length))
          (@.install "new" array//new)
          (@.install "read" array//read)
          (@.install "write" array//write)
          )))

(def: (object//null _)
  @.Nullary
  $i.NULL)

(def: (object//null? objectI)
  @.Unary
  (<| $i.with-label (function (_ @then))
      $i.with-label (function (_ @end))
      (|>> objectI
           ($i.IFNULL @then)
           ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
           ($i.GOTO @end)
           ($i.label @then)
           ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
           ($i.label @end))))

(def: (object//synchronized [monitorI exprI])
  @.Binary
  (|>> monitorI
       $i.DUP
       $i.MONITORENTER
       exprI
       $i.SWAP
       $i.MONITOREXIT))

(def: (object//throw exceptionI)
  @.Unary
  (|>> exceptionI
       $i.ATHROW))

(def: (object//class proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)]))
    (do macro.Monad<Meta>
      []
      (wrap (|>> ($i.string class)
                 ($i.INVOKESTATIC "java.lang.Class" "forName"
                                  ($t.method (list ($t.class "java.lang.String" (list)))
                                             (#.Some ($t.class "java.lang.Class" (list)))
                                             (list))
                                  false))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: (object//instance? proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)] objectS))
    (do macro.Monad<Meta>
      [objectI (translate objectS)]
      (wrap (|>> objectI
                 ($i.INSTANCEOF class)
                 ($i.wrap #$.Boolean))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: (object//cast proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text from)] [_ (#.Text to)] valueS))
    (do macro.Monad<Meta>
      [valueI (translate valueS)]
      (case [from to]
        ## Wrap
        (^template [<primitive> <object> <type>]
          [<primitive> <object>]
          (wrap (|>> valueI ($i.wrap <type>)))

          [<object> <primitive>]
          (wrap (|>> valueI ($i.unwrap <type>))))
        (["boolean" "java.lang.Boolean"   #$.Boolean]
         ["byte"    "java.lang.Byte"      #$.Byte]
         ["short"   "java.lang.Short"     #$.Short]
         ["int"     "java.lang.Integer"   #$.Int]
         ["long"    "java.lang.Long"      #$.Long]
         ["float"   "java.lang.Float"     #$.Float]
         ["double"  "java.lang.Double"    #$.Double]
         ["char"    "java.lang.Character" #$.Char])
        
        _
        (wrap valueI)))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: object-procs
  @.Bundle
  (<| (@.prefix "object")
      (|> (dict.new text.Hash<Text>)
          (@.install "null" (@.nullary object//null))
          (@.install "null?" (@.unary object//null?))
          (@.install "synchronized" (@.binary object//synchronized))
          (@.install "throw" (@.unary object//throw))
          (@.install "class" object//class)
          (@.install "instance?" object//instance?)
          (@.install "cast" object//cast)
          )))

(def: primitives
  (Dict Text $.Primitive)
  (|> (list ["boolean" #$.Boolean]
            ["byte" #$.Byte]
            ["short" #$.Short]
            ["int" #$.Int]
            ["long" #$.Long]
            ["float" #$.Float]
            ["double" #$.Double]
            ["char" #$.Char])
      (dict.from-list text.Hash<Text>)))

(def: (static//get proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)]))
    (do macro.Monad<Meta>
      []
      (case (dict.get unboxed primitives)
        (#.Some primitive)
        (let [primitive (case unboxed
                          "boolean" #$.Boolean
                          "byte" #$.Byte
                          "short" #$.Short
                          "int" #$.Int
                          "long" #$.Long
                          "float" #$.Float
                          "double" #$.Double
                          "char" #$.Char
                          _ (undefined))]
          (wrap (|>> ($i.GETSTATIC class field (#$.Primitive primitive))
                     ($i.wrap primitive))))
        
        #.None
        (wrap ($i.GETSTATIC class field ($t.class unboxed (list))))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: (static//put proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS))
    (do macro.Monad<Meta>
      [valueI (translate valueS)]
      (case (dict.get unboxed primitives)
        (#.Some primitive)
        (let [primitive (case unboxed
                          "boolean" #$.Boolean
                          "byte" #$.Byte
                          "short" #$.Short
                          "int" #$.Int
                          "long" #$.Long
                          "float" #$.Float
                          "double" #$.Double
                          "char" #$.Char
                          _ (undefined))]
          (wrap (|>> valueI
                     ($i.unwrap primitive)
                     ($i.PUTSTATIC class field (#$.Primitive primitive))
                     ($i.string hostL.unit))))
        
        #.None
        (wrap (|>> valueI
                   ($i.CHECKCAST class)
                   ($i.PUTSTATIC class field ($t.class class (list)))
                   ($i.string hostL.unit)))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: (virtual//get proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS))
    (do macro.Monad<Meta>
      [objectI (translate objectS)]
      (case (dict.get unboxed primitives)
        (#.Some primitive)
        (let [primitive (case unboxed
                          "boolean" #$.Boolean
                          "byte" #$.Byte
                          "short" #$.Short
                          "int" #$.Int
                          "long" #$.Long
                          "float" #$.Float
                          "double" #$.Double
                          "char" #$.Char
                          _ (undefined))]
          (wrap (|>> objectI
                     ($i.CHECKCAST class)
                     ($i.GETFIELD class field (#$.Primitive primitive))
                     ($i.wrap primitive))))
        
        #.None
        (wrap (|>> objectI
                   ($i.CHECKCAST class)
                   ($i.GETFIELD class field ($t.class unboxed (list)))))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: (virtual//put proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS))
    (do macro.Monad<Meta>
      [valueI (translate valueS)
       objectI (translate objectS)]
      (case (dict.get unboxed primitives)
        (#.Some primitive)
        (let [primitive (case unboxed
                          "boolean" #$.Boolean
                          "byte" #$.Byte
                          "short" #$.Short
                          "int" #$.Int
                          "long" #$.Long
                          "float" #$.Float
                          "double" #$.Double
                          "char" #$.Char
                          _ (undefined))]
          (wrap (|>> objectI
                     ($i.CHECKCAST class)
                     $i.DUP
                     valueI
                     ($i.unwrap primitive)
                     ($i.PUTFIELD class field (#$.Primitive primitive)))))
        
        #.None
        (wrap (|>> objectI
                   ($i.CHECKCAST class)
                   $i.DUP
                   valueI
                   ($i.CHECKCAST unboxed)
                   ($i.PUTFIELD class field ($t.class unboxed (list)))))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: base-type
  (l.Lexer $.Type)
  ($_ p.either
      (p.after (l.this "boolean") (parser/wrap $t.boolean))
      (p.after (l.this "byte") (parser/wrap $t.byte))
      (p.after (l.this "short") (parser/wrap $t.short))
      (p.after (l.this "int") (parser/wrap $t.int))
      (p.after (l.this "long") (parser/wrap $t.long))
      (p.after (l.this "float") (parser/wrap $t.float))
      (p.after (l.this "double") (parser/wrap $t.double))
      (p.after (l.this "char") (parser/wrap $t.char))
      (parser/map (function (_ name)
                    ($t.class name (list)))
                  (l.many (l.none-of "[")))
      ))

(def: java-type
  (l.Lexer $.Type)
  (do p.Monad<Parser>
    [raw base-type
     nesting (p.some (l.this "[]"))]
    (wrap ($t.array (list.size nesting) raw))))

(def: (translate-type argD)
  (-> Text (Meta $.Type))
  (case (l.run argD java-type)
    (#e.Error error)
    (&.throw Invalid-Syntax-For-JVM-Type argD)

    (#e.Success type)
    (macro/wrap type)))

(def: (translate-arg translate argS)
  (-> (-> ls.Synthesis (Meta $.Inst)) ls.Synthesis
      (Meta [$.Type $.Inst]))
  (case argS
    (^ [_ (#.Tuple (list [_ (#.Text argD)] argS))])
    (do macro.Monad<Meta>
      [argT (translate-type argD)
       argI (translate argS)]
      (wrap [argT argI]))

    _
    (&.throw Invalid-Syntax-For-Argument-Generation "")))

(def: (method-return-type description)
  (-> Text (Meta (Maybe $.Type)))
  (case description
    "void"
    (macro/wrap #.None)

    _
    (macro/map (|>> #.Some) (translate-type description))))

(def: (invoke//static proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list& [_ (#.Text class)] [_ (#.Text method)]
              [_ (#.Text unboxed)] argsS))
    (do macro.Monad<Meta>
      [argsTI (monad.map @ (translate-arg translate) argsS)
       returnT (method-return-type unboxed)]
      (wrap (|>> ($i.fuse (list/map product.right argsTI))
                 ($i.INVOKESTATIC class method
                                  ($t.method (list/map product.left argsTI) returnT (list))
                                  false))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(do-template [<name> <invoke> <interface?>]
  [(def: (<name> proc translate inputs)
     (-> Text @.Proc)
     (case inputs
       (^ (list& [_ (#.Text class)] [_ (#.Text method)]
                 [_ (#.Text unboxed)] objectS argsS))
       (do macro.Monad<Meta>
         [objectI (translate objectS)
          argsTI (monad.map @ (translate-arg translate) argsS)
          returnT (method-return-type unboxed)]
         (wrap (|>> objectI
                    ($i.CHECKCAST class)
                    ($i.fuse (list/map product.right argsTI))
                    (<invoke> class method
                              ($t.method (list/map product.left argsTI) returnT (list))
                              <interface?>))))

       _
       (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))]

  [invoke//virtual $i.INVOKEVIRTUAL false]
  [invoke//special $i.INVOKESPECIAL false]
  [invoke//interface $i.INVOKEINTERFACE true]
  )

(def: (invoke//constructor proc translate inputs)
  (-> Text @.Proc)
  (case inputs
    (^ (list& [_ (#.Text class)] argsS))
    (do macro.Monad<Meta>
      [argsTI (monad.map @ (translate-arg translate) argsS)]
      (wrap (|>> ($i.NEW class)
                 $i.DUP
                 ($i.fuse (list/map product.right argsTI))
                 ($i.INVOKESPECIAL class "<init>"
                                   ($t.method (list/map product.left argsTI) #.None (list))
                                   false))))

    _
    (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))

(def: member-procs
  @.Bundle
  (<| (@.prefix "member")
      (|> (dict.new text.Hash<Text>)
          (dict.merge (<| (@.prefix "static")
                          (|> (dict.new text.Hash<Text>)
                              (@.install "get" static//get)
                              (@.install "put" static//put))))
          (dict.merge (<| (@.prefix "virtual")
                          (|> (dict.new text.Hash<Text>)
                              (@.install "get" virtual//get)
                              (@.install "put" virtual//put))))
          (dict.merge (<| (@.prefix "invoke")
                          (|> (dict.new text.Hash<Text>)
                              (@.install "static" invoke//static)
                              (@.install "virtual" invoke//virtual)
                              (@.install "special" invoke//special)
                              (@.install "interface" invoke//interface)
                              (@.install "constructor" invoke//constructor))))
          )))

(def: #export procedures
  @.Bundle
  (<| (@.prefix "jvm")
      (|> conversion-procs
          (dict.merge int-procs)
          (dict.merge long-procs)
          (dict.merge float-procs)
          (dict.merge double-procs)
          (dict.merge char-procs)
          (dict.merge array-procs)
          (dict.merge object-procs)
          (dict.merge member-procs)
          )))