(.module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:]
                pipe)
       (concurrency [atom #+ Atom atom])
       (data ["e" error]
             [text]
             text/format
             (coll [dict]
                   [array]))
       [macro]
       [host #+ do-to object]
       [io])
  (luxc ["&" lang]
        (lang [".L" variable #+ Register]
              (translation (jvm [".T" common])))))

(host.import org/objectweb/asm/Label)

(host.import java/lang/reflect/AccessibleObject
  (setAccessible [boolean] void))

(host.import java/lang/reflect/Method
  (invoke [Object (Array Object)] #try Object))

(host.import (java/lang/Class a)
  (getDeclaredMethod [String (Array (Class Object))] #try Method))

(host.import java/lang/Object
  (getClass [] (Class Object)))

(host.import java/lang/Integer
  (#static TYPE (Class Integer)))

(host.import java/lang/ClassLoader)

(def: ClassLoader::defineClass
  Method
  (case (Class::getDeclaredMethod ["defineClass"
                                   (|> (host.array (Class Object) +4)
                                       (host.array-write +0 (:! (Class Object) (host.class-for String)))
                                       (host.array-write +1 (Object::getClass [] (host.array byte +0)))
                                       (host.array-write +2 (:! (Class Object) Integer::TYPE))
                                       (host.array-write +3 (:! (Class Object) Integer::TYPE)))]
                                  (host.class-for java/lang/ClassLoader))
    (#e.Success method)
    (do-to method
      (AccessibleObject::setAccessible [true]))

    (#e.Error error)
    (error! error)))

(def: (define-class class-name byte-code loader)
  (-> Text commonT.Bytecode ClassLoader (e.Error Object))
  (Method::invoke [loader
                   (array.from-list (list (:! Object class-name)
                                          (:! Object byte-code)
                                          (:! Object (host.long-to-int 0))
                                          (:! Object (host.long-to-int (nat-to-int (host.array-length byte-code))))))]
                  ClassLoader::defineClass))

(def: (fetch-byte-code class-name store)
  (-> Text commonT.Class-Store (Maybe commonT.Bytecode))
  (|> store atom.read io.run (dict.get class-name)))

(def: (memory-class-loader store)
  (-> commonT.Class-Store ClassLoader)
  (object [] ClassLoader []
    []
    (ClassLoader (findClass [class-name String]) Class
                 (case (fetch-byte-code class-name store)
                   (#.Some bytecode)
                   (case (define-class class-name bytecode (:! ClassLoader _jvm_this))
                     (#e.Success class)
                     (:!! class)

                     (#e.Error error)
                     (error! (format "Class definition error: " class-name "\n"
                                     error)))

                   #.None
                   (error! (format "Class not found: " class-name))))))

(def: #export init-host
  (io.IO commonT.Host)
  (io.io (let [store (: commonT.Class-Store
                        (atom (dict.new text.Hash<Text>)))]
           {#commonT.loader (memory-class-loader store)
            #commonT.store store
            #commonT.artifacts (dict.new text.Hash<Text>)
            #commonT.context ["" +0]
            #commonT.anchor #.None})))

(def: #export (with-anchor anchor expr)
  (All [a] (-> [Label Register] (Meta a) (Meta a)))
  (.function (_ compiler)
    (let [old (:! commonT.Host (get@ #.host compiler))]
      (case (expr (set@ #.host
                        (:! Void (set@ #commonT.anchor (#.Some anchor) old))
                        compiler))
        (#e.Success [compiler' output])
        (#e.Success [(update@ #.host
                              (|>> (:! commonT.Host)
                                   (set@ #commonT.anchor (get@ #commonT.anchor old))
                                   (:! Void))
                              compiler')
                     output])

        (#e.Error error)
        (#e.Error error)))))

(exception: #export (No-Anchor {message Text})
  message)

(def: #export anchor
  (Meta [Label Register])
  (.function (_ compiler)
    (case (|> compiler (get@ #.host) (:! commonT.Host) (get@ #commonT.anchor))
      (#.Some anchor)
      (#e.Success [compiler
                   anchor])

      #.None
      ((&.throw No-Anchor "") compiler))))

(def: #export (with-context name expr)
  (All [a] (-> Text (Meta a) (Meta a)))
  (.function (_ compiler)
    (let [old (:! commonT.Host (get@ #.host compiler))]
      (case (expr (set@ #.host
                        (:! Void (set@ #commonT.context [(&.normalize-name name) +0] old))
                        compiler))
        (#e.Success [compiler' output])
        (#e.Success [(update@ #.host
                              (|>> (:! commonT.Host)
                                   (set@ #commonT.context (get@ #commonT.context old))
                                   (:! Void))
                              compiler')
                     output])

        (#e.Error error)
        (#e.Error error)))))

(def: #export (with-sub-context expr)
  (All [a] (-> (Meta a) (Meta [Text a])))
  (.function (_ compiler)
    (let [old (:! commonT.Host (get@ #.host compiler))
          [old-name old-sub] (get@ #commonT.context old)
          new-name (format old-name "$" (%i (nat-to-int old-sub)))]
      (case (expr (set@ #.host
                        (:! Void (set@ #commonT.context [new-name +0] old))
                        compiler))
        (#e.Success [compiler' output])
        (#e.Success [(update@ #.host
                              (|>> (:! commonT.Host)
                                   (set@ #commonT.context [old-name (n/inc old-sub)])
                                   (:! Void))
                              compiler')
                     [new-name output]])

        (#e.Error error)
        (#e.Error error)))))

(def: #export context
  (Meta Text)
  (.function (_ compiler)
    (#e.Success [compiler
                 (|> (get@ #.host compiler)
                     (:! commonT.Host)
                     (get@ #commonT.context)
                     (let> [name sub]
                           name))])))

(def: #export class-loader
  (Meta ClassLoader)
  (function (_ compiler)
    (#e.Success [compiler
                 (|> compiler
                     (get@ #.host)
                     (:! commonT.Host)
                     (get@ #commonT.loader))])))

(def: #export runtime-class Text "LuxRuntime")
(def: #export function-class Text "LuxFunction")
(def: #export runnable-class Text "LuxRunnable")
(def: #export unit Text "")