(.module:
  lux
  (lux (control monad)
       (data text/format
             (coll [list "list/" Functor<List>]))
       [math]
       [macro])
  (luxc ["&" lang]
        (lang [".L" host]
              (host ["$" jvm]
                    (jvm ["$t" type]
                         ["$d" def]
                         ["$i" inst]))
              ["la" analysis]
              ["ls" synthesis]))
  (// [".T" common]))

(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 hostL.function-class (list)))
(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list)))
(def: $Runtime $.Type ($t.class "java.lang.Runtime" (list)))
(def: $Runnable $.Type ($t.class "java.lang.Runnable" (list)))

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

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

(def: #export variantI
  $.Inst
  ($i.INVOKESTATIC hostL.runtime-class "variant_make" variant-method false))

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

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

(def: #export someI $.Inst rightI)

(def: #export noneI
  $.Inst
  (|>> ($i.int 0)
       $i.NULL
       ($i.string hostL.unit)
       variantI))

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

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

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

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

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

(def: #export force-textI
  $.Inst
  ($i.INVOKESTATIC hostL.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) false))

(def: frac-shiftI $.Inst ($i.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
                   (|>> ($i.ALOAD +0)
                        ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false)
                        ($i.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
                   (|>> ($i.ALOAD +0)
                        ($i.ILOAD +1)
                        ($i.ILOAD +2)
                        ($i.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) false))))
       ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list))
                  (try-methodI
                   (|>> ($i.ALOAD +0)
                        ($i.ILOAD +1)
                        ($i.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) false)
                        $i.I2L
                        ($i.wrap #$.Long))))
       ))

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

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

(def: process-methods
  $.Def
  (let [executor-class "java.util.concurrent.ScheduledThreadPoolExecutor"
        executorT ($t.class executor-class (list))
        executor-field "executor"
        endI (|>> ($i.string hostL.unit)
                  $i.ARETURN)
        runnableI (: (-> $.Inst $.Inst)
                     (function (_ functionI)
                       (|>> ($i.NEW hostL.runnable-class)
                            $i.DUP
                            functionI
                            ($i.INVOKESPECIAL hostL.runnable-class "<init>" ($t.method (list $Function) #.None (list)) false))))
        threadI (: (-> $.Inst $.Inst)
                   (function (_ runnableI)
                     (|>> ($i.NEW "java.lang.Thread")
                          $i.DUP
                          runnableI
                          ($i.INVOKESPECIAL "java.lang.Thread" "<init>" ($t.method (list $Runnable) #.None (list)) false))))]
    (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) executor-field executorT)
         ($d.method #$.Public $.staticM "<clinit>" ($t.method (list) #.None (list))
                    (let [parallelism-levelI (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some $Runtime) (list)) false)
                                                  ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false))
                          executorI (|>> ($i.NEW executor-class)
                                         $i.DUP
                                         parallelism-levelI
                                         ($i.INVOKESPECIAL executor-class "<init>" ($t.method (list $t.int) #.None (list)) false))]
                      (|>> executorI
                           ($i.PUTSTATIC hostL.runtime-class executor-field executorT)
                           $i.RETURN)))
         ($d.method #$.Public $.staticM "schedule"
                    ($t.method (list $t.long $Function) (#.Some $Object) (list))
                    (let [delayI ($i.LLOAD +0)
                          immediacy-checkI (|>> delayI
                                                ($i.long 0)
                                                $i.LCMP)
                          time-unit-class "java.util.concurrent.TimeUnit"
                          time-unitT ($t.class time-unit-class (list))
                          futureT ($t.class "java.util.concurrent.ScheduledFuture" (list))
                          executorI ($i.GETSTATIC hostL.runtime-class executor-field executorT)
                          schedule-laterI (|>> executorI
                                               (runnableI ($i.ALOAD +2))
                                               delayI
                                               ($i.GETSTATIC time-unit-class "MILLISECONDS" time-unitT)
                                               ($i.INVOKEVIRTUAL executor-class "schedule" ($t.method (list $Runnable $t.long time-unitT) (#.Some futureT) (list)) false))
                          schedule-immediatelyI (|>> executorI
                                                     (runnableI ($i.ALOAD +2))
                                                     ($i.INVOKEVIRTUAL executor-class "execute" ($t.method (list $Runnable) #.None (list)) false))]
                      (<| $i.with-label (function (_ @immediately))
                          (|>> immediacy-checkI
                               ($i.IFEQ @immediately)
                               schedule-laterI
                               endI
                               ($i.label @immediately)
                               schedule-immediatelyI
                               endI))))
         )))

(def: translate-runtime
  (Meta commonT.Bytecode)
  (do macro.Monad<Meta>
    [_ (wrap [])
     #let [bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runtime-class (list) ["java.lang.Object" (list)] (list)
                              (|>> adt-methods
                                   frac-methods
                                   text-methods
                                   pm-methods
                                   io-methods
                                   process-methods))]
     _ (commonT.store-class hostL.runtime-class bytecode)]
    (wrap bytecode)))

(def: translate-function
  (Meta commonT.Bytecode)
  (do macro.Monad<Meta>
    [_ (wrap [])
     #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 (n/dec arity))
                                                            (list/map $i.ALOAD)
                                                            $i.fuse)]
                                               (|>> preI
                                                    ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature (n/dec arity)) false)
                                                    ($i.CHECKCAST hostL.function-class)
                                                    ($i.ALOAD arity)
                                                    ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false)
                                                    $i.ARETURN)))))
                      (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1)))
                      $d.fuse)
           bytecode ($d.abstract #$.V1_6 #$.Public $.noneC hostL.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))
                                                 (|>> ($i.ALOAD +0)
                                                      ($i.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) false)
                                                      ($i.ALOAD +0)
                                                      ($i.ILOAD +1)
                                                      ($i.PUTFIELD hostL.function-class partials-field $t.int)
                                                      $i.RETURN))
                                      applyI))]
     _ (commonT.store-class hostL.function-class bytecode)]
    (wrap bytecode)))

(def: translate-runnable
  (Meta commonT.Bytecode)
  (do macro.Monad<Meta>
    [_ (wrap [])
     #let [procedure-field "procedure"
           bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runnable-class (list) ["java.lang.Object" (list)] (list ["java.lang.Runnable" (list)])
                              (|>> ($d.field #$.Public $.finalF procedure-field $Function)
                                   ($d.method #$.Public $.noneM "<init>" ($t.method (list $Function) #.None (list))
                                              (|>> ($i.ALOAD +0)
                                                   ($i.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) false)
                                                   ($i.ALOAD +0)
                                                   ($i.ALOAD +1)
                                                   ($i.PUTFIELD hostL.runnable-class procedure-field $Function)
                                                   $i.RETURN))
                                   ($d.method #$.Public $.noneM "run" ($t.method (list) #.None (list))
                                              (|>> ($i.ALOAD +0)
                                                   ($i.GETFIELD hostL.runnable-class procedure-field $Function)
                                                   $i.NULL
                                                   ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false)
                                                   $i.RETURN))
                                   ))]
     _ (commonT.store-class hostL.runnable-class bytecode)]
    (wrap bytecode)))

(def: #export translate
  (Meta [commonT.Bytecode commonT.Bytecode commonT.Bytecode])
  (do macro.Monad<Meta>
    [runtime-bc translate-runtime
     function-bc translate-function
     runnable-bc translate-runnable]
    (wrap [runtime-bc function-bc runnable-bc])))