path: root/new-luxc/source/luxc/lang/translation.lux

(.module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (concurrency ["P" promise]
                    ["T" task])
       (data [product]
             ["e" error]
             [text "text/" Hash<Text>]
             text/format
             (coll [list "list/" Functor<List>]
                   (dictionary ["dict" unordered])))
       [macro]
       (lang [syntax #+ Aliases]
             (type ["tc" check]))
       [host]
       [io #+ IO Process io]
       (world [blob #+ Blob]
              [file #+ File]))
  (luxc ["&" lang]
        ["&." io]
        [cache]
        [cache/description]
        [cache/io]
        (lang [".L" module]
              [".L" host]
              [".L" macro]
              [".L" extension]
              [".L" init]
              (host ["$" jvm])
              (analysis [".A" expression]
                        [".A" common])
              (synthesis [".S" expression])
              ["&." eval]))
  (/ ## [js]
     (jvm [".T" runtime]
          [".T" statement]
          [".T" common #+ Artifacts]
          [".T" expression]
          [".T" eval]
          [".T" imports])))

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

(do-template [<name>]
  [(exception: #export (<name> {message Text})
     message)]

  [Macro-Expansion-Failed]
  [Unrecognized-Statement]
  [Invalid-Macro]
  )

(def: (process-annotations annsC)
  (-> Code (Meta [## js.Expression
                  $.Inst
                  Code]))
  (do macro.Monad<Meta>
    [[_ annsA] (&.with-scope
                 (&.with-type Code
                   (analyse annsC)))
     syntheses extensionL.all-syntheses
     annsI (expressionT.translate (expressionS.synthesize syntheses annsA))
     annsV (evalT.eval annsI)]
    (wrap [annsI (:coerce Code annsV)])))

(def: (switch-compiler new-compiler)
  (-> Lux (Meta Aliases))
  (function (_ old-compiler)
    ((do macro.Monad<Meta>
       [this macro.current-module]
       (wrap (|> this (get@ #.module-aliases) (dict.from-list text.Hash<Text>) (: Aliases))))
     new-compiler)))

(def: #export (translate translate-module aliases code)
  (-> (-> Text Lux (Process Lux)) Aliases Code (Meta Aliases))
  (case code
    (^code ("lux module" (~ annsC)))
    (do macro.Monad<Meta>
      [[annsI annsV] (process-annotations annsC)
       process (importsT.translate-imports translate-module annsV)]
      (case (io.run process)
        (#e.Success compiler')
        (switch-compiler compiler')
        
        (#e.Error error)
        (macro.fail error)))

    (^code ((~ [_ (#.Text statement)]) (~+ argsC+)))
    (do macro.Monad<Meta>
      [statement (extensionL.find-statement statement)
       _ (statement argsC+)]
      (wrap aliases))
    
    (^code ((~ macroC) (~+ argsC+)))
    (do macro.Monad<Meta>
      [[_ macroA] (&.with-scope
                    (&.with-type Macro
                      (analyse macroC)))
       [_macroT _macroM _macroV] (case macroA
                                   [_ (#.Symbol macro-name)]
                                   (macro.find-def macro-name)

                                   _
                                   (&.throw Invalid-Macro (%code code)))
       expansion (: (Meta (List Code))
                    (function (_ compiler)
                      (case (macroL.expand (:coerce Macro _macroV) argsC+ compiler)
                        (#e.Error error)
                        ((&.throw Macro-Expansion-Failed error) compiler)

                        output
                        output)))
       expansion-aliases (monad.map @ (translate translate-module aliases) expansion)]
      (wrap (if (dict.empty? aliases)
              (loop [expansion-aliases expansion-aliases]
                (case expansion-aliases
                  #.Nil
                  aliases

                  (#.Cons head tail)
                  (if (dict.empty? head)
                    (recur tail)
                    head)))
              aliases)))

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

(def: (forgive-eof action)
  (-> (Meta Any) (Meta Any))
  (function (_ compiler)
    (case (action compiler)
      (#e.Error error)
      (if (ex.match? syntax.end-of-file error)
        (#e.Success [compiler []])
        (#e.Error error))

      output
      output)))

(def: #export prelude Text "lux")

(def: (with-active-compilation [module-name file-name source-code] action)
  (All [a] (-> [Text Text Text] (Meta a) (Meta a)))
  (do macro.Monad<Meta>
    [output (&.with-source-code (initL.source file-name source-code)
              action)
     _ (moduleL.flag-compiled! module-name)]
    (wrap output)))

(def: (read current-module aliases)
  (-> Text Aliases (Meta Code))
  (function (_ compiler)
    (case (syntax.read current-module aliases (get@ #.source compiler))
      (#e.Error error)
      (#e.Error error)

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

(for {"JVM" (as-is (host.import: java/lang/String
                     (getBytes [String] #try (Array byte)))

                   (def: text-to-blob
                     (-> Text Blob)
                     (|>> (:coerce String)
                          (String::getBytes ["UTF-8"])
                          e.assume)))})

## (def: (write-module target-dir file-name module-name module artifacts)
##   (-> File Text Text Module Artifacts (Process Any))
##   (do io.Monad<Process>
##     [_ (monad.map @ (product.uncurry (&io.write target-dir))
##                   (dict.entries artifacts))]
##     (&io.write target-dir
##                (format module-name "/" cache.descriptor-name)
##                (text-to-blob (%code (cache/description.write file-name module))))))

(def: no-aliases Aliases (dict.new text.Hash<Text>))

(def: #export (translate-module source-dirs target-dir module-name compiler)
  (-> (List File) File Text Lux (Process Lux))
  (do io.Monad<Process>
    [[file-name file-content] (&io.read source-dirs module-name)
     #let [module-hash (text/hash file-content)
           translate-module (translate-module source-dirs target-dir)]]
    (case (macro.run' compiler
                      (do macro.Monad<Meta>
                        [[module _] (moduleL.with-module module-hash module-name
                                      (with-active-compilation [module-name
                                                                file-name
                                                                file-content]
                                        (forgive-eof
                                         (loop [aliases no-aliases]
                                           (do @
                                             [code (read module-name aliases)
                                              #let [[cursor _] code]
                                              aliases' (&.with-cursor cursor
                                                         (translate translate-module aliases code))]
                                             (forgive-eof (recur aliases')))))))]
                        (wrap module)))
      (#e.Success [compiler module])
      (do @
        [## _ (&io.prepare-module target-dir module-name)
         ## _ (write-module target-dir file-name module-name module artifacts)
         ]
        (wrap compiler))
      
      (#e.Error error)
      (io.fail error))
    ## (case (macro.run' compiler
    ##                   (do macro.Monad<Meta>
    ##                     [[module artifacts _] (moduleL.with-module module-hash module-name
    ##                                             (commonT.with-artifacts
    ##                                               (with-active-compilation [module-name
    ##                                                                         file-name
    ##                                                                         file-content]
    ##                                                 (forgive-eof
    ##                                                  (loop [aliases no-aliases]
    ##                                                    (do @
    ##                                                      [code (read module-name aliases)
    ##                                                       #let [[cursor _] code]
    ##                                                       aliases' (&.with-cursor cursor
    ##                                                                  (translate translate-module aliases code))]
    ##                                                      (forgive-eof (recur aliases'))))))))]
    ##                     (wrap [module artifacts])))
    ##   (#e.Success [compiler [module artifacts]])
    ##   (do @
    ##     [## _ (&io.prepare-module target-dir module-name)
    ##      ## _ (write-module target-dir file-name module-name module artifacts)
    ##      ]
    ##     (wrap compiler))
    
    ##   (#e.Error error)
    ##   (io.fail error))
    ))

(def: (initialize sources target)
  (-> (List File) File (Process Lux))
  (do io.Monad<Process>
    [compiler (case (runtimeT.translate ## (initL.compiler (io.run js.init))
                                        (initL.compiler (io.run hostL.init-host))
                                        )
                ## (#e.Success [compiler disk-write])
                ## (do @
                ##   [_ (&io.prepare-target target)
                ##    _ disk-write
                ##    ## _ (cache/io.pre-load sources target (commonT.load-definition compiler))
                ##    ]
                ##   (wrap (|> compiler
                ##             (set@ [#.info #.mode] #.Build))))
                
                (#e.Success [compiler [runtime-bc function-bc]])
                (do @
                  [_ (&io.prepare-target target)
                   ## _ (&io.write target (format hostL.runtime-class ".class") runtime-bc)
                   ## _ (&io.write target (format hostL.function-class ".class") function-bc)
                   ## _ (cache/io.pre-load sources target (commonT.load-definition compiler))
                   ]
                  (wrap (|> compiler
                            (set@ [#.info #.mode] #.Build))))

                (#e.Error error)
                (io.fail error))]
    (translate-module sources target prelude compiler)))

(def: #export (translate-program sources target program)
  (-> (List File) File Text (Process Any))
  (do io.Monad<Process>
    [compiler (initialize sources target)
     _ (translate-module sources target program compiler)
     ## _ (cache/io.clean target ...)
     #let [_ (log! "Compilation complete!")]]
    (wrap [])))