(.module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (data text/format
             (coll [list "list/" Fold<List>]))
       [macro #+ "meta/" Monad<Meta>])
  (luxc [lang]
        (lang ["ls" synthesis]
              (host [lua #+ Lua Expression Statement])))
  [//]
  (// [".T" runtime]
      [".T" primitive]
      [".T" reference]))

(def: (expression-block body)
  (-> Statement Expression)
  (lua.apply (lua.function (list)
               body)
             (list)))

(def: #export (translate-let translate register valueS bodyS)
  (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis
      (Meta Expression))
  (do macro.Monad<Meta>
    [valueO (translate valueS)
     bodyO (translate bodyS)]
    (wrap (expression-block
           (lua.block! (list (lua.local! (referenceT.variable register) (#.Some valueO))
                             (lua.return! bodyO)))))))

(def: #export (translate-record-get translate valueS path)
  (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bit])
      (Meta Expression))
  (do macro.Monad<Meta>
    [valueO (translate valueS)]
    (wrap (list/fold (function (_ [idx tail?] source)
                       (let [method (if tail?
                                      runtimeT.product//right
                                      runtimeT.product//left)]
                         (method source (lua.int (:coerce Int idx)))))
                     valueO
                     path))))

(def: #export (translate-if testO thenO elseO)
  (-> Expression Expression Expression Expression)
  (expression-block
   (lua.if! testO
            (lua.return! thenO)
            (lua.return! elseO))))

(def: savepoint
  Expression
  "pm_cursor_savepoint")

(def: cursor
  Expression
  "pm_cursor")

(def: (push-cursor! value)
  (-> Expression Expression)
  (lua.apply "table.insert" (list cursor value)))

(def: save-cursor!
  Statement
  (lua.apply "table.insert" (list savepoint (runtimeT.array//copy cursor))))

(def: restore-cursor!
  Statement
  (lua.set! cursor (lua.apply "table.remove" (list savepoint))))

(def: cursor-top
  Expression
  (lua.nth (lua.length cursor) cursor))

(def: pop-cursor!
  Statement
  (lua.apply "table.remove" (list cursor)))

(def: pm-error
  Expression
  (lua.string "PM-ERROR"))

(exception: #export (Unrecognized-Path {message Text})
  message)

(def: (translate-pattern-matching' translate path)
  (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression))
  (case path
    (^code ("lux case exec" (~ bodyS)))
    (do macro.Monad<Meta>
      [bodyO (translate bodyS)]
      (wrap (lua.return! bodyO)))

    (^code ("lux case pop"))
    (meta/wrap pop-cursor!)

    (^code ("lux case bind" (~ [_ (#.Nat register)])))
    (meta/wrap (lua.local! (referenceT.variable register) (#.Some cursor-top)))

    (^template [<tag> <format>]
      [_ (<tag> value)]
      (meta/wrap (lua.when! (lua.not (lua.= (|> value <format>) cursor-top))
                            (lua.return! pm-error))))
    ([#.Nat  (<| lua.int (:coerce Int))]
     [#.Int  lua.int]
     [#.Rev  (<| lua.int (:coerce Int))]
     [#.Bit lua.bool]
     [#.Frac lua.float]
     [#.Text lua.string])

    (^template [<pm> <getter>]
      (^code (<pm> (~ [_ (#.Nat idx)])))
      (meta/wrap (push-cursor! (<getter> cursor-top (lua.int (:coerce Int idx))))))
    (["lux case tuple left" runtimeT.product//left]
     ["lux case tuple right" runtimeT.product//right])

    (^template [<pm> <flag>]
      (^code (<pm> (~ [_ (#.Nat idx)])))
      (meta/wrap (lua.block! (list (lua.set! "temp" (runtimeT.sum//get cursor-top (lua.int (:coerce Int idx)) <flag>))
                                   (lua.if! (lua.= lua.nil "temp")
                                            (lua.return! pm-error)
                                            (push-cursor! "temp"))))))
    (["lux case variant left" lua.nil]
     ["lux case variant right" (lua.string "")])

    (^code ("lux case seq" (~ leftP) (~ rightP)))
    (do macro.Monad<Meta>
      [leftO (translate-pattern-matching' translate leftP)
       rightO (translate-pattern-matching' translate rightP)]
      (wrap (lua.block! (list leftO rightO))))

    (^code ("lux case alt" (~ leftP) (~ rightP)))
    (do macro.Monad<Meta>
      [leftO (translate-pattern-matching' translate leftP)
       rightO (translate-pattern-matching' translate rightP)]
      (wrap (lua.block! (list (format "local alt_success, alt_value = " (lua.apply "pcall" (list (lua.function (list)
                                                                                                   (lua.block! (list save-cursor!
                                                                                                                     leftO))))) ";")
                              (lua.if! "alt_success"
                                       (lua.return! "alt_value")
                                       (lua.if! (lua.= pm-error "alt_value")
                                                (lua.block! (list restore-cursor!
                                                                  rightO))
                                                (lua.error "alt_value")))))))

    _
    (lang.throw Unrecognized-Path (%code path))
    ))

(def: (translate-pattern-matching translate path)
  (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression))
  (do macro.Monad<Meta>
    [pattern-matching (translate-pattern-matching' translate path)]
    (wrap (lua.block! (list (format "local success, value = pcall(function () " pattern-matching " end);")
                            (lua.if! "success"
                                     (lua.return! "value")
                                     (lua.if! (lua.= pm-error "value")
                                              (lua.error (lua.string "Invalid expression for pattern-matching."))
                                              (lua.error "value"))))))))

(def: (initialize-pattern-matching stack-init)
  (-> Expression Statement)
  (lua.block! (list (lua.local! "temp" #.None)
                    (lua.local! cursor (#.Some (lua.array (list stack-init))))
                    (lua.local! savepoint (#.Some (lua.array (list)))))))

(def: #export (translate-case translate valueS path)
  (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression))
  (do macro.Monad<Meta>
    [valueO (translate valueS)
     pattern-matching (translate-pattern-matching translate path)]
    (wrap (expression-block
           (lua.block! (list (initialize-pattern-matching valueO)
                             pattern-matching))))))