(.module:
  [lux #*
   [control
    [monad (#+ do)]]
   [data
    [text
     format]
    [collection
     ["." list ("list/." Functor<List>)]]]
   ["." math]
   [compiler
    [default
     ["." phase
      [analysis (#+ Arity)]
      ["." translation]]]]]
  [luxc
   [lang
    [host
     ["$" jvm (#+ Inst Method Def Operation)
      ["$t" type]
      ["$d" def]
      ["_" inst]]]]]
  ["." // (#+ ByteCode)])

(def: $Object $.Type ($t.class "java.lang.Object" (list)))
(def: $Object-Array $.Type ($t.array 1 $Object))
(def: $String $.Type ($t.class "java.lang.String" (list)))
(def: #export $Stack $.Type ($t.array 1 $Object))
(def: #export $Tuple $.Type $Object-Array)
(def: #export $Variant $.Type $Object-Array)
(def: #export $Tag $.Type $t.int)
(def: #export $Flag $.Type $Object)
(def: #export $Datum $.Type $Object)
(def: #export $Function $.Type ($t.class //.function-class (list)))
(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list)))
(def: $Runtime $.Type ($t.class "java.lang.Runtime" (list)))

(def: #export logI
  Inst
  (let [outI (_.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list)))
        printI (function (_ method) (_.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) #0))]
    (|>> outI (_.string "LOG: ") (printI "print")
         outI _.SWAP (printI "println"))))

(def: variant-method
  Method
  ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list)))

(def: #export variantI
  Inst
  (_.INVOKESTATIC //.runtime-class "variant_make" variant-method #0))

(def: #export leftI
  Inst
  (|>> (_.int +0)
       _.NULL
       _.DUP2_X1
       _.POP2
       variantI))

(def: #export rightI
  Inst
  (|>> (_.int +1)
       (_.string "")
       _.DUP2_X1
       _.POP2
       variantI))

(def: #export someI Inst rightI)

(def: #export noneI
  Inst
  (|>> (_.int +0)
       _.NULL
       (_.string //.unit)
       variantI))

(def: (try-methodI unsafeI)
  (-> Inst Inst)
  (<| _.with-label (function (_ @from))
      _.with-label (function (_ @to))
      _.with-label (function (_ @handler))
      (|>> (_.try @from @to @handler "java.lang.Exception")
           (_.label @from)
           unsafeI
           someI
           _.ARETURN
           (_.label @to)
           (_.label @handler)
           noneI
           _.ARETURN)))

(def: #export string-concatI
  Inst
  (_.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0))

(def: #export partials-field Text "partials")
(def: #export apply-method Text "apply")
(def: #export num-apply-variants Nat 8)

(def: #export (apply-signature arity)
  (-> Arity Method)
  ($t.method (list.repeat arity $Object) (#.Some $Object) (list)))

(def: adt-methods
  Def
  (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap #$.Int) _.AASTORE)
        store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE)
        store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)
        force-textMT ($t.method (list $Object) (#.Some $String) (list))]
    (|>> ($d.method #$.Public $.staticM "force_text" force-textMT
                    (<| _.with-label (function (_ @is-null))
                        _.with-label (function (_ @normal-object))
                        _.with-label (function (_ @array-loop))
                        _.with-label (function (_ @within-bounds))
                        _.with-label (function (_ @is-first))
                        _.with-label (function (_ @elem-end))
                        _.with-label (function (_ @fold-end))
                        (let [on-normal-objectI (|>> (_.ALOAD 0)
                                                     (_.INVOKEVIRTUAL "java.lang.Object" "toString" ($t.method (list) (#.Some $String) (list)) #0))
                              on-null-objectI (_.string "NULL")
                              arrayI (|>> (_.ALOAD 0)
                                          (_.CHECKCAST ($t.descriptor $Object-Array)))
                              recurseI (_.INVOKESTATIC //.runtime-class "force_text" force-textMT #0)
                              force-elemI (|>> _.DUP arrayI _.SWAP _.AALOAD recurseI)
                              swap2 (|>> _.DUP2_X2 ## X,Y => Y,X,Y
                                         _.POP2 ## Y,X,Y => Y,X
                                         )
                              add-spacingI (|>> (_.string ", ") _.SWAP string-concatI)
                              merge-with-totalI (|>> _.DUP_X2 _.POP ## TSIP => TPSI
                                                     swap2 ## TPSI => SITP
                                                     string-concatI ## SITP => SIT
                                                     _.DUP_X2 _.POP ## SIT => TSI
                                                     )
                              foldI (|>> _.DUP ## TSI => TSII
                                         (_.IFEQ @is-first) ## TSI
                                         force-elemI add-spacingI merge-with-totalI (_.GOTO @elem-end)
                                         (_.label @is-first) ## TSI
                                         force-elemI merge-with-totalI
                                         (_.label @elem-end) ## TSI
                                         )
                              inc-idxI (|>> (_.int +1) _.IADD)
                              on-array-objectI (|>> (_.string "[") ## T
                                                    arrayI _.ARRAYLENGTH ## TS
                                                    (_.int +0) ## TSI
                                                    (_.label @array-loop) ## TSI
                                                    _.DUP2
                                                    (_.IF_ICMPGT @within-bounds) ## TSI
                                                    _.POP2 (_.string "]") string-concatI (_.GOTO @fold-end)
                                                    (_.label @within-bounds)
                                                    foldI inc-idxI (_.GOTO @array-loop)
                                                    (_.label @fold-end))])
                        (|>> (_.ALOAD 0)
                             (_.IFNULL @is-null)
                             (_.ALOAD 0)
                             (_.INSTANCEOF ($t.descriptor $Object-Array))
                             (_.IFEQ @normal-object)
                             on-array-objectI _.ARETURN
                             (_.label @normal-object) on-normal-objectI _.ARETURN
                             (_.label @is-null) on-null-objectI _.ARETURN)))
         ($d.method #$.Public $.staticM "variant_make"
                    ($t.method (list $t.int $Object $Object)
                               (#.Some $Variant)
                               (list))
                    (|>> (_.int +3)
                         (_.array $Object)
                         store-tagI
                         store-flagI
                         store-valueI
                         _.ARETURN)))))

(def: #export force-textI
  Inst
  (_.INVOKESTATIC //.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) #0))

(def: frac-shiftI Inst (_.double (math.pow +32.0 +2.0)))

(def: frac-methods
  Def
  (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list))
                  (try-methodI
                   (|>> (_.ALOAD 0)
                        (_.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) #0)
                        (_.wrap #$.Double))))
       ))

(def: clz-method Method ($t.method (list $t.long) (#.Some $t.int) (list)))

(def: text-methods
  Def
  (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list))
                  (try-methodI
                   (|>> (_.ALOAD 0)
                        (_.ILOAD 1)
                        (_.ILOAD 2)
                        (_.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) #0))))
       ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list))
                  (try-methodI
                   (|>> (_.ALOAD 0)
                        (_.ILOAD 1)
                        (_.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) #0)
                        _.I2L
                        (_.wrap #$.Long))))
       ))

(def: pm-methods
  Def
  (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH)
        tuple-elemI (|>> (_.ALOAD 0) (_.ILOAD 1) _.AALOAD)
        expected-last-sizeI (|>> (_.ILOAD 1) (_.int +1) _.IADD)
        tuple-tailI (|>> (_.ALOAD 0) tuple-sizeI (_.int +1) _.ISUB _.AALOAD (_.CHECKCAST ($t.descriptor $Tuple)))]
    (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list))
                    (|>> (_.NEW "java.lang.IllegalStateException")
                         _.DUP
                         (_.string "Invalid expression for pattern-matching.")
                         (_.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) #0)
                         _.ATHROW))
         ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list))
                    (|>> (_.NEW "java.lang.IllegalStateException")
                         _.DUP
                         (_.string "Error while applying function.")
                         (_.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) #0)
                         _.ATHROW))
         ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list))
                    (|>> (_.int +2)
                         (_.ANEWARRAY "java.lang.Object")
                         _.DUP
                         (_.int +0)
                         (_.ALOAD 0)
                         _.AASTORE
                         _.DUP
                         (_.int +1)
                         (_.ALOAD 1)
                         _.AASTORE
                         _.ARETURN))
         ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list))
                    (|>> (_.ALOAD 0)
                         (_.int +0)
                         _.AALOAD
                         (_.CHECKCAST ($t.descriptor $Stack))
                         _.ARETURN))
         ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list))
                    (|>> (_.ALOAD 0)
                         (_.int +1)
                         _.AALOAD
                         _.ARETURN))
         ($d.method #$.Public $.staticM "pm_variant" ($t.method (list $Variant $Tag $Flag) (#.Some $Object) (list))
                    (<| _.with-label (function (_ @begin))
                        _.with-label (function (_ @just-return))
                        _.with-label (function (_ @then))
                        _.with-label (function (_ @further))
                        _.with-label (function (_ @shorten))
                        _.with-label (function (_ @wrong))
                        (let [variant-partI (: (-> Nat Inst)
                                               (function (_ idx)
                                                 (|>> (_.int (.int idx)) _.AALOAD)))
                              tagI (: Inst
                                      (|>> (variant-partI 0) (_.unwrap #$.Int)))
                              flagI (variant-partI 1)
                              datumI (variant-partI 2)
                              shortenI (|>> (_.ALOAD 0) tagI ## Get tag
                                            (_.ILOAD 1) _.ISUB ## Shorten tag
                                            (_.ALOAD 0) flagI ## Get flag
                                            (_.ALOAD 0) datumI ## Get value
                                            variantI ## Build sum
                                            _.ARETURN)
                              update-tagI (|>> _.ISUB (_.ISTORE 1))
                              update-variantI (|>> (_.ALOAD 0) datumI (_.CHECKCAST ($t.descriptor $Variant)) (_.ASTORE 0))
                              failureI (|>> _.NULL _.ARETURN)
                              return-datumI (|>> (_.ALOAD 0) datumI _.ARETURN)])
                        (|>> (_.label @begin)
                             (_.ILOAD 1) ## tag
                             (_.ALOAD 0) tagI ## tag, sumT
                             _.DUP2 (_.IF_ICMPEQ @then)
                             _.DUP2 (_.IF_ICMPGT @further)
                             _.DUP2 (_.IF_ICMPLT @shorten)
                             ## _.POP2
                             failureI
                             (_.label @then) ## tag, sumT
                             (_.ALOAD 2) ## tag, sumT, wants-last?
                             (_.ALOAD 0) flagI ## tag, sumT, wants-last?, is-last?
                             (_.IF_ACMPEQ @just-return) ## tag, sumT
                             (_.label @further) ## tag, sumT
                             (_.ALOAD 0) flagI ## tag, sumT, last?
                             (_.IFNULL @wrong) ## tag, sumT
                             update-tagI
                             update-variantI
                             (_.GOTO @begin)
                             (_.label @just-return) ## tag, sumT
                             ## _.POP2
                             return-datumI
                             (_.label @shorten) ## tag, sumT
                             (_.ALOAD 2) (_.IFNULL @wrong)
                             ## _.POP2
                             shortenI
                             (_.label @wrong) ## tag, sumT
                             ## _.POP2
                             failureI)))
         ($d.method #$.Public $.staticM "pm_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (list))
                    (<| _.with-label (function (_ @begin))
                        _.with-label (function (_ @not-recursive))
                        (let [updated-idxI (|>> _.SWAP _.ISUB)])
                        (|>> (_.label @begin)
                             tuple-sizeI
                             expected-last-sizeI
                             _.DUP2 (_.IF_ICMPGT @not-recursive)
                             ## Recursive
                             updated-idxI (_.ISTORE 1)
                             tuple-tailI (_.ASTORE 0)
                             (_.GOTO @begin)
                             (_.label @not-recursive)
                             ## _.POP2
                             tuple-elemI
                             _.ARETURN)))
         ($d.method #$.Public $.staticM "pm_right" ($t.method (list $Tuple $t.int) (#.Some $Object) (list))
                    (<| _.with-label (function (_ @begin))
                        _.with-label (function (_ @tail))
                        _.with-label (function (_ @slice))
                        (let [updated-idxI (|>> (_.ILOAD 1) (_.int +1) _.ISUB tuple-sizeI _.ISUB)
                              sliceI (|>> (_.ALOAD 0) (_.ILOAD 1) tuple-sizeI
                                          (_.INVOKESTATIC "java.util.Arrays" "copyOfRange"
                                                          ($t.method (list $Object-Array $t.int $t.int)
                                                                     (#.Some $Object-Array)
                                                                     (list))
                                                          #0))])
                        (|>> (_.label @begin)
                             tuple-sizeI
                             expected-last-sizeI
                             _.DUP2 (_.IF_ICMPEQ @tail)
                             (_.IF_ICMPGT @slice)
                             ## Must recurse
                             tuple-tailI (_.ASTORE 0)
                             updated-idxI (_.ISTORE 1)
                             (_.GOTO @begin)
                             (_.label @slice)
                             sliceI
                             _.ARETURN
                             (_.label @tail)
                             ## _.POP2
                             tuple-elemI
                             _.ARETURN)))
         )))

(def: io-methods
  Def
  (let [string-writerI (|>> (_.NEW "java.io.StringWriter")
                            _.DUP
                            (_.INVOKESPECIAL "java.io.StringWriter" "<init>" ($t.method (list) #.None (list)) #0))
        print-writerI (|>> (_.NEW "java.io.PrintWriter")
                           _.SWAP
                           _.DUP2
                           _.POP
                           _.SWAP
                           (_.boolean #1)
                           (_.INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) #0)
                           )]
    (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list))
                    (<| _.with-label (function (_ @from))
                        _.with-label (function (_ @to))
                        _.with-label (function (_ @handler))
                        (|>> (_.try @from @to @handler "java.lang.Throwable")
                             (_.label @from)
                             (_.ALOAD 0)
                             _.NULL
                             (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0)
                             rightI
                             _.ARETURN
                             (_.label @to)
                             (_.label @handler)
                             string-writerI ## TW
                             _.DUP2 ## TWTW
                             print-writerI ## TWTP
                             (_.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) #0) ## TW
                             (_.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) #0) ## TS
                             _.SWAP _.POP leftI
                             _.ARETURN)))
         )))

(def: translate-runtime
  (Operation ByteCode)
  (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list)
                           (|>> adt-methods
                                frac-methods
                                text-methods
                                pm-methods
                                io-methods))]
    (do phase.Monad<Operation>
      [_ (translation.execute! //.runtime-class [//.runtime-class bytecode])]
      (wrap bytecode))))

(def: translate-function
  (Operation ByteCode)
  (let [applyI (|> (list.n/range 2 num-apply-variants)
                   (list/map (function (_ arity)
                               ($d.method #$.Public $.noneM apply-method (apply-signature arity)
                                          (let [preI (|> (list.n/range 0 (dec arity))
                                                         (list/map _.ALOAD)
                                                         _.fuse)]
                                            (|>> preI
                                                 (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature (dec arity)) #0)
                                                 (_.CHECKCAST //.function-class)
                                                 (_.ALOAD arity)
                                                 (_.INVOKEVIRTUAL //.function-class apply-method (apply-signature 1) #0)
                                                 _.ARETURN)))))
                   (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1)))
                   $d.fuse)
        bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list)
                              (|>> ($d.field #$.Public $.finalF partials-field $t.int)
                                   ($d.method #$.Public $.noneM "<init>" ($t.method (list $t.int) #.None (list))
                                              (|>> (_.ALOAD 0)
                                                   (_.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) #0)
                                                   (_.ALOAD 0)
                                                   (_.ILOAD 1)
                                                   (_.PUTFIELD //.function-class partials-field $t.int)
                                                   _.RETURN))
                                   applyI))]
    (do phase.Monad<Operation>
      [_ (translation.execute! //.function-class [//.function-class bytecode])]
      (wrap bytecode))))

(def: #export translate
  (Operation Any)
  (do phase.Monad<Operation>
    [runtime-bc translate-runtime
     function-bc translate-function]
    (wrap [])))