(.using
 [library
  [lux {"-" Alias if loop}
   ["[0]" meta]
   [abstract
    ["[0]" monad]]
   [control
    ["[0]" maybe ("[1]#[0]" monad)]]
   [data
    ["[0]" text
     ["%" format {"+" format}]]
    [collection
     ["[0]" list ("[1]#[0]" mix functor)]]]
   ["[0]" macro {"+" with_symbols}
    ["[0]" code]
    ["[0]" template]
    [syntax {"+" syntax:}
     ["|[0]|" export]]]
   [math
    [number
     ["n" nat]
     ["i" int]
     ["r" rev]
     ["f" frac]]]]]
 [//
  ["<>" parser ("[1]#[0]" monad)
   ["<[0]>" code {"+" Parser}]]])

(type: Alias
  [Text Code])

(type: Stack
  (Record
   [#bottom (Maybe Code)
    #top (List Code)]))

(def: aliases^
  (Parser (List Alias))
  (|> (<>.and <code>.local <code>.any)
      <>.some
      <code>.tuple))

(def: top^
  (Parser (List Code))
  (<code>.tuple (<>.some <code>.any)))

(def: bottom^
  (Parser Code)
  (<code>.not ..top^))

(def: stack^
  (Parser Stack)
  (<>.either (<>.and (<>.maybe bottom^)
                     ..top^)
             (<>.and (<>#each (|>> {.#Some}) bottom^)
                     (<>#in (list)))))

(def: (stack_mix tops bottom)
  (-> (List Code) Code Code)
  (list#mix (function (_ top bottom)
              (` [(~ bottom) (~ top)]))
            bottom
            tops))

(def: (singleton expander)
  (-> (Meta (List Code)) (Meta Code))
  (monad.do meta.monad
    [expansion expander]
    (case expansion
      {.#Item singleton {.#End}}
      (in singleton)

      _
      (meta.failure (format "Cannot expand to more than a single AST/Code node:" text.new_line
                            (|> expansion (list#each %.code) (text.interposed " ")))))))

(def: signature^
  (Parser [(List Alias) Stack Stack])
  (<>.either ($_ <>.and aliases^ stack^ stack^)
             ($_ <>.and (<>#in (list)) stack^ stack^)))

(syntax: .public (=> [[aliases inputs outputs] signature^])
  (let [de_alias (function (_ aliased)
                   (list#mix (function (_ [from to] pre)
                               (code.replaced (code.local from) to pre))
                             aliased
                             aliases))]
    (case [(the #bottom inputs)
           (the #bottom outputs)]
      [{.#Some bottomI} {.#Some bottomO}]
      (monad.do meta.monad
        [inputC (singleton (macro.full_expansion (stack_mix (the #top inputs) bottomI)))
         outputC (singleton (macro.full_expansion (stack_mix (the #top outputs) bottomO)))]
        (in (list (` (-> (~ (de_alias inputC))
                         (~ (de_alias outputC)))))))

      [?bottomI ?bottomO]
      (with_symbols [g!stack]
        (monad.do meta.monad
          [inputC (singleton (macro.full_expansion (stack_mix (the #top inputs) (maybe.else g!stack ?bottomI))))
           outputC (singleton (macro.full_expansion (stack_mix (the #top outputs) (maybe.else g!stack ?bottomO))))]
          (with_symbols [g!_]
            (in (list (` (All ((~ g!_) (~ g!stack))
                           (-> (~ (de_alias inputC))
                               (~ (de_alias outputC)))))))))))))

(def: beginning
  Any
  [])

(def: end
  (All (_ a) (-> [Any a] a))
  (function (_ [_ top])
    top))

(syntax: .public (||> [commands (<>.some <code>.any)])
  (in (list (` (|> (~! ..beginning) (~+ commands) ((~! ..end)))))))

(def: word
  (Parser [Code Text Code (List Code)])
  (|export|.parser
   ($_ <>.and
       <code>.local
       <code>.any
       (<>.many <code>.any))))

(syntax: .public (word: [[export_policy name type commands] ..word])
  (in (list (` (def: (~ export_policy) (~ (code.local name))
                 (~ type)
                 (|>> (~+ commands)))))))

(syntax: .public (apply [arity (<>.only (n.> 0) <code>.nat)])
  (with_symbols [g!_ g!func g!stack g!output]
    (monad.do [! meta.monad]
      [g!inputs (|> (macro.symbol "input") (list.repeated arity) (monad.all !))]
      (in (list (` (is (All ((~ g!_) (~+ g!inputs) (~ g!output))
                         (-> (-> (~+ g!inputs) (~ g!output))
                             (=> [(~+ g!inputs)] [(~ g!output)])))
                       (function ((~ g!_) (~ g!func))
                         (function ((~ g!_) (~ (stack_mix g!inputs g!stack)))
                           [(~ g!stack) ((~ g!func) (~+ g!inputs))])))))))))

(template [<arity>]
  [(`` (def: .public (~~ (template.symbol ["apply_" <arity>]))
         (..apply <arity>)))]

  [1] [2] [3] [4]
  [5] [6] [7] [8]
  )

(def: .public (push x)
  (All (_ a) (-> a (=> [] [a])))
  (function (_ stack)
    [stack x]))

(def: .public drop
  (All (_ t) (=> [t] []))
  (function (_ [stack top])
    stack))

(def: .public nip
  (All (_ _ a) (=> [_ a] [a]))
  (function (_ [[stack _] top])
    [stack top]))

(def: .public dup
  (All (_ a) (=> [a] [a a]))
  (function (_ [stack top])
    [[stack top] top]))

(def: .public swap
  (All (_ a b) (=> [a b] [b a]))
  (function (_ [[stack l] r])
    [[stack r] l]))

(def: .public rotL
  (All (_ a b c) (=> [a b c] [b c a]))
  (function (_ [[[stack a] b] c])
    [[[stack b] c] a]))

(def: .public rotR
  (All (_ a b c) (=> [a b c] [c a b]))
  (function (_ [[[stack a] b] c])
    [[[stack c] a] b]))

(def: .public &&
  (All (_ a b) (=> [a b] [(Tuple a b)]))
  (function (_ [[stack l] r])
    [stack [l r]]))

(def: .public ||L
  (All (_ a b) (=> [a] [(Or a b)]))
  (function (_ [stack l])
    [stack {0 #0 l}]))

(def: .public ||R
  (All (_ a b) (=> [b] [(Or a b)]))
  (function (_ [stack r])
    [stack {0 #1 r}]))

(template [<input> <output> <word> <func>]
  [(`` (def: .public <word>
         (=> [<input> <input>] [<output>])
         (function (_ [[stack subject] param])
           [stack (<func> param subject)])))]

  [Nat Nat  n/+  n.+]
  [Nat Nat  n/-  n.-]
  [Nat Nat  n/*  n.*]
  [Nat Nat  n//  n./]
  [Nat Nat  n/%  n.%]
  [Nat Bit  n/=  n.=]
  [Nat Bit  n/<  n.<]
  [Nat Bit  n/<= n.<=]
  [Nat Bit  n/>  n.>]
  [Nat Bit  n/>= n.>=]

  [Int Int  i/+  i.+]
  [Int Int  i/-  i.-]
  [Int Int  i/*  i.*]
  [Int Int  i//  i./]
  [Int Int  i/%  i.%]
  [Int Bit  i/=  i.=]
  [Int Bit  i/<  i.<]
  [Int Bit  i/<= i.<=]
  [Int Bit  i/>  i.>]
  [Int Bit  i/>= i.>=]

  [Rev Rev  r/+  r.+]
  [Rev Rev  r/-  r.-]
  [Rev Rev  r/*  r.*]
  [Rev Rev  r//  r./]
  [Rev Rev  r/%  r.%]
  [Rev Bit  r/=  r.=]
  [Rev Bit  r/<  r.<]
  [Rev Bit  r/<= r.<=]
  [Rev Bit  r/>  r.>]
  [Rev Bit  r/>= r.>=]

  [Frac Frac f/+  f.+]
  [Frac Frac f/-  f.-]
  [Frac Frac f/*  f.*]
  [Frac Frac f//  f./]
  [Frac Frac f/%  f.%]
  [Frac Bit  f/=  f.=]
  [Frac Bit  f/<  f.<]
  [Frac Bit  f/<= f.<=]
  [Frac Bit  f/>  f.>]
  [Frac Bit  f/>= f.>=]
  )

(def: .public if
  (All (_ ,,,0 ,,,1)
    (=> [then (=> ,,,0 ,,,1)
         else (=> ,,,0 ,,,1)]
        ,,,0 [Bit then else] ,,,1))
  (function (_ [[[stack test] then] else])
    (.if test
      (then stack)
      (else stack))))

(def: .public call
  (All (_ ,,,0 ,,,1)
    (=> [quote (=> ,,,0 ,,,1)]
        ,,,0 [quote] ,,,1))
  (function (_ [stack quote])
    (quote stack)))

(def: .public loop
  (All (_ ,,,)
    (=> [test (=> ,,, ,,, [Bit])]
        ,,, [test] ,,,))
  (function (loop [stack pred])
    (let [[stack' verdict] (pred stack)]
      (.if verdict
        (loop [stack' pred])
        stack'))))

(def: .public dip
  (All (_ ,,, a)
    (=> ,,, [a (=> ,,, ,,,)]
        ,,, [a]))
  (function (_ [[stack a] quote])
    [(quote stack) a]))

(def: .public dip_2
  (All (_ ,,, a b)
    (=> ,,, [a b (=> ,,, ,,,)]
        ,,, [a b]))
  (function (_ [[[stack a] b] quote])
    [[(quote stack) a] b]))

(def: .public do
  (All (_ ,,,0 ,,,1)
    (=> [body (=> ,,,0 ,,,1)
         pred (=> ,,,1 ,,,0 [Bit])]
        ,,,0 [pred body]
        ,,,1 [pred body]))
  (function (_ [[stack pred] body])
    [[(body stack) pred] body]))

(def: .public while
  (All (_ ,,,0 ,,,1)
    (=> [body (=> ,,,1 ,,,0)
         pred (=> ,,,0 ,,,1 [Bit])]
        ,,,0 [pred body]
        ,,,1))
  (function (while [[stack pred] body])
    (let [[stack' verdict] (pred stack)]
      (.if verdict
        (while [[(body stack') pred] body])
        stack'))))

(def: .public compose
  (All (_ ,,,0 ,,, ,,,1)
    (=> [(=> ,,,0 ,,,) (=> ,,, ,,,1)]
        [(=> ,,,0 ,,,1)]))
  (function (_ [[stack f] g])
    [stack (|>> f g)]))

(def: .public partial
  (All (_ ,,,0 ,,,1 a)
    (=> ,,,0 [a (=> ,,,0 [a] ,,,1)]
        ,,,0 [(=> ,,,0 ,,,1)]))
  (function (_ [[stack arg] quote])
    [stack (|>> (push arg) quote)]))

(word: .public when
  (All (_ ,,,)
    (=> [body (=> ,,, ,,,)]
        ,,, [Bit body]
        ,,,))
  swap
  (push ..call)
  (push ..drop)
  if)

(word: .public ?
  (All (_ a)
    (=> [Bit a a] [a]))
  rotL
  (push ..drop)
  (push ..nip)
  if)