(;module:
  lux
  (lux (control ["p" parser])
       (data [maybe]
             ["e" error]
             [number]
             [product]
             text/format
             (coll [list "list/" Functor<List> Fold<List> Monoid<List>]
                   [dict #+ Dict]))
       (meta [code]
             ["s" syntax]))
  (luxc ["&" base]
        (lang ["la" analysis]
              ["ls" synthesis])
        (synthesizer ["&&;" structure]
                     ["&&;" case]
                     ["&&;" function]
                     ["&&;" loop])
        ))

(def: init-env (List ls;Variable) (list))
(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>))

(def: (prepare-body inner-arity arity body)
  (-> Nat Nat ls;Synthesis ls;Synthesis)
  (if (&&function;nested? inner-arity)
    body
    (&&loop;reify-recursion arity body)))

(def: (parse-environment env)
  (-> (List Code) (e;Error (List ls;Variable)))
  (s;run env (p;some s;int)))

(def: (let$ register inputS bodyS)
  (-> Nat ls;Synthesis ls;Synthesis ls;Synthesis)
  (` ("lux let" (~ (code;nat register)) (~ inputS) (~ bodyS))))

(def: (if$ testS thenS elseS)
  (-> ls;Synthesis ls;Synthesis ls;Synthesis ls;Synthesis)
  (` ("lux if" (~ testS)
      (~ thenS)
      (~ elseS))))

(def: (function$ arity environment body)
  (-> ls;Arity (List ls;Variable) ls;Synthesis ls;Synthesis)
  (` ("lux function" (~ (code;nat arity))
      [(~@ (list/map code;int environment))]
      (~ body))))

(def: (variant$ tag last? valueS)
  (-> Nat Bool ls;Synthesis ls;Synthesis)
  (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS))))

(def: (var$ var)
  (-> ls;Variable ls;Synthesis)
  (` ((~ (code;int var)))))

(def: (procedure$ name argsS)
  (-> Text (List ls;Synthesis) ls;Synthesis)
  (` ((~ (code;text name)) (~@ argsS))))

(def: (call$ funcS argsS)
  (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis)
  (` ("lux call" (~ funcS) (~@ argsS))))

(def: (synthesize-case synthesize inputA branchesA)
  (-> (-> la;Analysis ls;Synthesis)
      la;Analysis (List [la;Pattern la;Analysis])
      ls;Synthesis)
  (let [inputS (synthesize inputA)]
    (case (list;reverse branchesA)
      (^multi (^ (list [(#la;BindP input-register)
                        (#la;Variable (#;Local output-register))]))
              (n.= input-register output-register))
      inputS

      (^ (list [(#la;BindP register) bodyA]))
      (let$ register inputS (synthesize bodyA))
      
      (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA]))
           (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA])))
      (if$ inputS (synthesize thenA) (synthesize elseA))

      (#;Cons [lastP lastA] prevsPA)
      (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
                                (function [pattern expr]
                                  (|> (synthesize expr)
                                      (~) ("lux case exec")
                                      ("lux case seq" (~ (&&case;path pattern)))
                                      (`))))]
        (` ("lux case" (~ inputS)
            (~ (list/fold &&case;weave
                          (transform-branch lastP lastA)
                          (list/map (product;uncurry transform-branch) prevsPA))))))

      _
      (undefined)
      )))

(def: #export (synthesize analysis)
  (-> la;Analysis ls;Synthesis)
  (loop [outer-arity +0
         resolver init-resolver
         num-locals +0
         exprA analysis]
    (case exprA
      #la;Unit
      (' [])

      (^template [<from> <to>]
        (<from> value)
        (<to> value))
      ([#la;Bool       code;bool]
       [#la;Nat        code;nat]
       [#la;Int        code;int]
       [#la;Deg        code;deg]
       [#la;Frac       code;frac]
       [#la;Text       code;text]
       [#la;Definition code;symbol])

      (#la;Product _)
      (` [(~@ (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))])

      (#la;Sum choice)
      (let [[tag last? value] (&&structure;unfold-variant choice)]
        (variant$ tag last? (recur +0 resolver num-locals value)))

      (#la;Variable ref)
      (case ref
        (#;Local register)
        (if (&&function;nested? outer-arity)
          (if (n.= +0 register)
            (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity))
                                (list/map (|>. &&function;to-local code;int (~) () (`)))))
            (var$ (&&function;adjust-var outer-arity (&&function;to-local register))))
          (var$ (&&function;to-local register)))
        
        (#;Captured register)
        (var$ (let [var (&&function;to-captured register)]
                (maybe;default var (dict;get var resolver)))))

      (#la;Case inputA branchesA)
      (synthesize-case (recur +0 resolver num-locals) inputA branchesA)
      
      (#la;Function scope bodyA)
      (let [inner-arity (n.inc outer-arity)
            raw-env (&&function;environment scope)
            env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env)
            env-vars (let [env-size (list;size raw-env)]
                       (: (List ls;Variable)
                          (case env-size
                            +0 (list)
                            _ (list/map &&function;to-captured (list;n.range +0 (n.dec env-size))))))
            resolver' (if (&&function;nested? inner-arity)
                        (list/fold (function [[from to] resolver']
                                     (dict;put from to resolver'))
                                   init-resolver
                                   (list;zip2 env-vars env))
                        (list/fold (function [var resolver']
                                     (dict;put var var resolver'))
                                   init-resolver
                                   env-vars))]
        (case (recur inner-arity resolver' +0 bodyA)
          (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))])
          (let [arity (n.inc arity')]
            (function$ arity env (prepare-body inner-arity arity bodyS')))

          bodyS
          (function$ +1 env (prepare-body inner-arity +1 bodyS))))

      (#la;Apply _)
      (let [[funcA argsA] (&&function;unfold-apply exprA)
            funcS (recur +0 resolver num-locals funcA)
            argsS (list/map (recur +0 resolver num-locals) argsA)]
        (case funcS
          (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))])
                  (and (n.= _arity (list;size argsS))
                       (not (&&loop;contains-self-reference? _bodyS)))
                  [(parse-environment _env) (#e;Success _env)])
          (let [register-offset (if (&&function;top? outer-arity)
                                  num-locals
                                  (|> outer-arity n.inc (n.+ num-locals)))]
            (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)]
                (~ (&&loop;adjust _env register-offset _bodyS)))))

          (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))])
          (call$ funcS' (list/compose argsS' argsS))

          _
          (call$ funcS argsS)))

      (#la;Procedure name args)
      (procedure$ name (list/map (recur +0 resolver num-locals) args))
      )))