(.module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (data text/format)
       [macro "macro/" Monad<Meta>])
  (luxc ["_" lang]
        (lang [".L" host]
              (host ["$" jvm]
                    (jvm ["$t" type]
                         ["$i" inst]))
              ["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 macro.Monad<Meta>
      [bodyI (translate bodyS)]
      (wrap (|>> (pop-altI stack-depth)
                 bodyI
                 ($i.GOTO @end))))

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

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

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

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

    [_ (#.Frac value)]
    (macro/wrap (|>> peekI
                     ($i.unwrap #$.Double)
                     ($i.double value)
                     $i.DCMPL
                     ($i.IFNE @else)))
    
    [_ (#.Text value)]
    (macro/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)]))])
      (macro/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)]))])
      (macro/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 macro.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 macro.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 macro.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 macro.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 macro.Monad<Meta>
    [inputI (translate inputS)
     exprI (translate exprS)]
    (wrap (|>> inputI
               ($i.ASTORE register)
               exprI))))