(.module:
  [lux #- case let if]
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (data [number]
             [text]
             text/format
             (coll [list "list/" Functor<List> Fold<List>]
                   (set ["set" unordered #+ Set]))))
  (///// [reference #+ Register]
         (host ["_" scheme #+ Expression Computation Var])
         [compiler #+ "operation/" Monad<Operation>]
         (compiler [synthesis #+ Synthesis Path]))
  [//runtime #+ Operation Translator]
  [//reference])

(def: #export (let translate [valueS register bodyS])
  (-> Translator [Synthesis Register Synthesis]
      (Operation Computation))
  (do compiler.Monad<Operation>
    [valueO (translate valueS)
     bodyO (translate bodyS)]
    (wrap (_.let (list [(//reference.local' register) valueO])
            bodyO))))

(def: #export (record-get translate valueS pathP)
  (-> Translator Synthesis (List [Nat Bool])
      (Operation Expression))
  (do compiler.Monad<Operation>
    [valueO (translate valueS)]
    (wrap (list/fold (function (_ [idx tail?] source)
                       (.let [method (.if tail?
                                       //runtime.product//right
                                       //runtime.product//left)]
                         (method source (_.int (:coerce Int idx)))))
                     valueO
                     pathP))))

(def: #export (if translate [testS thenS elseS])
  (-> Translator [Synthesis Synthesis Synthesis]
      (Operation Computation))
  (do compiler.Monad<Operation>
    [testO (translate testS)
     thenO (translate thenS)
     elseO (translate elseS)]
    (wrap (_.if testO thenO elseO))))

(def: @savepoint (_.var "lux_pm_cursor_savepoint"))

(def: @cursor (_.var "lux_pm_cursor"))

(def: top _.length/1)

(def: (push! value var)
  (-> Expression Var Computation)
  (_.set! var (_.cons/2 value var)))

(def: (pop! var)
  (-> Var Computation)
  (_.set! var var))

(def: (push-cursor! value)
  (-> Expression Computation)
  (push! value @cursor))

(def: save-cursor!
  Computation
  (push! @cursor @savepoint))

(def: restore-cursor!
  Computation
  (_.set! @cursor (_.car/1 @savepoint)))

(def: cursor-top
  Computation
  (_.car/1 @cursor))

(def: pop-cursor!
  Computation
  (pop! @cursor))

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

(def: fail-pm! (_.raise/1 pm-error))

(def: @temp (_.var "lux_pm_temp"))

(exception: #export (unrecognized-path)
  "")

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

(def: (pm-catch handler)
  (-> Expression Computation)
  (_.lambda [(list $alt_error) #.None]
       (_.if (|> $alt_error (_.eqv?/2 pm-error))
         handler
         (_.raise/1 $alt_error))))

(def: (pattern-matching' translate pathP)
  (-> Translator Path (Operation Expression))
  (.case pathP
    (^ (synthesis.path/then bodyS))
    (translate bodyS)

    #synthesis.Pop
    (operation/wrap pop-cursor!)

    (#synthesis.Bind register)
    (operation/wrap (_.define (//reference.local' register) [(list) #.None]
                              cursor-top))

    (^template [<tag> <format> <=>]
      (^ (<tag> value))
      (operation/wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
                              fail-pm!)))
    ([synthesis.path/bool _.bool   _.eqv?/2]
     [synthesis.path/i64  _.int    _.=/2]
     [synthesis.path/f64  _.float  _.=/2]
     [synthesis.path/text _.string _.eqv?/2])

    (^template [<pm> <flag> <prep>]
      (^ (<pm> idx))
      (operation/wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))])
                        (_.if (_.null?/1 @temp)
                          fail-pm!
                          (push-cursor! @temp)))))
    ([synthesis.side/left  _.nil         (<|)]
     [synthesis.side/right (_.string "") inc])

    (^template [<pm> <getter> <prep>]
      (^ (<pm> idx))
      (operation/wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!)))
    ([synthesis.member/left  //runtime.product//left  (<|)]
     [synthesis.member/right //runtime.product//right inc])

    (^template [<tag> <computation>]
      (^ (<tag> [leftP rightP]))
      (do compiler.Monad<Operation>
        [leftO (pattern-matching' translate leftP)
         rightO (pattern-matching' translate rightP)]
        (wrap <computation>)))
    ([synthesis.path/seq (_.begin (list leftO
                                        rightO))]
     [synthesis.path/alt (_.with-exception-handler
                           (pm-catch (_.begin (list restore-cursor!
                                                    rightO)))
                           (_.lambda [(list) #.None]
                                (_.begin (list save-cursor!
                                               leftO))))])
    
    _
    (compiler.throw unrecognized-path [])))

(def: (pattern-matching translate pathP)
  (-> Translator Path (Operation Computation))
  (do compiler.Monad<Operation>
    [pattern-matching! (pattern-matching' translate pathP)]
    (wrap (_.with-exception-handler
            (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching.")))
            (_.lambda [(list) #.None]
                 pattern-matching!)))))

(def: #export (case translate [valueS pathP])
  (-> Translator [Synthesis Path] (Operation Computation))
  (do compiler.Monad<Operation>
    [valueO (translate valueS)]
    (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))]
                               [@savepoint (_.list/* (list))])))
        (pattern-matching translate pathP))))