Moved default compiler process to stdlib (with caching temporarily disabled).

9 files changed, 281 insertions, 36 deletions

diff --git a/stdlib/source/lux/compiler/default.lux b/stdlib/source/lux/compiler/default.lux
index 197befb10..d5b97ad36 100644
--- a/stdlib/source/lux/compiler/default.lux
+++ b/stdlib/source/lux/compiler/default.lux
@@ -1,2 +1,187 @@
 (.module:
-  [lux #*])
+  [lux #*
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." product]
+    ["." error]
+    [text ("text/." Hash<Text>)
+     format
+     ["." encoding]]
+    [collection
+     ["." dictionary]]]
+   [type (#+ :share)]
+   ["." macro]
+   [concurrency
+    ["." promise ("promise/." Monad<Promise>)]
+    ["." task (#+ Task)]]
+   [world
+    ["." file (#+ File)]]]
+  [//
+   [meta
+    [io
+     ["." context]]]]
+  [/
+   ["." init]
+   ["." syntax (#+ Aliases)]
+   ["." phase
+    ["." analysis
+     ["." module]
+     [".A" expression]]
+    ["." translation (#+ Host)]
+    ["." statement
+     [".S" total]]]]
+  ## (luxc [cache]
+  ##       [cache/description]
+  ##       [cache/io])
+  )
+
+(def: (forgive-eof operation)
+  (All [s o]
+    (-> (phase.Operation s o) (phase.Operation s Any)))
+  (function (_ compiler)
+    (ex.catch syntax.end-of-file
+              (|>> [compiler])
+              (operation compiler))))
+
+(def: #export prelude Text "lux")
+
+(def: (read current-module aliases)
+  (-> Text Aliases (analysis.Operation Code))
+  (function (_ [bundle compiler])
+    (case (syntax.read current-module aliases (get@ #.source compiler))
+      (#error.Error error)
+      (#error.Error error)
+
+      (#error.Success [source' output])
+      (#error.Success [[bundle (set@ #.source source' compiler)]
+                       output]))))
+
+## ## (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))
+## ##                   (dictionary.entries artifacts))]
+## ##     (&io.write target-dir
+## ##                (format module-name "/" cache.descriptor-name)
+## ##                (encoding.to-utf8 (%code (cache/description.write file-name module))))))
+
+(type: Configuration
+  {#sources (List File)
+   #target File})
+
+(type: (Platform anchor expression statement)
+  {#host (Host expression statement)
+   #phase (translation.Phase anchor expression statement)
+   #runtime (translation.Operation anchor expression statement Any)
+   #file-system (file.System Task)})
+
+(with-expansions [<Platform> (as-is (Platform anchor expression statement))
+                  <Operation> (as-is (statement.Operation anchor expression statement Any))
+                  <Compiler> (as-is (statement.State+ anchor expression statement))]
+  
+  (def: (begin-module-compilation module-name file-name source-code)
+    (All [anchor expression statement]
+      (-> Text Text Text <Operation>))
+    (statement.lift-analysis!
+     (do phase.Monad<Operation>
+       [_ (module.create (text/hash source-code) module-name)
+        _ (analysis.set-current-module module-name)]
+       (analysis.set-source-code (init.source file-name source-code)))))
+
+  (def: (end-module-compilation module-name)
+    (All [anchor expression statement]
+      (-> Text <Operation>))
+    (statement.lift-analysis!
+     (module.set-compiled module-name)))
+
+  (def: (loop-module-compilation module-name)
+    (All [anchor expression statement]
+      (-> Text <Operation>))
+    (forgive-eof
+     (loop [_ []]
+       (do phase.Monad<Operation>
+         [code (statement.lift-analysis!
+                (do @
+                  [code (..read module-name syntax.no-aliases)
+                   #let [[cursor _] code]
+                   _ (analysis.set-cursor cursor)]
+                  (wrap code)))
+          _ (totalS.phase code)]
+         (forgive-eof (recur []))))))
+
+  (def: (perform-module-compilation module-name file-name source-code)
+    (All [anchor expression statement]
+      (-> Text Text Text <Operation>))
+    (do phase.Monad<Operation>
+      [_ (begin-module-compilation module-name file-name source-code)
+       _ (loop-module-compilation module-name)]
+      (end-module-compilation module-name)))
+
+  (def: #export (compile-module platform configuration module-name compiler)
+    (All [anchor expression statement]
+      (-> <Platform> Configuration Text <Compiler> (Task <Compiler>)))
+    (do task.Monad<Task>
+      [[file-name source-code] (context.read (get@ #file-system platform)
+                                             (get@ #sources configuration)
+                                             module-name)
+       [compiler' _] (<| promise/wrap
+                         (phase.run' compiler)
+                         (:share [anchor expression statement]
+                                 {<Platform>
+                                  platform}
+                                 {<Operation>
+                                  (perform-module-compilation module-name file-name source-code)}))
+       ## _ (&io.prepare-module target-dir module-name)
+       ## _ (write-module target-dir file-name module-name module artifacts)
+       ]
+      (wrap compiler')))
+
+  (def: (initialize platform configuration)
+    (All [anchor expression statement]
+      (-> <Platform> Configuration (Task <Compiler>)))
+    (do task.Monad<Task>
+      [[compiler _] (|> platform
+                        (get@ #runtime)
+                        statement.lift-translation!
+                        (phase.run' (init.state (get@ #host platform)
+                                                (get@ #phase platform)))
+                        promise/wrap)
+       ## compiler (case (runtimeT.translate ## (initL.compiler (io.run js.init))
+       ##                 (initL.compiler (io.run hostL.init-host))
+       ##                 )
+       ##            ## (#error.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))))
+
+       ##            (#error.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))))
+
+       ##            (#error.Error error)
+       ##            (io.fail error))
+       ]
+      (compile-module platform configuration prelude compiler)))
+
+  (def: #export (compile platform configuration program)
+    (All [anchor expression statement]
+      (-> <Platform> Configuration Text (Task Any)))
+    (do task.Monad<Task>
+      [compiler (initialize platform configuration)
+       _ (compile-module platform configuration program compiler)
+       ## _ (cache/io.clean target ...)
+       #let [_ (log! "Compilation complete!")]]
+      (wrap [])))
+  )
diff --git a/stdlib/source/lux/compiler/default/init.lux b/stdlib/source/lux/compiler/default/init.lux
index d768f5f7d..4bd2f807d 100644
--- a/stdlib/source/lux/compiler/default/init.lux
+++ b/stdlib/source/lux/compiler/default/init.lux
@@ -1,6 +1,7 @@
 (.module:
   lux
   [//
+   ["." evaluation]
    [phase (#+ Eval)
     [analysis
      [".A" expression]]
@@ -67,16 +68,19 @@
    #.extensions      []
    #.host            host})
 
-(def: #export (state eval translate host)
+(def: #export (state host translate)
   (All [anchor expression statement]
-    (-> Eval
+    (-> (Host expression statement)
         (translation.Phase anchor expression statement)
-        (Host expression statement)
         (statement.State+ anchor expression statement)))
-  [statementE.bundle
-   {#statement.analysis {#statement.state [analysisE.bundle (..compiler [])]
-                         #statement.phase (expressionA.analyser eval)}
-    #statement.synthesis {#statement.state [synthesisE.bundle synthesis.init]
-                          #statement.phase expressionS.synthesize}
-    #statement.translation {#statement.state [translationE.bundle (translation.state host)]
-                            #statement.phase translate}}])
+  (let [analysis-state [analysisE.bundle (..compiler host)]
+        synthesis-state [synthesisE.bundle synthesis.init]
+        translation-state [translationE.bundle (translation.state host)]
+        eval (evaluation.evaluator analysis-state synthesis-state translation-state translate)]
+    [statementE.bundle
+     {#statement.analysis {#statement.state analysis-state
+                           #statement.phase (expressionA.analyser eval)}
+      #statement.synthesis {#statement.state synthesis-state
+                            #statement.phase expressionS.synthesize}
+      #statement.translation {#statement.state translation-state
+                              #statement.phase translate}}]))
diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux
index b0776141a..974fc2473 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis.lux
@@ -280,3 +280,13 @@
 
           (#error.Error error)
           (#error.Error error))))))
+
+(do-template [<name> <type> <field> <value>]
+  [(def: #export (<name> value)
+     (-> <type> (Operation Any))
+     (extension.update (set@ <field> <value>)))]
+
+  [set-source-code    Source #.source         value]
+  [set-current-module Text   #.current-module (#.Some value)]
+  [set-cursor         Cursor #.cursor         value]
+  )
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/module.lux b/stdlib/source/lux/compiler/default/phase/analysis/module.lux
index 5812ef3d2..47b7d7331 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/module.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/module.lux
@@ -133,7 +133,7 @@
          ((///.throw cannot-define-more-than-once [self-name name]) state))))))
 
 (def: #export (create hash name)
-  (-> Nat Text (Operation []))
+  (-> Nat Text (Operation Any))
   (extension.lift
    (function (_ state)
      (let [module (new hash)]
diff --git a/stdlib/source/lux/compiler/default/phase/extension/statement.lux b/stdlib/source/lux/compiler/default/phase/extension/statement.lux
index 2c2bf4464..b1b28b6a3 100644
--- a/stdlib/source/lux/compiler/default/phase/extension/statement.lux
+++ b/stdlib/source/lux/compiler/default/phase/extension/statement.lux
@@ -23,20 +23,6 @@
     [//
      ["." evaluation]]]])
 
-(do-template [<name> <component> <operation>]
-  [(def: (<name> operation)
-     (All [anchor expression statement output]
-       (-> (<operation> output) (Operation anchor expression statement output)))
-     (extension.lift
-      (///.sub [(get@ [<component> #statement.state])
-                (set@ [<component> #statement.state])]
-               operation)))]
-
-  [lift-analysis!    #statement.analysis    analysis.Operation]
-  [lift-synthesis!   #statement.synthesis   synthesis.Operation]
-  [lift-translation! #statement.translation (translation.Operation anchor expression statement)]
-  )
-
 (def: (compile ?name ?type codeC)
   (All [anchor expression statement]
     (-> (Maybe Name) (Maybe Type) Code
@@ -46,7 +32,7 @@
      #let [analyse (get@ [#statement.analysis #statement.phase] state)
            synthesize (get@ [#statement.synthesis #statement.phase] state)
            translate (get@ [#statement.translation #statement.phase] state)]
-     [_ code//type codeA] (lift-analysis!
+     [_ code//type codeA] (statement.lift-analysis!
                            (analysis.with-scope
                              (type.with-fresh-env
                                (case ?type
@@ -62,9 +48,9 @@
                                     code//type (type.with-env
                                                  (check.clean code//type))]
                                    (wrap [code//type codeA]))))))
-     codeS (lift-synthesis!
+     codeS (statement.lift-synthesis!
             (synthesize codeA))]
-    (lift-translation!
+    (statement.lift-translation!
      (do @
        [codeT (translate codeS)
         codeV (case ?name
@@ -83,7 +69,7 @@
       (do ///.Monad<Operation>
         [[_ annotationsT annotationsV] (compile #.None (#.Some Code) annotationsC)
          #let [annotationsV (:coerce Code annotationsV)]
-         current-module (lift-analysis!
+         current-module (statement.lift-analysis!
                          (extension.lift
                           macro.current-module-name))
          [value//type valueT valueV] (compile (#.Some [current-module def-name])
@@ -91,7 +77,7 @@
                                                 (#.Some Type)
                                                 #.None)
                                               valueC)]
-        (lift-analysis!
+        (statement.lift-analysis!
          (do @
            [_ (module.define def-name [value//type annotationsV valueV])]
            (if (macro.type? annotationsV)
@@ -112,6 +98,20 @@
     [definition (extension.lift (macro.find-def def-name))]
     (module.define alias definition)))
 
+(def: def::module
+  Handler
+  (function (_ extension-name phase inputsC+)
+    (case inputsC+
+      (^ (list annotationsC))
+      (do ///.Monad<Operation>
+        [[_ annotationsT annotationsV] (compile #.None (#.Some Code) annotationsC)
+         _ (statement.lift-analysis!
+            (module.set-annotations (:coerce Code annotationsV)))]
+        (wrap []))
+
+      _
+      (///.throw bundle.invalid-syntax [extension-name]))))
+
 (def: def::alias
   Handler
   (function (_ extension-name phase inputsC+)
@@ -151,7 +151,7 @@
          _
          (///.throw bundle.invalid-syntax [extension-name]))))]
 
-  [def::analysis    analysis.Handler lift-analysis!]
+  [def::analysis    analysis.Handler statement.lift-analysis!]
   [def::synthesis   synthesis.Handler
    (<| extension.lift
        (///.sub [(get@ [#statement.synthesis #statement.state])
@@ -169,6 +169,7 @@
   Bundle
   (<| (bundle.prefix "def")
       (|> bundle.empty
+          (dictionary.put "module"      def::module)
           (dictionary.put "alias"       def::alias)
           (dictionary.put "analysis"    def::analysis)
           (dictionary.put "synthesis"   def::synthesis)
diff --git a/stdlib/source/lux/compiler/default/phase/statement.lux b/stdlib/source/lux/compiler/default/phase/statement.lux
index 8b0876cdd..daaea020c 100644
--- a/stdlib/source/lux/compiler/default/phase/statement.lux
+++ b/stdlib/source/lux/compiler/default/phase/statement.lux
@@ -1,6 +1,6 @@
 (.module:
   [lux #*]
-  [//
+  ["." //
    ["." analysis]
    ["." synthesis]
    ["." translation]
@@ -28,3 +28,18 @@
   [Handler   extension.Handler]
   [Bundle    extension.Bundle]
   )
+
+(do-template [<name> <component> <operation>]
+  [(def: #export (<name> operation)
+     (All [anchor expression statement output]
+       (-> (<operation> output)
+           (Operation anchor expression statement output)))
+     (extension.lift
+      (//.sub [(get@ [<component> #..state])
+               (set@ [<component> #..state])]
+              operation)))]
+
+  [lift-analysis!    #..analysis    analysis.Operation]
+  [lift-synthesis!   #..synthesis   synthesis.Operation]
+  [lift-translation! #..translation (translation.Operation anchor expression statement)]
+  )
diff --git a/stdlib/source/lux/compiler/default/phase/statement/total.lux b/stdlib/source/lux/compiler/default/phase/statement/total.lux
new file mode 100644
index 000000000..d2b046f5f
--- /dev/null
+++ b/stdlib/source/lux/compiler/default/phase/statement/total.lux
@@ -0,0 +1,27 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    [text
+     format]]]
+  ["." // (#+ Phase)
+   ["/." //
+    ["." extension]]])
+
+(do-template [<name>]
+  [(exception: #export (<name> {code Code})
+     (ex.report ["Statement" (%code code)]))]
+
+  [unrecognized-statement]
+  )
+
+(def: #export (phase code)
+  Phase
+  (case code
+    (^ [_ (#.Form (list& [_ (#.Text extension-name)] extension-args))])
+    (extension.apply phase [extension-name extension-args])
+
+    _
+    (///.throw unrecognized-statement code)))
diff --git a/stdlib/source/lux/compiler/default/syntax.lux b/stdlib/source/lux/compiler/default/syntax.lux
index 5b20dcff5..7faa5a4ea 100644
--- a/stdlib/source/lux/compiler/default/syntax.lux
+++ b/stdlib/source/lux/compiler/default/syntax.lux
@@ -40,9 +40,10 @@
      format]
     [collection
      ["." row (#+ Row)]
-     ["dict" dictionary (#+ Dictionary)]]]])
+     ["." dictionary (#+ Dictionary)]]]])
 
 (type: #export Aliases (Dictionary Text Text))
+(def: #export no-aliases Aliases (dictionary.new text.Hash<Text>))
 
 (def: white-space Text "\t\v \r\f")
 (def: new-line Text "\n")
@@ -555,7 +556,7 @@
         (p.either (do @
                     [_ (l.this name-separator)
                      second-part name-part^]
-                    (wrap [[(|> aliases (dict.get first-part) (maybe.default first-part))
+                    (wrap [[(|> aliases (dictionary.get first-part) (maybe.default first-part))
                             second-part]
                            ($_ n/+
                                (text.size first-part)
diff --git a/stdlib/source/lux/compiler/meta/io/context.lux b/stdlib/source/lux/compiler/meta/io/context.lux
index 6d90483e2..b0a35cf61 100644
--- a/stdlib/source/lux/compiler/meta/io/context.lux
+++ b/stdlib/source/lux/compiler/meta/io/context.lux
@@ -78,7 +78,9 @@
 (type: #export Code Text)
 
 (def: #export (read System<m> contexts name)
-  (All [m] (-> (System m) (List Context) Module (m [Text Code])))
+  (All [m]
+    (-> (System m) (List Context) Module
+        (m [Text Code])))
   (let [find-source' (find-source System<m> contexts name)]
     (do (:: System<m> &monad)
       [[path file] (try System<m>