Add local repo installation to Aedifex.

8 files changed, 196 insertions, 45 deletions

diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux
index fd269f71f..6909704dd 100644
--- a/stdlib/source/program/aedifex.lux
+++ b/stdlib/source/program/aedifex.lux
@@ -10,7 +10,9 @@
      ["." cli (#+ program:)]
      ["<c>" code]]
     [security
-     ["!" capability]]]
+     ["!" capability]]
+    [concurrency
+     ["." promise]]]
    [data
     [binary (#+ Binary)]
     ["." text
@@ -28,7 +30,9 @@
   ["." / #_
    ["#" project]
    ["#." parser]
-   ["#." pom]])
+   ["#." pom]
+   ["#." cli]
+   ["#." local]])
 
 (def: (read-file! path)
   (-> Path (IO (Try Binary)))
@@ -67,22 +71,36 @@
             [..read-code]
             [(list) (<c>.run /parser.project)])))
 
-(program: [project-file]
+(program: [{command /cli.command}]
   (do {@ io.monad}
-    [data (..read-file! project-file)]
+    [data (..read-file! /.file)]
     (case data
       (#try.Success data)
       (case (..project data)
-        (#try.Success value)
-        (do @
-          [outcome (..write-pom! /pom.file value)]
-          (case outcome
-            (#try.Success value)
-            (wrap (log! "Successfully wrote POM file!"))
-            
-            (#try.Failure error)
-            (wrap (log! (format "Could not write POM file:" text.new-line
-                                error)))))
+        (#try.Success project)
+        (case command
+          #/cli.POM
+          (do @
+            [outcome (..write-pom! /pom.file project)]
+            (case outcome
+              (#try.Success value)
+              (wrap (log! "Successfully wrote POM file!"))
+              
+              (#try.Failure error)
+              (wrap (log! (format "Could not write POM file:" text.new-line
+                                  error)))))
+          
+          #/cli.Install
+          (exec (do promise.monad
+                  [outcome (/local.install (file.async file.system) project)]
+                  (wrap (case outcome
+                          (#try.Success _)
+                          (log! "Successfully installed locally!")
+                          
+                          (#try.Failure error)
+                          (log! (format "Could not install locally:" text.new-line
+                                        error)))))
+            (wrap [])))
         
         (#try.Failure error)
         (wrap (log! (format "Invalid format file:" text.new-line
@@ -90,4 +108,4 @@
       
       (#try.Failure error)
       (wrap (log! (format "Could not read file: "
-                          (%.text project-file)))))))
+                          (%.text /.file)))))))
diff --git a/stdlib/source/program/aedifex/cli.lux b/stdlib/source/program/aedifex/cli.lux
new file mode 100644
index 000000000..5f75cac9b
--- /dev/null
+++ b/stdlib/source/program/aedifex/cli.lux
@@ -0,0 +1,16 @@
+(.module:
+  [lux #*
+   [control
+    ["<>" parser
+     ["." cli (#+ Parser)]]]])
+
+(type: #export Command
+  #POM
+  #Install)
+
+(def: #export command
+  (Parser Command)
+  ($_ <>.or
+      (cli.this "pom")
+      (cli.this "install")
+      ))
diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux
new file mode 100644
index 000000000..15d9a9323
--- /dev/null
+++ b/stdlib/source/program/aedifex/local.lux
@@ -0,0 +1,86 @@
+(.module:
+  [lux #*
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." io (#+ IO)]
+    ["." try (#+ Try)]
+    [concurrency
+     ["." promise (#+ Promise)]]
+    [security
+     ["!" capability]]]
+   [data
+    [binary (#+ Binary)]
+    ["." text
+     ["%" format (#+ format)]
+     ["." encoding]]
+    [collection
+     ["." list ("#@." monoid)]]
+    [format
+     ["." binary]
+     ["." tar]
+     ["." xml]]]
+   [world
+    ["." file (#+ Path File Directory)]]]
+  [program
+   [compositor
+    ["." export]]]
+  ["." // #_
+   ["#." project (#+ Project)]
+   ["#." pom]
+   ["#." dependency]])
+
+(def: group-separator
+  ".")
+
+(def: (local system)
+  (All [a] (-> (file.System a) Path))
+  (format "~" (:: system separator) ".m2"))
+
+(def: (repository system)
+  (All [a] (-> (file.System a) Path))
+  (format (..local system) (:: system separator) "repository"))
+
+(def: (guarantee-repository! system project)
+  (-> (file.System Promise) Project (Promise (Try Path)))
+  (do {@ (try.with promise.monad)}
+    [_ (: (Promise (Try (Directory Promise)))
+          (file.get-directory promise.monad system (..local system)))
+     #let [root (..repository system)
+           identity (get@ #//project.identity project)]
+     _ (: (Promise (Try (Directory Promise)))
+          (file.get-directory promise.monad system root))]
+    (monad.fold @
+                (function (_ child parent)
+                  (do @
+                    [#let [path (format parent (:: system separator) child)]
+                     _ (: (Promise (Try (Directory Promise)))
+                          (file.get-directory promise.monad system path))]
+                    (wrap path)))
+                root
+                (list@compose (|> identity
+                                  (get@ #//project.group)
+                                  (text.split-all-with ..group-separator))
+                              (list (get@ #//project.name identity)
+                                    (get@ #//project.version identity))))))
+
+(def: (save! system content file)
+  (-> (file.System Promise) Binary Path (Promise (Try Any)))
+  (do (try.with promise.monad)
+    [file (: (Promise (Try (File Promise)))
+             (file.get-file promise.monad system file))]
+    (!.use (:: file over-write) [content])))
+
+(def: #export (install system project)
+  (-> (file.System Promise) Project (Promise (Try Any)))
+  (do (try.with promise.monad)
+    [repository (..guarantee-repository! system project)
+     #let [identity (get@ #//project.identity project)
+           artifact-name (format repository
+                                 (:: system separator) (get@ #//project.name identity)
+                                 "-" (get@ #//project.version identity))]
+     package (export.library system (get@ #//project.sources project))
+     _ (..save! system (binary.run tar.writer package)
+                (format artifact-name "." //dependency.lux-library))]
+    (..save! system (|> project //pom.project (:: xml.codec encode) encoding.to-utf8)
+             (format artifact-name //pom.extension))))
diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux
index f3bdbe34f..1a4b2f638 100644
--- a/stdlib/source/program/aedifex/parser.lux
+++ b/stdlib/source/program/aedifex/parser.lux
@@ -121,6 +121,10 @@
        (<>.default //dependency.lux-library ..type)
        )))
 
+(def: source
+  (Parser /.Source)
+  <c>.text)
+
 (def: #export project
   (Parser /.Project)
   (<| <c>.form
@@ -137,4 +141,7 @@
               (<| (<>.default (list))
                   (..bundle (' #dependencies))
                   ..dependency)
+              (<| (<>.default (list "source"))
+                  (..bundle (' #sources))
+                  ..source)
               ))))
diff --git a/stdlib/source/program/aedifex/pom.lux b/stdlib/source/program/aedifex/pom.lux
index d19ec5902..102728e1e 100644
--- a/stdlib/source/program/aedifex/pom.lux
+++ b/stdlib/source/program/aedifex/pom.lux
@@ -16,6 +16,9 @@
 (def: #export file
   "pom.xml")
 
+(def: #export extension
+  ".pom")
+
 (def: version
   XML
   (#_.Node ["" "modelVersion"] _.attrs
diff --git a/stdlib/source/program/aedifex/project.lux b/stdlib/source/program/aedifex/project.lux
index a0891951f..9f98ebc51 100644
--- a/stdlib/source/program/aedifex/project.lux
+++ b/stdlib/source/program/aedifex/project.lux
@@ -1,10 +1,14 @@
 (.module:
-  [lux (#- Name Info)
+  [lux (#- Name Info Source)
    [world
-    [net (#+ URL)]]]
+    [net (#+ URL)]
+    [file (#+ Path)]]]
   [//
    ["." dependency]])
 
+(def: #export file
+  "project.lux")
+
 (type: #export Group
   Text)
 
@@ -61,8 +65,12 @@
 (type: #export Dependency
   [Artifact dependency.Type])
 
+(type: #export Source
+  Path)
+
 (type: #export Project
   {#identity Artifact
    #info Info
    #repositories (List Repository)
-   #dependencies (List Dependency)})
+   #dependencies (List Dependency)
+   #sources (List Source)})
diff --git a/stdlib/source/program/compositor/cli.lux b/stdlib/source/program/compositor/cli.lux
index 03235bbad..4c4384636 100644
--- a/stdlib/source/program/compositor/cli.lux
+++ b/stdlib/source/program/compositor/cli.lux
@@ -12,9 +12,14 @@
    [world
     [file (#+ Path)]]])
 
-(type: #export Source Path)
-(type: #export Library Path)
-(type: #export Target Path)
+(type: #export Source
+  Path)
+
+(type: #export Library
+  Path)
+
+(type: #export Target
+  Path)
 
 (type: #export Compilation
   [(List Source) (List Library) Target Module])
diff --git a/stdlib/source/program/compositor/export.lux b/stdlib/source/program/compositor/export.lux
index f6a78ed78..468b1ef9d 100644
--- a/stdlib/source/program/compositor/export.lux
+++ b/stdlib/source/program/compositor/export.lux
@@ -1,5 +1,5 @@
 (.module:
-  [lux #*
+  [lux (#- Source)
    [abstract
     ["." monad (#+ do)]]
    [control
@@ -27,7 +27,10 @@
    [world
     ["." file]]]
   [//
-   [cli (#+ Export)]])
+   [cli (#+ Source Export)]])
+
+(def: file
+  "library.tar")
 
 (def: no-ownership
   tar.Ownership
@@ -37,26 +40,31 @@
     {#tar.user commons
      #tar.group commons}))
 
-(def: #export (export system extension [sources target])
-  (-> (file.System Promise) Extension Export (Promise (Try Any)))
-  (let [package (format target (:: system separator) "library.tar")]
+(def: #export (library system sources)
+  (-> (file.System Promise) (List Source) (Promise (Try tar.Tar)))
+  (do (try.with promise.monad)
+    [files (io.enumerate system sources)]
+    (|> (dictionary.entries files)
+        (monad.map try.monad
+                   (function (_ [path source-code])
+                     (do try.monad
+                       [path (|> path
+                                 (text.replace-all (:: system separator) .module-separator)
+                                 tar.path)
+                        source-code (tar.content source-code)]
+                       (wrap (#tar.Normal [path
+                                           (instant.from-millis +0)
+                                           tar.none
+                                           ..no-ownership
+                                           source-code])))))
+        (:: try.monad map row.from-list)
+        (:: promise.monad wrap))))
+
+(def: #export (export system [sources target])
+  (-> (file.System Promise) Export (Promise (Try Any)))
+  (let [package (format target (:: system separator) ..file)]
     (do (try.with promise.monad)
-      [package (: (Promise (Try (file.File Promise)))
-                  (file.get-file promise.monad system package))
-       files (io.enumerate system extension sources)
-       tar (|> (dictionary.entries files)
-               (monad.map try.monad
-                          (function (_ [path source-code])
-                            (do try.monad
-                              [path (|> path
-                                        (text.replace-all (:: system separator) .module-separator)
-                                        tar.path)
-                               source-code (tar.content source-code)]
-                              (wrap (#tar.Normal [path
-                                                  (instant.from-millis +0)
-                                                  tar.none
-                                                  ..no-ownership
-                                                  source-code])))))
-               (:: try.monad map (|>> row.from-list (binary.run tar.writer)))
-               promise@wrap)]
-      (!.use (:: package over-write) tar))))
+      [tar (..library system sources)
+       package (: (Promise (Try (file.File Promise)))
+                  (file.get-file promise.monad system package))]
+      (!.use (:: package over-write) (binary.run tar.writer tar)))))