(;module:
  [lux #- char]
  (lux [host #+ jvm-import do-to])
  ["$" ..]
  (.. ["$t" type]))

## [Host]
(jvm-import #long java.lang.Object)
(jvm-import #long java.lang.String)

(jvm-import org.objectweb.asm.Opcodes
  (#static T_BOOLEAN int)
  (#static T_CHAR int)
  (#static T_FLOAT int)
  (#static T_DOUBLE int)
  (#static T_BYTE int)
  (#static T_SHORT int)
  (#static T_INT int)
  (#static T_LONG int)

  (#static CHECKCAST int)
  (#static NEW int)
  (#static NEWARRAY int)
  (#static ANEWARRAY int)
  
  (#static DUP int)
  (#static DUP2_X1 int)
  (#static POP int)
  (#static POP2 int)

  (#static IF_ICMPEQ int)
  (#static IF_ACMPEQ int)
  (#static IFNULL int)
  (#static GOTO int)

  (#static ACONST_NULL int)
  
  (#static ILOAD int)
  (#static ALOAD int)

  (#static IADD int)
  
  (#static LAND int)
  (#static LOR int)
  (#static LXOR int)
  (#static LSHL int)
  (#static LSHR int)
  (#static LUSHR int)

  (#static LADD int)
  (#static LSUB int)
  (#static LMUL int)
  (#static LDIV int)
  (#static LREM int)
  (#static LCMP int)
  
  (#static DADD int)
  (#static DSUB int)
  (#static DMUL int)
  (#static DDIV int)
  (#static DREM int)
  (#static DCMPG int)

  (#static I2L int)
  (#static L2I int)
  (#static L2D int)
  (#static D2L int)
  (#static I2C int)

  (#static AALOAD int)
  (#static AASTORE int)
  (#static ARRAYLENGTH int)
  
  (#static GETSTATIC int)
  (#static PUTSTATIC int)
  (#static GETFIELD int)
  (#static PUTFIELD int)
  
  (#static INVOKESTATIC int)
  (#static INVOKESPECIAL int)
  (#static INVOKEVIRTUAL int)

  (#static ATHROW int)

  (#static RETURN int)
  (#static ARETURN int)
  )

(jvm-import org.objectweb.asm.FieldVisitor
  (visitEnd [] void))

(jvm-import org.objectweb.asm.Label
  (new []))

(jvm-import org.objectweb.asm.MethodVisitor
  (visitCode [] void)
  (visitMaxs [int int] void)
  (visitEnd [] void)
  (visitInsn [int] void)
  (visitLdcInsn [Object] void)
  (visitFieldInsn [int String String String] void)
  (visitTypeInsn [int String] void)
  (visitVarInsn [int int] void)
  (visitIntInsn [int int] void)
  (visitMethodInsn [int String String String boolean] void)
  (visitLabel [Label] void)
  (visitJumpInsn [int Label] void))

## [Insts]
(def: #export (with-label action)
  (-> (-> Label $;Inst) $;Inst)
  (action (Label.new [])))

(do-template [<name> <type> <prepare>]
  [(def: #export (<name> value)
     (-> <type> $;Inst)
     (function [visitor]
       (do-to visitor
         (MethodVisitor.visitLdcInsn [(<prepare> value)]))))]

  [boolean Bool id]
  [int     Int  host;l2i]
  [long    Int  id]
  [double  Real id]
  [char    Nat  (|>. nat-to-int host;l2i host;i2c)]
  [string  Text id]
  )

(do-template [<name> <inst>]
  [(def: #export <name>
     $;Inst
     (function [visitor]
       (do-to visitor
         (MethodVisitor.visitInsn [<inst>]))))]

  [DUP         Opcodes.DUP]
  [DUP2_X1     Opcodes.DUP2_X1]
  [POP         Opcodes.POP]
  [POP2        Opcodes.POP2]

  [NULL        Opcodes.ACONST_NULL]
  
  [IADD        Opcodes.IADD]
  
  [LAND        Opcodes.LAND]
  [LOR         Opcodes.LOR]
  [LXOR        Opcodes.LXOR]
  [LSHL        Opcodes.LSHL]
  [LSHR        Opcodes.LSHR]
  [LUSHR       Opcodes.LUSHR]

  [LADD        Opcodes.LADD]
  [LSUB        Opcodes.LSUB]
  [LMUL        Opcodes.LMUL]
  [LDIV        Opcodes.LDIV]
  [LREM        Opcodes.LREM]
  [LCMP        Opcodes.LCMP]
  
  [DADD        Opcodes.DADD]
  [DSUB        Opcodes.DSUB]
  [DMUL        Opcodes.DMUL]
  [DDIV        Opcodes.DDIV]
  [DREM        Opcodes.DREM]
  [DCMPG       Opcodes.DCMPG]

  [I2L         Opcodes.I2L]
  [L2I         Opcodes.L2I]
  [L2D         Opcodes.L2D]
  [D2L         Opcodes.D2L]
  [I2C         Opcodes.I2C]
  
  [AALOAD      Opcodes.AALOAD]
  [AASTORE     Opcodes.AASTORE]
  [ARRAYLENGTH Opcodes.ARRAYLENGTH]

  [ATHROW      Opcodes.ATHROW]

  [RETURN      Opcodes.RETURN]
  [ARETURN     Opcodes.ARETURN]
  )

(do-template [<name> <inst>]
  [(def: #export (<name> register)
     (-> Nat $;Inst)
     (function [visitor]
       (do-to visitor
         (MethodVisitor.visitVarInsn [<inst> (nat-to-int register)]))))]

  [ALOAD Opcodes.ALOAD]
  [ILOAD Opcodes.ILOAD]
  )

(do-template [<name> <inst>]
  [(def: #export (<name> class field type)
     (-> Text Text $;Type $;Inst)
     (function [visitor]
       (do-to visitor
         (MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))]

  [GETSTATIC Opcodes.GETSTATIC]
  [PUTSTATIC Opcodes.PUTSTATIC]
  
  [PUTFIELD  Opcodes.PUTFIELD]
  [GETFIELD  Opcodes.GETFIELD]
  )

(do-template [<name> <inst>]
  [(def: #export (<name> class)
     (-> Text $;Inst)
     (function [visitor]
       (do-to visitor
         (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))]

  [CHECKCAST Opcodes.CHECKCAST]
  [NEW       Opcodes.NEW]
  [ANEWARRAY Opcodes.ANEWARRAY]
  )

(def: #export (NEWARRAY type)
  (-> $;Primitive $;Inst)
  (function [visitor]
    (do-to visitor
      (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type
                                                      #$;Boolean Opcodes.T_BOOLEAN
                                                      #$;Byte    Opcodes.T_SHORT
                                                      #$;Short   Opcodes.T_SHORT
                                                      #$;Int     Opcodes.T_INT
                                                      #$;Long    Opcodes.T_LONG
                                                      #$;Float   Opcodes.T_FLOAT
                                                      #$;Double  Opcodes.T_DOUBLE
                                                      #$;Char    Opcodes.T_CHAR)]))))

(do-template [<name> <inst>]
  [(def: #export (<name> class method-name method-signature interface?)
     (-> Text Text $;Method Bool $;Inst)
     (function [visitor]
       (do-to visitor
         (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))]

  [INVOKESTATIC  Opcodes.INVOKESTATIC]
  [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL]
  [INVOKESPECIAL Opcodes.INVOKESPECIAL]
  )

(do-template [<name> <inst>]
  [(def: #export (<name> @where)
     (-> $;Label $;Inst)
     (function [visitor]
       (do-to visitor
         (MethodVisitor.visitJumpInsn [<inst> @where]))))]

  [IF_ICMPEQ Opcodes.IF_ICMPEQ]
  [IF_ACMPEQ Opcodes.IF_ACMPEQ]
  [IFNULL    Opcodes.IFNULL]
  [GOTO      Opcodes.GOTO]
  )

(def: #export (label @label)
  (-> $;Label $;Inst)
  (function [visitor]
    (do-to visitor
      (MethodVisitor.visitLabel [@label]))))

(def: #export (array type size)
  (-> $;Type Nat $;Inst)
  (case type
    (#$;Primitive prim)
    (|>. (int (nat-to-int size))
         (NEWARRAY prim))

    (#$;Generic generic)
    (let [elem-class (case generic
                       (#$;Class class params)
                       ($t;binary-name class)

                       _
                       ($t;binary-name "java.lang.Object"))]
      (|>. (int (nat-to-int size))
           (ANEWARRAY elem-class)))

    _
    (|>. (int (nat-to-int size))
         (ANEWARRAY ($t;descriptor type)))))

(do-template [<wrap> <unwrap> <class> <unwrap-method> <prim>]
  [(def: #export <wrap>
     $;Inst
     (|>. (INVOKESTATIC <class> "valueOf"
                        ($t;method (list <prim>)
                                   (#;Some ($t;class <class> (list)))
                                   (list))
                        false)))
   (def: #export <unwrap>
     $;Inst
     (|>. (CHECKCAST <class>)
          (INVOKEVIRTUAL <class> <unwrap-method>
                         ($t;method (list) (#;Some <prim>) (list))
                         false)))]

  [wrap-boolean unwrap-boolean "java.lang.Boolean"   "booleanValue" $t;boolean]
  [wrap-byte    unwrap-byte    "java.lang.Byte"      "byteValue"    $t;byte]
  [wrap-short   unwrap-short   "java.lang.Short"     "shortValue"   $t;short]
  [wrap-int     unwrap-int     "java.lang.Integer"   "intValue"     $t;int]
  [wrap-long    unwrap-long    "java.lang.Long"      "longValue"    $t;long]
  [wrap-float   unwrap-float   "java.lang.Float"     "floatValue"   $t;float]
  [wrap-double  unwrap-double  "java.lang.Double"    "doubleValue"  $t;double]
  [wrap-char    unwrap-char    "java.lang.Character" "charValue"    $t;char]
  )

(def: #export (fuse insts)
  (-> (List $;Inst) $;Inst)
  (case insts
    #;Nil
    id

    (#;Cons singleton #;Nil)
    singleton

    (#;Cons head tail)
    (. head (fuse tail))))