Place the "program:" macro of "lux/control/parser/cli" in its own module.

1 files changed, 176 insertions, 0 deletions

diff --git a/stdlib/source/program/aedifex/artifact/versioning.lux b/stdlib/source/program/aedifex/artifact/versioning.lux
new file mode 100644
index 000000000..df9f7dfa3
--- /dev/null
+++ b/stdlib/source/program/aedifex/artifact/versioning.lux
@@ -0,0 +1,176 @@
+(.module:
+  [lux (#- Name Type)
+   [abstract
+    [equivalence (#+ Equivalence)]
+    [monad (#+ do)]]
+   [control
+    ["." exception (#+ exception:)]
+    ["<>" parser
+     ["<.>" xml (#+ Parser)]
+     ["<.>" text]]]
+   [data
+    ["." product]
+    ["." text
+     ["%" format]]
+    [format
+     ["." xml (#+ XML)]]
+    [collection
+     ["." list ("#\." functor)]]]
+   [math
+    [number
+     ["n" nat]]]
+   ["." time (#+ Time)
+    ["." instant (#+ Instant)]
+    ["." date (#+ Date)]
+    ["." year]
+    ["." month]]]
+  ["." // (#+ Version)
+   [type (#+ Type)]
+   ["#." value (#+ Build Value)]
+   ["#." time_stamp (#+ Time_Stamp)
+    ["#/." date]
+    ["#/." time]]])
+
+(type: #export Versioning
+  {#time_stamp Time_Stamp
+   #build Build
+   #snapshot (List Type)})
+
+(def: #export init
+  {#time_stamp (instant.from_millis +0)
+   #build 0
+   #snapshot (list)})
+
+(def: #export equivalence
+  (Equivalence Versioning)
+  ($_ product.equivalence
+      instant.equivalence
+      n.equivalence
+      (list.equivalence text.equivalence)
+      ))
+
+(template [<definition> <tag>]
+  [(def: <definition> xml.Tag ["" <tag>])]
+
+  [<extension> "extension"]
+  [<value> "value"]
+  [<updated> "updated"]
+
+  [<timestamp> "timestamp"]
+  [<build_number> "buildNumber"]
+  [<last_updated> "lastUpdated"]
+  
+  [<snapshot_versions> "snapshotVersions"]
+  [<snapshot_version> "snapshotVersion"]
+  
+  [<snapshot> "snapshot"]
+  [<versioning> "versioning"]
+  )
+
+(def: (instant_format value)
+  (%.Format Instant)
+  (%.format (//time_stamp/date.format (instant.date value))
+            (//time_stamp/time.format (instant.time value))))
+
+(template [<name> <type> <tag> <pre>]
+  [(def: <name>
+     (-> <type> XML)
+     (|>> <pre> #xml.Text list (#xml.Node <tag> xml.attributes)))]
+
+  [format_extension Type ..<extension> (|>)]
+  [format_value Value ..<value> //value.format]
+  [format_updated Instant ..<updated> ..instant_format]
+
+  [format_time_stamp Instant ..<timestamp> //time_stamp.format]
+  [format_build_number Nat ..<build_number> %.nat]
+  [format_last_updated Instant ..<last_updated> ..instant_format]
+  )
+
+(def: (format_snapshot value type)
+  (-> Value Type XML)
+  (<| (#xml.Node ..<snapshot_version> xml.attributes)
+      (list (..format_extension type)
+            (..format_value value)
+            (let [[version time_stamp build] value]
+              (..format_updated time_stamp)))))
+
+(def: #export (format version (^slots [#time_stamp #build #snapshot]))
+  (-> Version Versioning XML)
+  (<| (#xml.Node ..<versioning> xml.attributes)
+      (list (<| (#xml.Node ..<snapshot> xml.attributes)
+                (list (..format_time_stamp time_stamp)
+                      (..format_build_number build)))
+            (..format_last_updated time_stamp)
+            (<| (#xml.Node ..<snapshot_versions> xml.attributes)
+                (list\map (..format_snapshot [version time_stamp build])
+                          snapshot)))))
+
+(exception: #export (time_stamp_mismatch {expected Time_Stamp} {actual Text})
+  (exception.report
+   ["Expected time-stamp" (instant_format expected)]
+   ["Actual time-stamp" actual]))
+
+(exception: #export (value_mismatch {expected Value} {actual Text})
+  (exception.report
+   ["Expected" (//value.format expected)]
+   ["Actual" actual]))
+
+(def: (sub tag parser)
+  (All [a] (-> xml.Tag (Parser a) (Parser a)))
+  (do <>.monad
+    [_ (<xml>.node tag)]
+    (<xml>.children parser)))
+
+(def: (text tag)
+  (-> xml.Tag (Parser Text))
+  (..sub tag <xml>.text))
+
+(def: last_updated_parser
+  (Parser Instant)
+  (<text>.embed (do <>.monad
+                  [date //time_stamp/date.parser
+                   time //time_stamp/time.parser]
+                  (wrap (instant.from_date_time date time)))
+                (..text ..<last_updated>)))
+
+(def: time_stamp_parser
+  (Parser Time_Stamp)
+  (<text>.embed //time_stamp.parser
+                (..text ..<timestamp>)))
+
+(def: build_parser
+  (Parser Build)
+  (<text>.embed (<>.codec n.decimal
+                          (<text>.many <text>.decimal))
+                (..text ..<build_number>)))
+
+(def: (snapshot_parser expected)
+  (-> Value (Parser Type))
+  (<| (..sub ..<snapshot_version>)
+      (do <>.monad
+        [#let [[version time_stamp build] expected]
+         updated (<xml>.somewhere (..text ..<updated>))
+         _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp updated])
+                      (\ text.equivalence = (instant_format time_stamp) updated))
+         actual (<xml>.somewhere (..text ..<value>))
+         _ (<>.assert (exception.construct ..value_mismatch [expected actual])
+                      (\ text.equivalence = (//value.format expected) actual))]
+        (<xml>.somewhere (..text ..<extension>)))))
+
+(def: #export (parser version)
+  (-> Version (Parser Versioning))
+  (<| (..sub ..<versioning>)
+      (do <>.monad
+        [[time_stamp build] (<| <xml>.somewhere
+                                (..sub ..<snapshot>)
+                                (<>.and (<xml>.somewhere ..time_stamp_parser)
+                                        (<xml>.somewhere ..build_parser)))
+         last_updated (<xml>.somewhere ..last_updated_parser)
+         _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp (instant_format last_updated)])
+                      (\ instant.equivalence = time_stamp last_updated))
+         snapshot (<| <xml>.somewhere
+                      (..sub ..<snapshot_versions>)
+                      (<>.some (..snapshot_parser [version time_stamp build])))]
+        (wrap {#time_stamp time_stamp
+               #build build
+               #snapshot snapshot}))))