(.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 [ruby #+ Ruby Expression Statement])))
  [//]
  (// [".T" runtime]
      [".T" primitive]
      [".T" reference]))

(def: (expression-block body)
  (-> Statement Expression)
  (ruby.call (list)
             (ruby.lambda #.None (list)
                     body)))

(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
           (ruby.block! (list (ruby.set! (list (referenceT.variable register)) valueO)
                              (ruby.return! bodyO)))))))

(def: #export (translate-record-get translate valueS path)
  (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bool])
      (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 (ruby.int (:! Int idx)))))
                     valueO
                     path))))

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

(def: savepoint
  Expression
  "pm_cursor_savepoint")

(def: cursor
  Expression
  "pm_cursor")

(def: (push-cursor! value)
  (-> Expression Statement)
  (ruby.statement (ruby.send "push" (list value) cursor)))

(def: save-cursor!
  Statement
  (ruby.statement
   (ruby.send "push"
              (list (ruby.array-range (ruby.int 0) (ruby.int -1) cursor))
              savepoint)))

(def: restore-cursor!
  Statement
  (ruby.set! (list cursor) (ruby.send "pop" (list) savepoint)))

(def: cursor-top
  Expression
  (ruby.nth (ruby.- (ruby.int 1)
                    (ruby.length cursor))
            cursor))

(def: pop-cursor!
  Statement
  (ruby.statement (ruby.send "pop" (list) cursor)))

(def: pm-error
  Expression
  (ruby.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 (ruby.return! bodyO)))

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

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

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

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

    (^code ("lux case seq" (~ leftP) (~ rightP)))
    (do macro.Monad<Meta>
      [leftO (translate-pattern-matching' translate leftP)
       rightO (translate-pattern-matching' translate rightP)]
      (wrap (ruby.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 (ruby.begin! (ruby.block! (list save-cursor!
                                            leftO))
                         (list [(list) "alt_error" (ruby.if! (ruby.= pm-error (ruby.field "message" "alt_error"))
                                                             (ruby.block! (list restore-cursor!
                                                                                rightO))
                                                             (ruby.raise "alt_error"))]))))

    _
    (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 (ruby.begin! pattern-matching
                       (list [(list) "alt_error"
                              (ruby.if! (ruby.= pm-error (ruby.field "message" "alt_error"))
                                        (ruby.raise (ruby.string "Invalid expression for pattern-matching."))
                                        (ruby.raise "alt_error"))])))))

(def: (initialize-pattern-matching stack-init)
  (-> Expression Statement)
  (ruby.block! (list (ruby.set! (list cursor) (ruby.array (list stack-init)))
                     (ruby.set! (list savepoint) (ruby.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
           (ruby.block! (list (initialize-pattern-matching valueO)
                              pattern-matching))))))