(;module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (concurrency ["T" task])
       (data ["e" error]
             [text "text/" Hash<Text>]
             text/format
             (coll [dict]))
       [meta]
       (meta (type ["tc" check]))
       [host]
       [io]
       (world [file #+ File]))
  (luxc ["&" base]
        [";L" host]
        (host [";H" macro]
              ["$" jvm])
        ["&;" io]
        ["&;" module]
        ["&;" eval]
        (lang ["&;" syntax]
              (analysis [";A" expression]
                        [";A" common])
              (synthesis [";S" expression])
              (translation [";T" runtime]
                           [";T" statement]
                           [";T" common]
                           [";T" expression]
                           [";T" eval]))
        ))

(def: analyse
  (&;Analyser)
  (expressionA;analyser &eval;eval))

(exception: #export Macro-Expansion-Failed)
(exception: #export Unrecognized-Statement)

(def: (clean inputT)
  (-> Type (tc;Check Type))
  (case inputT
    (#;Primitive name paramsT+)
    (do tc;Monad<Check>
      [paramsT+' (monad;map @ clean paramsT+)]
      (wrap (#;Primitive name paramsT+')))

    (^or #;Void #;Unit (#;Bound _) (#;Ex _) (#;Named _))
    (:: tc;Monad<Check> wrap inputT)

    (^template [<tag>]
      (<tag> leftT rightT)
      (do tc;Monad<Check>
        [leftT' (clean leftT)
         rightT' (clean rightT)]
        (wrap (<tag> leftT' rightT'))))
    ([#;Sum] [#;Product] [#;Function] [#;Apply])

    (#;Var id)
    (do tc;Monad<Check>
      [?actualT (tc;read id)]
      (case ?actualT
        (#;Some actualT)
        (clean actualT)

        _
        (wrap inputT)))

    (^template [<tag>]
      (<tag> envT+ unquantifiedT)
      (do tc;Monad<Check>
        [envT+' (monad;map @ clean envT+)]
        (wrap (<tag> envT+' unquantifiedT))))
    ([#;UnivQ] [#;ExQ])
    ))

(def: (process-annotations annsC)
  (-> Code (Meta [$;Inst Code]))
  (do meta;Monad<Meta>
    [[_ annsA] (&;with-scope
                 (&;with-expected-type Code
                   (analyse annsC)))
     annsI (expressionT;translate (expressionS;synthesize annsA))
     annsV (evalT;eval annsI)]
    (wrap [annsI (:! Code annsV)])))

(def: (translate code)
  (-> Code (Meta Unit))
  (case code
    (^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ annsC)))
    (hostL;with-context def-name
      (&;with-fresh-type-env
        (do meta;Monad<Meta>
          [[annsI annsV] (process-annotations annsC)
           [_ valueT valueA] (&;with-scope
                               (if (meta;type? (:! Code annsV))
                                 (do @
                                   [valueA (&;with-expected-type Type
                                             (analyse valueC))]
                                   (wrap [Type valueA]))
                                 (commonA;with-unknown-type
                                   (analyse valueC))))
           valueT (&;with-type-env
                    (clean valueT))
           valueI (expressionT;translate (expressionS;synthesize valueA))
           _ (&;with-scope
               (statementT;translate-def def-name valueT valueI annsI annsV))]
          (wrap []))))

    (^code ("lux program" (~ [_ (#;Symbol ["" program-args])]) (~ programC)))
    (do meta;Monad<Meta>
      [[_ programA] (&;with-scope
                      (&;with-expected-type (type (io;IO Unit))
                        (analyse programC)))
       programI (expressionT;translate (expressionS;synthesize programA))]
      (statementT;translate-program program-args programI))

    (^code ("lux module" (~ annsC)))
    (do meta;Monad<Meta>
      [[annsI annsV] (process-annotations annsC)]
      (&;fail (%code annsV)))

    (^code ((~ [_ (#;Symbol macro-name)]) (~@ args)))
    (do meta;Monad<Meta>
      [macro-name (meta;normalize macro-name)
       [def-type def-anns def-value] (meta;find-def macro-name)]
      (if (meta;macro? def-anns)
        (do @
          [expansion (function [compiler]
                       (case (macroH;expand (:! Macro def-value) args compiler)
                         (#e;Success [compiler' output])
                         (#e;Success [compiler' output])

                         (#e;Error error)
                         ((&;throw Macro-Expansion-Failed error) compiler)))
           _ (monad;map @ translate expansion)]
          (wrap []))
        (&;throw Unrecognized-Statement (%code code))))

    _
    (&;throw Unrecognized-Statement (%code code))))

(def: (exhaust action)
  (All [a] (-> (Meta a) (Meta Unit)))
  (function [compiler]
    (case (action compiler)
      (#e;Success [compiler' _])
      ((exhaust action) compiler')
      
      (#e;Error error)
      (if (ex;match? &syntax;End-Of-File error)
        (#e;Success [compiler []])
        (#e;Error error)))))

(def: prelude Text "lux")

(def: (with-active-compilation [module-name file-name source-code] action)
  (All [a] (-> [Text Text Text] (Meta a) (Meta a)))
  (do meta;Monad<Meta>
    [#let [init-cursor [file-name +1 +0]]
     output (&;with-source-code [init-cursor +0 source-code]
              action)
     _ (&module;flag-compiled! module-name)]
    (wrap output)))

(def: (parse current-module)
  (-> Text (Meta Code))
  (function [compiler]
    (case (&syntax;parse current-module (get@ #;source compiler))
      (#e;Error error)
      (#e;Error error)

      (#e;Success [source' output])
      (#e;Success [(set@ #;source source' compiler)
                   output]))))

(def: (translate-module source-dirs module-name target-dir compiler)
  (-> (List File) Text File Compiler (T;Task Compiler))
  (do T;Monad<Task>
    [_ (&io;prepare-module target-dir module-name)
     [file-name file-content] (&io;read-module source-dirs module-name)
     #let [module-hash (text/hash file-content)]]
    (case (meta;run' compiler
                     (do meta;Monad<Meta>
                       [[_ artifacts _] (&module;with-module module-hash module-name
                                          (commonT;with-artifacts
                                            (with-active-compilation [module-name
                                                                      file-name
                                                                      file-content]
                                              (exhaust
                                               (do @
                                                 [code (parse module-name)
                                                  #let [[cursor _] code]]
                                                 (&;with-cursor cursor
                                                   (translate code)))))))]
                       (wrap artifacts)
                       ## (&module;translate-descriptor module-name)
                       ))
      (#e;Success [compiler artifacts ## module-descriptor
                   ])
      (do @
        [## _ (&io;write-module module-name module-descriptor)
         _ (monad;map @ (function [[class-name class-bytecode]]
                          (&io;write-file target-dir class-name class-bytecode))
                      (dict;entries artifacts))]
        (wrap compiler))
      
      (#e;Error error)
      (T;fail error))))

(def: init-cursor Cursor ["" +1 +0])

(def: #export init-type-context
  Type-Context
  {#;ex-counter +0
   #;var-counter +0
   #;var-bindings (list)})

(def: #export init-info
  Info
  {#;target  "JVM"
   #;version &;version
   #;mode    #;Build})

(def: #export (init-compiler host)
  (-> commonT;Host Compiler)
  {#;info            init-info
   #;source          [init-cursor +0 ""]
   #;cursor          init-cursor
   #;current-module  #;None
   #;modules         (list)
   #;scopes          (list)
   #;type-context    init-type-context
   #;expected        #;None
   #;seed            +0
   #;scope-type-vars (list)
   #;host            (:! Void host)})

(def: #export (translate-program program target sources)
  (-> Text File (List File) (T;Task Unit))
  (do T;Monad<Task>
    [compiler (|> (case (runtimeT;translate (init-compiler (io;run hostL;init-host)))
                    (#e;Error error)
                    (T;fail error)

                    (#e;Success [compiler [runtime-bc function-bc]])
                    (do @
                      [_ (&io;prepare-target target)
                       _ (&io;write-file target hostL;runtime-class runtime-bc)
                       _ (&io;write-file target hostL;function-class function-bc)]
                      (wrap compiler)))
                  (: (T;Task Compiler))
                  (:: @ map (translate-module sources prelude target)) (:: @ join)
                  (:: @ map (translate-module sources program target)) (:: @ join))
     #let [_ (log! "Compilation complete!")]]
    (wrap [])))