(.module:
  [lux (#- int char)
   [abstract
    ["." monad (#+ do)]]
   [control
    ["ex" exception (#+ exception:)]
    ["p" parser ("#@." monad)
     ["l" text]]]
   [data
    ["." product]
    ["." error]
    ["." text
     format]
    [collection
     ["." list ("#@." functor)]
     ["." dictionary (#+ Dictionary)]]]
   [tool
    [compiler
     ["." synthesis (#+ Synthesis %synthesis)]
     ["." phase ("#@." monad)
      [generation
       [extension (#+ Nullary Unary Binary
                      nullary unary binary)]]
      ["." extension
       ["." bundle]]]]]
   [host (#+ import:)]]
  [luxc
   [lang
    [host
     ["$" jvm (#+ Primitive Label Inst Method Handler Bundle Operation)
      ["_t" type]
      ["_" inst]]]]])

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

  [invalid-syntax-for-jvm-type]
  [invalid-syntax-for-argument-generation]
  )

(template [<name> <inst>]
  [(def: <name>
     Inst
     <inst>)]

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

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

(def: conversion
  Bundle
  (<| (bundle.prefix "conversion")
      (|> (: Bundle bundle.empty)
          (bundle.install "double-to-float" (unary conversion::double-to-float))
          (bundle.install "double-to-int" (unary conversion::double-to-int))
          (bundle.install "double-to-long" (unary conversion::double-to-long))
          (bundle.install "float-to-double" (unary conversion::float-to-double))
          (bundle.install "float-to-int" (unary conversion::float-to-int))
          (bundle.install "float-to-long" (unary conversion::float-to-long))
          (bundle.install "int-to-byte" (unary conversion::int-to-byte))
          (bundle.install "int-to-char" (unary conversion::int-to-char))
          (bundle.install "int-to-double" (unary conversion::int-to-double))
          (bundle.install "int-to-float" (unary conversion::int-to-float))
          (bundle.install "int-to-long" (unary conversion::int-to-long))
          (bundle.install "int-to-short" (unary conversion::int-to-short))
          (bundle.install "long-to-double" (unary conversion::long-to-double))
          (bundle.install "long-to-float" (unary conversion::long-to-float))
          (bundle.install "long-to-int" (unary conversion::long-to-int))
          (bundle.install "long-to-short" (unary conversion::long-to-short))
          (bundle.install "long-to-byte" (unary conversion::long-to-byte))
          (bundle.install "long-to-char" (unary conversion::long-to-char))
          (bundle.install "char-to-byte" (unary conversion::char-to-byte))
          (bundle.install "char-to-short" (unary conversion::char-to-short))
          (bundle.install "char-to-int" (unary conversion::char-to-int))
          (bundle.install "char-to-long" (unary conversion::char-to-long))
          (bundle.install "byte-to-long" (unary conversion::byte-to-long))
          (bundle.install "short-to-long" (unary conversion::short-to-long))
          )))

(template [<name> <op>]
  [(def: (<name> [xI yI])
     (Binary Inst)
     (|>> xI
          yI
          <op>))]

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

  [float::+ _.FADD]
  [float::- _.FSUB]
  [float::* _.FMUL]
  [float::/ _.FDIV]
  [float::% _.FREM]
  
  [double::+ _.DADD]
  [double::- _.DSUB]
  [double::* _.DMUL]
  [double::/ _.DDIV]
  [double::% _.DREM]
  )

(def: boolean-class (_t.class "java.lang.Boolean" (list)))
(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class))
(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class))

(template [<name> <op>]
  [(def: (<name> [xI yI])
     (Binary Inst)
     (<| _.with-label (function (_ @then))
         _.with-label (function (_ @end))
         (|>> xI
              yI
              (<op> @then)
              falseI
              (_.GOTO @end)
              (_.label @then)
              trueI
              (_.label @end))))]

  [int::= _.IF_ICMPEQ]
  [int::< _.IF_ICMPLT]

  [char::= _.IF_ICMPEQ]
  [char::< _.IF_ICMPLT]
  )

(template [<name> <op> <reference>]
  [(def: (<name> [xI yI])
     (Binary Inst)
     (<| _.with-label (function (_ @then))
         _.with-label (function (_ @end))
         (|>> xI
              yI
              <op>
              (_.int <reference>)
              (_.IF_ICMPEQ @then)
              falseI
              (_.GOTO @end)
              (_.label @then)
              trueI
              (_.label @end))))]

  [long::= _.LCMP +0]
  [long::< _.LCMP -1]
  
  [float::= _.FCMPG +0]
  [float::< _.FCMPG -1]

  [double::= _.DCMPG +0]
  [double::< _.DCMPG -1]
  )

(def: int
  Bundle
  (<| (bundle.prefix "int")
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary int::+))
          (bundle.install "-" (binary int::-))
          (bundle.install "*" (binary int::*))
          (bundle.install "/" (binary int::/))
          (bundle.install "%" (binary int::%))
          (bundle.install "=" (binary int::=))
          (bundle.install "<" (binary int::<))
          (bundle.install "and" (binary int::and))
          (bundle.install "or" (binary int::or))
          (bundle.install "xor" (binary int::xor))
          (bundle.install "shl" (binary int::shl))
          (bundle.install "shr" (binary int::shr))
          (bundle.install "ushr" (binary int::ushr))
          )))

(def: long
  Bundle
  (<| (bundle.prefix "long")
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary long::+))
          (bundle.install "-" (binary long::-))
          (bundle.install "*" (binary long::*))
          (bundle.install "/" (binary long::/))
          (bundle.install "%" (binary long::%))
          (bundle.install "=" (binary long::=))
          (bundle.install "<" (binary long::<))
          (bundle.install "and" (binary long::and))
          (bundle.install "or" (binary long::or))
          (bundle.install "xor" (binary long::xor))
          (bundle.install "shl" (binary long::shl))
          (bundle.install "shr" (binary long::shr))
          (bundle.install "ushr" (binary long::ushr))
          )))

(def: float
  Bundle
  (<| (bundle.prefix "float")
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary float::+))
          (bundle.install "-" (binary float::-))
          (bundle.install "*" (binary float::*))
          (bundle.install "/" (binary float::/))
          (bundle.install "%" (binary float::%))
          (bundle.install "=" (binary float::=))
          (bundle.install "<" (binary float::<))
          )))

(def: double
  Bundle
  (<| (bundle.prefix "double")
      (|> (: Bundle bundle.empty)
          (bundle.install "+" (binary double::+))
          (bundle.install "-" (binary double::-))
          (bundle.install "*" (binary double::*))
          (bundle.install "/" (binary double::/))
          (bundle.install "%" (binary double::%))
          (bundle.install "=" (binary double::=))
          (bundle.install "<" (binary double::<))
          )))

(def: char
  Bundle
  (<| (bundle.prefix "char")
      (|> (: Bundle bundle.empty)
          (bundle.install "=" (binary char::=))
          (bundle.install "<" (binary char::<))
          )))

(def: (array-java-type nesting elem-class)
  (-> Nat Text $.Type)
  (_t.array nesting
            (case elem-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 elem-class (list)))))

(def: (array::length proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             arrayS))
    (do phase.monad
      [arrayI (generate arrayS)]
      (wrap (|>> arrayI
                 (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class)))
                 _.ARRAYLENGTH)))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (array::new proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             lengthS))
    (do phase.monad
      [lengthI (generate lengthS)]
      (wrap (|>> lengthI
                 (_.array (array-java-type (.nat nesting) elem-class)))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (array::read proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             idxS
             arrayS))
    (do phase.monad
      [arrayI (generate arrayS)
       idxI (generate idxS)
       #let [loadI (case elem-class
                     "boolean" _.BALOAD
                     "byte" _.BALOAD
                     "short" _.SALOAD
                     "int" _.IALOAD
                     "long" _.LALOAD
                     "float" _.FALOAD
                     "double" _.DALOAD
                     "char" _.CALOAD
                     _ _.AALOAD)]]
      (wrap (|>> arrayI
                 (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class)))
                 idxI
                 loadI)))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (array::write proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.i64 nesting)
             (synthesis.text elem-class)
             idxS
             valueS
             arrayS))
    (do phase.monad
      [arrayI (generate arrayS)
       idxI (generate idxS)
       valueI (generate valueS)
       #let [storeI (case elem-class
                      "boolean" _.BASTORE
                      "byte" _.BASTORE
                      "short" _.SASTORE
                      "int" _.IASTORE
                      "long" _.LASTORE
                      "float" _.FASTORE
                      "double" _.DASTORE
                      "char" _.CASTORE
                      _ _.AASTORE)]]
      (wrap (|>> arrayI
                 (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class)))
                 _.DUP
                 idxI
                 valueI
                 storeI)))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: array
  Bundle
  (<| (bundle.prefix "array")
      (|> (: Bundle bundle.empty)
          (bundle.install "length" array::length)
          (bundle.install "new" array::new)
          (bundle.install "read" array::read)
          (bundle.install "write" array::write)
          )))

(def: (object::null _)
  (Nullary Inst)
  _.NULL)

(def: (object::null? objectI)
  (Unary Inst)
  (<| _.with-label (function (_ @then))
      _.with-label (function (_ @end))
      (|>> objectI
           (_.IFNULL @then)
           falseI
           (_.GOTO @end)
           (_.label @then)
           trueI
           (_.label @end))))

(def: (object::synchronized [monitorI exprI])
  (Binary Inst)
  (|>> monitorI
       _.DUP
       _.MONITORENTER
       exprI
       _.SWAP
       _.MONITOREXIT))

(def: (object::throw exceptionI)
  (Unary Inst)
  (|>> exceptionI
       _.ATHROW))

(def: (object::class proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)))
    (do phase.monad
      []
      (wrap (|>> (_.string class)
                 (_.INVOKESTATIC "java.lang.Class" "forName"
                                 (_t.method (list (_t.class "java.lang.String" (list)))
                                            (#.Some (_t.class "java.lang.Class" (list)))
                                            (list))
                                 false))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (object::instance? proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class) objectS))
    (do phase.monad
      [objectI (generate objectS)]
      (wrap (|>> objectI
                 (_.INSTANCEOF class)
                 (_.wrap #$.Boolean))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (object::cast proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text from) (synthesis.text to) valueS))
    (do phase.monad
      [valueI (generate valueS)]
      (case [from to]
        ## Wrap
        (^template [<primitive> <object> <type>]
          [<primitive> <object>]
          (wrap (|>> valueI (_.wrap <type>)))

          [<object> <primitive>]
          (wrap (|>> valueI (_.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)))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: object
  Bundle
  (<| (bundle.prefix "object")
      (|> (: Bundle bundle.empty)
          (bundle.install "null" (nullary object::null))
          (bundle.install "null?" (unary object::null?))
          (bundle.install "synchronized" (binary object::synchronized))
          (bundle.install "throw" (unary object::throw))
          (bundle.install "class" object::class)
          (bundle.install "instance?" object::instance?)
          (bundle.install "cast" object::cast)
          )))

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

(def: (static::get proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)))
    (do phase.monad
      []
      (case (dictionary.get unboxed primitives)
        (#.Some primitive)
        (wrap (_.GETSTATIC class field (#$.Primitive primitive)))
        
        #.None
        (wrap (_.GETSTATIC class field (_t.class unboxed (list))))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (static::put proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)
             valueS))
    (do phase.monad
      [valueI (generate valueS)]
      (case (dictionary.get unboxed primitives)
        (#.Some primitive)
        (wrap (|>> valueI
                   (_.PUTSTATIC class field (#$.Primitive primitive))
                   (_.string synthesis.unit)))
        
        #.None
        (wrap (|>> valueI
                   (_.CHECKCAST class)
                   (_.PUTSTATIC class field (_t.class class (list)))
                   (_.string synthesis.unit)))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (virtual::get proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)
             objectS))
    (do phase.monad
      [objectI (generate objectS)]
      (case (dictionary.get unboxed primitives)
        (#.Some primitive)
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   (_.GETFIELD class field (#$.Primitive primitive))))
        
        #.None
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   (_.GETFIELD class field (_t.class unboxed (list)))))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: (virtual::put proc generate inputs)
  Handler
  (case inputs
    (^ (list (synthesis.text class)
             (synthesis.text field)
             (synthesis.text unboxed)
             valueS
             objectS))
    (do phase.monad
      [valueI (generate valueS)
       objectI (generate objectS)]
      (case (dictionary.get unboxed primitives)
        (#.Some primitive)
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   _.DUP
                   valueI
                   (_.PUTFIELD class field (#$.Primitive primitive))))
        
        #.None
        (wrap (|>> objectI
                   (_.CHECKCAST class)
                   _.DUP
                   valueI
                   (_.CHECKCAST unboxed)
                   (_.PUTFIELD class field (_t.class unboxed (list)))))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

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

(def: java-type
  (l.Parser $.Type)
  (do p.monad
    [raw base-type
     nesting (p.some (l.this "[]"))]
    (wrap (_t.array (list.size nesting) raw))))

(def: (generate-type argD)
  (-> Text (Operation $.Type))
  (case (l.run argD java-type)
    (#error.Failure error)
    (phase.throw invalid-syntax-for-jvm-type argD)

    (#error.Success type)
    (phase@wrap type)))

(def: (generate-arg generate argS)
  (-> (-> Synthesis (Operation Inst)) Synthesis
      (Operation [$.Type Inst]))
  (case argS
    (^ (synthesis.tuple (list (synthesis.text argD) argS)))
    (do phase.monad
      [argT (generate-type argD)
       argI (generate argS)]
      (wrap [argT argI]))

    _
    (phase.throw invalid-syntax-for-argument-generation "")))

(def: (method-return-type description)
  (-> Text (Operation (Maybe $.Type)))
  (case description
    "void"
    (phase@wrap #.None)

    _
    (phase@map (|>> #.Some) (generate-type description))))

(def: (prepare-argI [type argI])
  (-> [$.Type Inst] Inst)
  (case (_t.class-name type)
    (#.Some class-name)
    (|>> argI
         (_.CHECKCAST class-name))

    #.None
    argI))

(def: (invoke::static proc generate inputs)
  Handler
  (case inputs
    (^ (list& (synthesis.text class)
              (synthesis.text method)
              (synthesis.text unboxed)
              argsS))
    (do phase.monad
      [argsTI (monad.map @ (generate-arg generate) argsS)
       returnT (method-return-type unboxed)]
      (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI))
                 (_.INVOKESTATIC class method
                                 (_t.method (list@map product.left argsTI) returnT (list))
                                 false))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(template [<name> <invoke> <interface?>]
  [(def: (<name> proc generate inputs)
     Handler
     (case inputs
       (^ (list& (synthesis.text class)
                 (synthesis.text method)
                 (synthesis.text unboxed)
                 objectS
                 argsS))
       (do phase.monad
         [objectI (generate objectS)
          argsTI (monad.map @ (generate-arg generate) argsS)
          returnT (method-return-type unboxed)]
         (wrap (|>> objectI
                    (_.CHECKCAST class)
                    (_.fuse (list@map ..prepare-argI argsTI))
                    (<invoke> class method
                              (_t.method (list@map product.left argsTI) returnT (list))
                              <interface?>))))

       _
       (phase.throw extension.invalid-syntax [proc %synthesis inputs])))]

  [invoke::virtual _.INVOKEVIRTUAL false]
  [invoke::special _.INVOKESPECIAL false]
  [invoke::interface _.INVOKEINTERFACE true]
  )

(def: (invoke::constructor proc generate inputs)
  Handler
  (case inputs
    (^ (list& (synthesis.text class) argsS))
    (do phase.monad
      [argsTI (monad.map @ (generate-arg generate) argsS)]
      (wrap (|>> (_.NEW class)
                 _.DUP
                 (_.fuse (list@map ..prepare-argI argsTI))
                 (_.INVOKESPECIAL class "<init>"
                                  (_t.method (list@map product.left argsTI) #.None (list))
                                  false))))

    _
    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))

(def: member
  Bundle
  (<| (bundle.prefix "member")
      (|> (: Bundle bundle.empty)
          (dictionary.merge (<| (bundle.prefix "static")
                                (|> (: Bundle bundle.empty)
                                    (bundle.install "get" static::get)
                                    (bundle.install "put" static::put))))
          (dictionary.merge (<| (bundle.prefix "virtual")
                                (|> (: Bundle bundle.empty)
                                    (bundle.install "get" virtual::get)
                                    (bundle.install "put" virtual::put))))
          (dictionary.merge (<| (bundle.prefix "invoke")
                                (|> (: Bundle bundle.empty)
                                    (bundle.install "static" invoke::static)
                                    (bundle.install "virtual" invoke::virtual)
                                    (bundle.install "special" invoke::special)
                                    (bundle.install "interface" invoke::interface)
                                    (bundle.install "constructor" invoke::constructor))))
          )))

(def: #export bundle
  Bundle
  (<| (bundle.prefix "jvm")
      (|> ..conversion
          (dictionary.merge ..int)
          (dictionary.merge ..long)
          (dictionary.merge ..float)
          (dictionary.merge ..double)
          (dictionary.merge ..char)
          (dictionary.merge ..array)
          (dictionary.merge ..object)
          (dictionary.merge ..member)
          )))