(;module:
  lux
  (lux (data text/format
             [number]
             [product]
             (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
                   ["d" dict])))
  (luxc ["&" base]
        (lang ["la" analysis]
              ["ls" synthesis])
        (synthesizer ["&&;" structure]
                     ["&&;" case]
                     ["&&;" function]
                     ["&&;" loop])
        ))

(def: init-env (List ls;Variable) (list))
(def: init-resolver (d;Dict Int Int) (d;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: #export (synthesize analysis)
  (-> la;Analysis ls;Synthesis)
  (loop [outer-arity +0
         resolver init-resolver
         num-locals +0
         exprA analysis]
    (case exprA
      (^template [<from> <to>]
        (<from> value)
        (<to> value))
      ([#la;Unit     #ls;Unit]
       [#la;Bool     #ls;Bool]
       [#la;Nat      #ls;Nat]
       [#la;Int      #ls;Int]
       [#la;Deg      #ls;Deg]
       [#la;Real     #ls;Real]
       [#la;Text     #ls;Text]
       [#la;Definition #ls;Definition])

      (#la;Product _)
      (#ls;Tuple (L/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))

      (#la;Sum choice)
      (let [[tag last? value] (&&structure;unfold-variant choice)]
        (#ls;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)
            (<| (#ls;Call (#ls;Variable 0))
                (L/map (|>. &&function;to-local #ls;Variable))
                (list;n.range +1 (n.dec outer-arity)))
            (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register))))
          (#ls;Variable (&&function;to-local register)))
        
        (#;Captured register)
        (#ls;Variable (let [var (&&function;to-captured register)]
                        (default var (d;get var resolver)))))

      (#la;Case inputA branchesA)
      (let [inputS (recur +0 resolver num-locals 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]))
          (#ls;Let register inputS (recur +0 resolver num-locals bodyA))
          
          (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA]))
               (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA])))
          (#ls;If inputS
                  (recur +0 resolver num-locals thenA)
                  (recur +0 resolver num-locals elseA))

          (#;Cons [lastP lastA] prevsPA)
          (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
                                    (function [pattern expr]
                                      (|> (recur +0 resolver num-locals expr)
                                          #ls;ExecP
                                          (#ls;SeqP (&&case;path pattern)))))]
            (#ls;Case inputS
                      (L/fold &&case;weave
                              (transform-branch lastP lastA)
                              (L/map (product;uncurry transform-branch) prevsPA))))

          _
          (undefined)
          ))
      
      (#la;Function scope bodyA)
      (let [inner-arity (n.inc outer-arity)
            raw-env (&&function;environment scope)
            env (L/map (function [var] (default var (d;get var resolver))) raw-env)
            env-vars (let [env-size (list;size raw-env)]
                       (: (List ls;Variable)
                          (case env-size
                            +0 (list)
                            _ (L/map &&function;to-captured (list;n.range +0 (n.dec env-size))))))
            resolver' (if (&&function;nested? inner-arity)
                        (L/fold (function [[from to] resolver']
                                  (d;put from to resolver'))
                                init-resolver
                                (list;zip2 env-vars env))
                        (L/fold (function [var resolver']
                                  (d;put var var resolver'))
                                init-resolver
                                env-vars))]
        (case (recur inner-arity resolver' +0 bodyA)
          (#ls;Function arity' env' bodyS')
          (let [arity (n.inc arity')]
            (#ls;Function arity env (prepare-body inner-arity arity bodyS')))

          bodyS
          (#ls;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 (L/map (recur +0 resolver num-locals) argsA)]
        (case funcS
          (^multi (#ls;Function _arity _env _bodyS)
                  (and (n.= _arity (list;size argsS))
                       (not (&&loop;contains-self-reference? _bodyS))))
          (let [register-offset (if (&&function;top? outer-arity)
                                  num-locals
                                  (|> outer-arity n.inc (n.+ num-locals)))]
            (#ls;Loop register-offset argsS
                      (&&loop;adjust _env register-offset _bodyS)))

          (#ls;Call funcS' argsS')
          (#ls;Call funcS' (L/append argsS' argsS))

          _
          (#ls;Call funcS argsS)))

      (#la;Procedure name args)
      (#ls;Procedure name (L/map (recur +0 resolver num-locals) args))
      )))