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

(def: #export (translate-let translate register valueS bodyS)
  (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis
      (Meta Expression))
  (do macro.Monad<Meta>
    [valueJS (translate valueS)
     bodyJS (translate bodyS)]
    (wrap (format "(function() {"
                  "var " (referenceT.variable register) " = " valueJS ";"
                  "return " bodyJS ";"
                  "})()"))))

(def: #export (translate-record-get translate valueS path)
  (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bool])
      (Meta Expression))
  (do macro.Monad<Meta>
    [valueJS (translate valueS)]
    (wrap (list/fold (function (_ [idx tail?] source)
                       (let [method (if tail? runtimeT.product//right runtimeT.product//left)]
                         (format method "(" source "," (|> idx .int %i) ")")))
                     (format "(" valueJS ")")
                     path))))

(def: #export (translate-if testJS thenJS elseJS)
  (-> Expression Expression Expression
      Expression)
  (format "(" testJS " ? " thenJS " : " elseJS ")"))

(def: savepoint
  Expression
  "pm_cursor_savepoint")

(def: cursor
  Expression
  "pm_cursor")

(def: (push-cursor value)
  (-> Expression Expression)
  (format cursor ".push(" value ");"))

(def: save-cursor
  Statement
  (format savepoint ".push(" cursor ".slice());"))

(def: restore-cursor
  Statement
  (format cursor " = " savepoint ".pop();"))

(def: peek-cursor
  Expression
  (format cursor "[" cursor ".length - 1]"))

(def: pop-cursor
  Statement
  (format cursor ".pop();"))

(def: pm-error
  Expression
  (%t "PM-ERROR"))

(def: fail-pattern-matching
  Statement
  (format "throw " 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>
      [bodyJS (translate bodyS)]
      (wrap (format "return " bodyJS ";")))

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

    (^code ("lux case bind" (~ [_ (#.Nat register)])))
    (meta/wrap (format "var " (referenceT.variable register) " = " peek-cursor ";"))

    (^template [<tag> <translate>]
      [_ (<tag> value)]
      (do macro.Monad<Meta>
        [valueJS (<translate> value)]
        (wrap (format "if(!" (format runtimeT.int//= "(" peek-cursor "," valueJS ")") ") { " fail-pattern-matching " }"))))
    ([#.Nat primitiveT.translate-nat]
     [#.Int primitiveT.translate-int]
     [#.Rev primitiveT.translate-rev])

    (^template [<tag> <format>]
      [_ (<tag> value)]
      (meta/wrap (format "if(" peek-cursor " !== " (<format> value) ") { " fail-pattern-matching " }")))
    ([#.Bool %b]
     [#.Frac %f]
     [#.Text %t])

    (^template [<pm> <getter>]
      (^code (<pm> (~ [_ (#.Nat idx)])))
      (meta/wrap (push-cursor (format <getter> "(" peek-cursor "," (|> idx .int %i) ")"))))
    (["lux case tuple left" runtimeT.product//left]
     ["lux case tuple right" runtimeT.product//right])

    (^template [<pm> <flag>]
      (^code (<pm> (~ [_ (#.Nat idx)])))
      (meta/wrap (format "temp = " runtimeT.sum//get "(" peek-cursor "," (|> idx .int %i) "," <flag> ");"
                         "if(temp == null) {"
                         fail-pattern-matching
                         "}"
                         "else {"
                         (push-cursor "temp")
                         "}")))
    (["lux case variant left" "null"]
     ["lux case variant right" "\"\""])

    (^code ("lux case seq" (~ leftP) (~ rightP)))
    (do macro.Monad<Meta>
      [leftJS (translate-pattern-matching' translate leftP)
       rightJS (translate-pattern-matching' translate rightP)]
      (wrap (format leftJS rightJS)))

    (^code ("lux case alt" (~ leftP) (~ rightP)))
    (do macro.Monad<Meta>
      [leftJS (translate-pattern-matching' translate leftP)
       rightJS (translate-pattern-matching' translate rightP)]
      (wrap (format "try {"
                    save-cursor
                    leftJS
                    "}"
                    "catch(ex) {"
                    "if(ex === " pm-error ") {"
                    restore-cursor
                    rightJS
                    "}"
                    "else {"
                    "throw ex;"
                    "}"
                    "}")))

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

(def: report-pattern-matching-error
  Statement
  (format "if(ex === " pm-error ") {"
          "throw \"Invalid expression for pattern-matching.\";"
          "}"
          "else {"
          "throw ex;"
          "}"))

(def: (translate-pattern-matching translate path)
  (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression))
  (do macro.Monad<Meta>
    [pmJS (translate-pattern-matching' translate path)]
    (wrap (format "try {" pmJS "}"
                  "catch(ex) {"
                  report-pattern-matching-error
                  "}"))))

(def: (initialize-pattern-matching stack-init)
  (-> Expression Statement)
  (format "var temp;"
          "var " cursor " = [" stack-init "];"
          "var " savepoint " = [];"))

(def: #export (translate-case translate valueS path)
  (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression))
  (do macro.Monad<Meta>
    [valueJS (translate valueS)
     pmJS (translate-pattern-matching translate path)]
    (wrap (format "(function() {"
                  "\"use strict\";"
                  (initialize-pattern-matching valueJS)
                  pmJS
                  "})()"))))