(;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: (generate-path' generate 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 (generate 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)
                    popI))

    [_ (#;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)] subP))])
      (do meta;Monad<Meta>
        [subI (generate-path' generate stack-depth @else @end subP)]
        (wrap (case idx
                +0
                (|>. peekI
                     ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
                     ($i;int 0)
                     $i;AALOAD
                     pushI
                     subI)
                
                _
                (|>. 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
                     subI)))))
    (["lux case tuple left" "pm_left"]
     ["lux case tuple right" "pm_right"])

    (^template [<special> <flag>]
      (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))])
      (do meta;Monad<Meta>
        [subI (generate-path' generate stack-depth @else @end subP)]
        (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
                       subI)))))
    (["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 (generate-path' generate stack-depth @else @end leftP)
       rightI (generate-path' generate 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 (generate-path' generate (n.inc stack-depth) @alt-else @end leftP)
       rightI (generate-path' generate stack-depth @else @end rightP)]
      (wrap (|>. $i;DUP
                 leftI
                 ($i;label @alt-else)
                 $i;POP
                 rightI)))

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

(def: (generate-path generate path @end)
  (-> (-> ls;Synthesis (Meta $;Inst))
      ls;Path $;Label (Meta $;Inst))
  (do meta;Monad<Meta>
    [@else $i;make-label
     pathI (generate-path' generate +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 (generate-case generate valueS path)
  (-> (-> ls;Synthesis (Meta $;Inst))
      ls;Synthesis ls;Path (Meta $;Inst))
  (do meta;Monad<Meta>
    [@end $i;make-label
     valueI (generate valueS)
     pathI (generate-path generate path @end)]
    (wrap (|>. valueI
               $i;NULL
               $i;SWAP
               pushI
               pathI
               ($i;label @end)))))

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