(;module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (data text/format)
       [meta "meta/" Monad<Meta>])
  (luxc ["_" base]
        [";L" host]
        (host ["$" jvm]
              (jvm ["$t" type]
                   ["$i" inst]))
        (lang ["ls" synthesis]))
  [../runtime])

(def: $Object $;Type ($t;class "java.lang.Object" (list)))

(def: (pop-altI stack-depth)
  (-> Nat $;Inst)
  (case stack-depth
    +0 id
    +1 $i;POP
    +2 $i;POP2
    _ ## (n.> +2)
    (|>. $i;POP2
         (pop-altI (n.- +2 stack-depth)))))

(def: peekI
  $;Inst
  (|>. $i;DUP
       ($i;INVOKESTATIC hostL;runtime-class
                        "pm_peek"
                        ($t;method (list ../runtime;$Stack)
                                   (#;Some $Object)
                                   (list))
                        false)))

(def: popI
  $;Inst
  (|>. ($i;INVOKESTATIC hostL;runtime-class
                        "pm_pop"
                        ($t;method (list ../runtime;$Stack)
                                   (#;Some ../runtime;$Stack)
                                   (list))
                        false)))

(def: pushI
  $;Inst
  (|>. ($i;INVOKESTATIC hostL;runtime-class
                        "pm_push"
                        ($t;method (list ../runtime;$Stack $Object)
                                   (#;Some ../runtime;$Stack)
                                   (list))
                        false)))

(exception: #export Unrecognized-Path)

(def: (translate-path' translate stack-depth @else @end path)
  (-> (-> ls;Synthesis (Meta $;Inst))
      Nat $;Label $;Label ls;Path (Meta $;Inst))
  (case path
    (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
    (do meta;Monad<Meta>
      [bodyI (translate bodyS)]
      (wrap (|>. (pop-altI stack-depth)
                 bodyI
                 ($i;GOTO @end))))

    (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))])
    (meta/wrap popI)

    (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))])
    (meta/wrap (|>. peekI
                    ($i;ASTORE register)))

    [_ (#;Bool value)]
    (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)]
                 (|>. peekI
                      ($i;unwrap #$;Boolean)
                      (jumpI @else))))

    (^template [<tag> <prep>]
      [_ (<tag> value)]
      (meta/wrap (|>. peekI
                      ($i;unwrap #$;Long)
                      ($i;long (|> value <prep>))
                      $i;LCMP
                      ($i;IFNE @else))))
    ([#;Nat (:! Int)]
     [#;Int (: Int)]
     [#;Deg (:! Int)])

    [_ (#;Frac value)]
    (meta/wrap (|>. peekI
                    ($i;unwrap #$;Double)
                    ($i;double value)
                    $i;DCMPL
                    ($i;IFNE @else)))
    
    [_ (#;Text value)]
    (meta/wrap (|>. peekI
                    ($i;string value)
                    ($i;INVOKEVIRTUAL "java.lang.Object"
                                      "equals"
                                      ($t;method (list $Object)
                                                 (#;Some $t;boolean)
                                                 (list))
                                      false)
                    ($i;IFEQ @else)))

    (^template [<special> <method>]
      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))])
      (meta/wrap (case idx
                   +0
                   (|>. peekI
                        ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
                        ($i;int 0)
                        $i;AALOAD
                        pushI)
                   
                   _
                   (|>. peekI
                        ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
                        ($i;int (nat-to-int idx))
                        ($i;INVOKESTATIC hostL;runtime-class
                                         <method>
                                         ($t;method (list ../runtime;$Tuple $t;int)
                                                    (#;Some $Object)
                                                    (list))
                                         false)
                        pushI))))
    (["lux case tuple left" "pm_left"]
     ["lux case tuple right" "pm_right"])

    (^template [<special> <flag>]
      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))])
      (meta/wrap (<| $i;with-label (function [@success])
                     $i;with-label (function [@fail])
                     (|>. peekI
                          ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
                          ($i;int (nat-to-int idx))
                          <flag>
                          ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
                                           ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
                                                      (#;Some ../runtime;$Datum)
                                                      (list))
                                           false)
                          $i;DUP
                          ($i;IFNULL @fail)
                          ($i;GOTO @success)
                          ($i;label @fail)
                          $i;POP
                          ($i;GOTO @else)
                          ($i;label @success)
                          pushI))))
    (["lux case variant left" $i;NULL]
     ["lux case variant right" ($i;string "")])
    
    (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))])
    (do meta;Monad<Meta>
      [leftI (translate-path' translate stack-depth @else @end leftP)
       rightI (translate-path' translate stack-depth @else @end rightP)]
      (wrap (|>. leftI
                 rightI)))

    (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))])
    (do meta;Monad<Meta>
      [@alt-else $i;make-label
       leftI (translate-path' translate (n.inc stack-depth) @alt-else @end leftP)
       rightI (translate-path' translate stack-depth @else @end rightP)]
      (wrap (|>. $i;DUP
                 leftI
                 ($i;label @alt-else)
                 $i;POP
                 rightI)))

    _
    (_;throw Unrecognized-Path (%code path))))

(def: (translate-path translate path @end)
  (-> (-> ls;Synthesis (Meta $;Inst))
      ls;Path $;Label (Meta $;Inst))
  (do meta;Monad<Meta>
    [@else $i;make-label
     pathI (translate-path' translate +1 @else @end path)]
    (wrap (|>. pathI
               ($i;label @else)
               $i;POP
               ($i;INVOKESTATIC hostL;runtime-class
                                "pm_fail"
                                ($t;method (list) #;None (list))
                                false)
               $i;NULL
               ($i;GOTO @end)))))

(def: #export (translate-if testI thenI elseI)
  (-> $;Inst $;Inst $;Inst $;Inst)
  (<| $i;with-label (function [@else])
      $i;with-label (function [@end])
      (|>. testI
           ($i;unwrap #$;Boolean)
           ($i;IFEQ @else)
           thenI
           ($i;GOTO @end)
           ($i;label @else)
           elseI
           ($i;label @end))))

(def: #export (translate-case translate valueS path)
  (-> (-> ls;Synthesis (Meta $;Inst))
      ls;Synthesis ls;Path (Meta $;Inst))
  (do meta;Monad<Meta>
    [@end $i;make-label
     valueI (translate valueS)
     pathI (translate-path translate path @end)]
    (wrap (|>. valueI
               $i;NULL
               $i;SWAP
               pushI
               pathI
               ($i;label @end)))))

(def: #export (translate-let translate register inputS exprS)
  (-> (-> ls;Synthesis (Meta $;Inst))
      Nat ls;Synthesis ls;Synthesis (Meta $;Inst))
  (do meta;Monad<Meta>
    [inputI (translate inputS)
     exprI (translate exprS)]
    (wrap (|>. inputI
               ($i;ASTORE register)
               exprI))))