(.module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (data [number]
             [text]
             text/format
             (coll [list "list/" Functor<List> Fold<List>]
                   (set ["set" unordered #+ Set])))
       [macro #+ "meta/" Monad<Meta>]
       (macro [code]))
  (luxc [lang]
        (lang [".L" variable #+ Register Variable]
              ["ls" synthesis #+ Synthesis Path]
              (host [r #+ Expression SVar @@])))
  [//]
  (// [".T" runtime]
      [".T" primitive]
      [".T" reference]))

(def: #export (translate-let translate register valueS bodyS)
  (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis
      (Meta Expression))
  (do macro.Monad<Meta>
    [valueO (translate valueS)
     bodyO (translate bodyS)
     #let [$register (referenceT.variable register)]]
    (wrap (r.block
           ($_ r.then
               (r.set! $register valueO)
               bodyO)))))

(def: #export (translate-record-get translate valueS pathP)
  (-> (-> Synthesis (Meta Expression)) 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 (r.int (:coerce Int idx)))))
                     valueO
                     pathP))))

(def: #export (translate-if testO thenO elseO)
  (-> Expression Expression Expression Expression)
  (r.if testO thenO elseO))

(def: $savepoint (r.var "lux_pm_cursor_savepoint"))
(def: $cursor (r.var "lux_pm_cursor"))

(def: top r.length)
(def: next (|>> r.length (r.+ (r.int 1))))
(def: (push! value var)
  (-> Expression SVar Expression)
  (r.set-nth! (next (@@ var)) value var))
(def: (pop! var)
  (-> SVar Expression)
  (r.set-nth! (top (@@ var)) r.null var))

(def: (push-cursor! value)
  (-> Expression Expression)
  (push! value $cursor))

(def: save-cursor!
  Expression
  (push! (r.slice (r.float 1.0) (r.length (@@ $cursor)) (@@ $cursor))
         $savepoint))

(def: restore-cursor!
  Expression
  (r.set! $cursor (r.nth (top (@@ $savepoint)) (@@ $savepoint))))

(def: cursor-top
  Expression
  (|> (@@ $cursor) (r.nth (top (@@ $cursor)))))

(def: pop-cursor!
  Expression
  (pop! $cursor))

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

(def: fail-pm! (r.stop pm-error))

(def: $temp (r.var "lux_pm_temp"))

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

(def: $alt_error (r.var "alt_error"))

(def: (pm-catch handler)
  (-> Expression Expression)
  (r.function (list $alt_error)
    (r.if (|> (@@ $alt_error) (r.= pm-error))
      handler
      (r.stop (@@ $alt_error)))))

(def: (translate-pattern-matching' translate pathP)
  (-> (-> Synthesis (Meta Expression)) Path (Meta Expression))
  (case pathP
    (^code ("lux case exec" (~ bodyS)))
    (do macro.Monad<Meta>
      [bodyO (translate bodyS)]
      (wrap bodyO))

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

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

    (^template [<tag> <format>]
      [_ (<tag> value)]
      (meta/wrap (r.when (r.not (r.= (|> value <format>) cursor-top))
                         fail-pm!)))
    ([#.Bool r.bool]
     [#.Frac r.float]
     [#.Text r.string])

    (^template [<tag> <format>]
      [_ (<tag> value)]
      (meta/wrap (r.when (r.not (runtimeT.int//= (|> value <format>) cursor-top))
                         fail-pm!)))
    ([#.Nat  (<| runtimeT.int (:coerce Int))]
     [#.Int  runtimeT.int]
     [#.Rev  (<| runtimeT.int (:coerce Int))])

    (^template [<pm> <getter>]
      (^code (<pm> (~ [_ (#.Nat idx)])))
      (meta/wrap (push-cursor! (<getter> cursor-top (r.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 ($_ r.then
                     (r.set! $temp (runtimeT.sum//get cursor-top (r.int (:coerce Int idx)) <flag>))
                     (r.if (r.= r.null (@@ $temp))
                       fail-pm!
                       (push-cursor! (@@ $temp))))))
    (["lux case variant left" r.null]
     ["lux case variant right" (r.string "")])

    (^code ("lux case seq" (~ leftP) (~ rightP)))
    (do macro.Monad<Meta>
      [leftO (translate-pattern-matching' translate leftP)
       rightO (translate-pattern-matching' translate rightP)]
      (wrap ($_ r.then
                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 (r.try ($_ r.then
                       save-cursor!
                       leftO)
                   #.None
                   (#.Some (pm-catch ($_ r.then
                                         restore-cursor!
                                         rightO)))
                   #.None)))

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

(def: (translate-pattern-matching translate pathP)
  (-> (-> Synthesis (Meta Expression)) Path (Meta Expression))
  (do macro.Monad<Meta>
    [pattern-matching! (translate-pattern-matching' translate pathP)]
    (wrap (r.try pattern-matching!
                 #.None
                 (#.Some (pm-catch (r.stop (r.string "Invalid expression for pattern-matching."))))
                 #.None))))

(def: (initialize-pattern-matching! stack-init)
  (-> Expression Expression)
  ($_ r.then
      (r.set! $cursor (r.list (list stack-init)))
      (r.set! $savepoint (r.list (list)))))

(def: #export (translate-case translate valueS pathP)
  (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression))
  (do macro.Monad<Meta>
    [valueO (translate valueS)
     pattern-matching! (translate-pattern-matching translate pathP)]
    (wrap (r.block
           ($_ r.then
               (initialize-pattern-matching! valueO)
               pattern-matching!)))))