From abc5c5293603229b447b8b5dfa7f3275571ad982 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 15 Dec 2020 22:05:05 -0400
Subject: Compiling "lux syntax char case!" with TABLESWITCH instead of
 LOOKUPSWITCH.

---
 .../source/program/aedifex/metadata/snapshot.lux   | 286 +++++++++++++++++++++
 1 file changed, 286 insertions(+)
 create mode 100644 stdlib/source/program/aedifex/metadata/snapshot.lux

(limited to 'stdlib/source/program/aedifex/metadata/snapshot.lux')

diff --git a/stdlib/source/program/aedifex/metadata/snapshot.lux b/stdlib/source/program/aedifex/metadata/snapshot.lux
new file mode 100644
index 000000000..a94ac33c4
--- /dev/null
+++ b/stdlib/source/program/aedifex/metadata/snapshot.lux
@@ -0,0 +1,286 @@
+(.module:
+  [lux (#- Name Type)
+   [abstract
+    [monad (#+ do)]
+    [equivalence (#+ Equivalence)]]
+   [control
+    ["." exception (#+ exception:)]
+    ["<>" parser
+     ["<.>" xml (#+ Parser)]
+     ["<.>" text]]]
+   [data
+    ["." product]
+    ["." text
+     ["%" format (#+ format)]]
+    [number
+     ["n" nat]]
+    [format
+     ["." xml (#+ XML)]]
+    [collection
+     ["." list ("#\." functor)]]]
+   ["." time (#+ Time)
+    ["." instant (#+ Instant)]
+    ["." date (#+ Date)]
+    ["." year]
+    ["." month]]]
+  ["." /// #_
+   ["#." artifact (#+ Group Name Version Artifact)
+    ["#/." type (#+ Type)]]])
+
+(def: snapshot
+  "SNAPSHOT")
+
+(type: #export Time-Stamp
+  Instant)
+
+(type: #export Build
+  Nat)
+
+(type: #export Versioning
+  {#time-stamp Time-Stamp
+   #build Build
+   #snapshot (List Type)})
+
+(type: #export Value
+  [Version Time-Stamp Build])
+
+(type: #export Metadata
+  {#group Group
+   #name Name
+   #version Version
+   #versioning Versioning})
+
+(def: (pad value)
+  (-> Nat Text)
+  (if (n.< 10 value)
+    (format "0" (%.nat value))
+    (%.nat value)))
+
+(def: (date-format value)
+  (%.Format Date)
+  (format (|> value date.year year.value .nat %.nat)
+          (|> value date.month month.number ..pad)
+          (|> value date.day-of-month ..pad)))
+
+(def: (time-format value)
+  (%.Format Time)
+  (let [(^slots [#time.hour #time.minute #time.second]) (time.clock value)]
+    (format (..pad hour)
+            (..pad minute)
+            (..pad second))))
+
+(def: (instant-format value)
+  (%.Format Instant)
+  (format (..date-format (instant.date value))
+          (..time-format (instant.time value))))
+
+(template [<separator> <name>]
+  [(def: <name>
+     <separator>)]
+
+  ["." time-stamp-separator]
+  ["-" value-separator]
+  )
+
+(def: (time-stamp-format value)
+  (%.Format Time-Stamp)
+  (format (..date-format (instant.date value))
+          ..time-stamp-separator
+          (..time-format (instant.time value))))
+
+(def: (value-format [version time-stamp build])
+  (%.Format Value)
+  (format (text.replace-all ..snapshot
+                            (..time-stamp-format time-stamp)
+                            version)
+          ..value-separator
+          (%.nat build)))
+
+(template [<definition> <tag>]
+  [(def: <definition> xml.Tag ["" <tag>])]
+
+  [<group> "groupId"]
+  [<name> "artifactId"]
+  [<version> "version"]
+  [<last-updated> "lastUpdated"]
+  [<metadata> "metadata"]
+  [<versioning> "versioning"]
+  [<snapshot> "snapshot"]
+  [<timestamp> "timestamp"]
+  [<build-number> "buildNumber"]
+  [<snapshot-versions> "snapshotVersions"]
+  [<snapshot-version> "snapshotVersion"]
+  [<extension> "extension"]
+  [<value> "value"]
+  [<updated> "updated"]
+  )
+
+(template [<name> <type> <tag> <pre>]
+  [(def: <name>
+     (-> <type> XML)
+     (|>> <pre> #xml.Text list (#xml.Node <tag> xml.attributes)))]
+
+  [write-group Group ..<group> (|>)]
+  [write-name Name ..<name> (|>)]
+  [write-version Version ..<version> (|>)]
+  [write-last-updated Instant ..<last-updated> ..instant-format]
+  [write-time-stamp Instant ..<timestamp> ..time-stamp-format]
+  [write-build-number Nat ..<build-number> %.nat]
+  [write-extension Type ..<extension> (|>)]
+  [write-value Value ..<value> ..value-format]
+  [write-updated Instant ..<updated> ..instant-format]
+  )
+
+(def: (write-snapshot value type)
+  (-> Value Type XML)
+  (<| (#xml.Node ..<snapshot-version> xml.attributes)
+      (list (..write-extension type)
+            (..write-value value)
+            (let [[version time-stamp build] value]
+              (..write-updated time-stamp)))))
+
+(def: (write-versioning version (^slots [#time-stamp #build #snapshot]))
+  (-> Version Versioning XML)
+  (<| (#xml.Node ..<versioning> xml.attributes)
+      (list (<| (#xml.Node ..<snapshot> xml.attributes)
+                (list (..write-time-stamp time-stamp)
+                      (..write-build-number build)))
+            (..write-last-updated time-stamp)
+            (<| (#xml.Node ..<snapshot-versions> xml.attributes)
+                (list\map (..write-snapshot [version time-stamp build])
+                          snapshot)))))
+
+(def: #export (write (^slots [#group #name #version #versioning]))
+  (-> Metadata XML)
+  (#xml.Node ..<metadata>
+             xml.attributes
+             (list (..write-group group)
+                   (..write-name name)
+                   (..write-version version)
+                   (..write-versioning version versioning))))
+
+(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: date-parser
+  (<text>.Parser Date)
+  (do <>.monad
+    [year (<>.codec n.decimal (<text>.exactly 4 <text>.decimal))
+     year (<>.lift (year.year (.int year)))
+     month (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))
+     month (<>.lift (month.by-number month))
+     day-of-month (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))]
+    (<>.lift (date.date year month day-of-month))))
+
+(def: time-parser
+  (<text>.Parser Time)
+  (do <>.monad
+    [hour (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))
+     minute (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))
+     second (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))]
+    (<>.lift (time.time
+              {#time.hour hour
+               #time.minute minute
+               #time.second second
+               #time.milli-second 0}))))
+
+(def: last-updated-parser
+  (Parser Instant)
+  (<text>.embed (do <>.monad
+                  [date ..date-parser
+                   time ..time-parser]
+                  (wrap (instant.from-date-time date time)))
+                (..text ..<last-updated>)))
+
+(def: time-stamp-parser
+  (Parser Time-Stamp)
+  (<text>.embed (do <>.monad
+                  [date ..date-parser
+                   _ (<text>.this ..time-stamp-separator)
+                   time ..time-parser]
+                  (wrap (instant.from-date-time date time)))
+                (..text ..<timestamp>)))
+
+(def: build-parser
+  (Parser Build)
+  (<text>.embed (<>.codec n.decimal
+                          (<text>.many <text>.decimal))
+                (..text ..<timestamp>)))
+
+(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: (snapshot-parser expected)
+  (-> Value (Parser Type))
+  (<| (..sub ..<snapshot-versions>)
+      (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: (versioning-parser version)
+  (-> Version (Parser Versioning))
+  (<| (..sub ..<versioning>)
+      (do <>.monad
+        [[time-stamp build] (<| <xml>.somewhere
+                                (..sub ..<snapshot>)
+                                (<>.and ..time-stamp-parser
+                                        ..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}))))
+
+(def: #export parser
+  (Parser Metadata)
+  (<| (..sub ..<metadata>)
+      (do <>.monad
+        [group (<xml>.somewhere (..text ..<group>))
+         name (<xml>.somewhere (..text ..<name>))
+         version (<xml>.somewhere (..text ..<version>))
+         versioning (<xml>.somewhere (..versioning-parser version))]
+        (wrap {#group group
+               #name name
+               #version version
+               #versioning versioning}))))
+
+(def: versioning
+  (Equivalence Versioning)
+  ($_ product.equivalence
+      instant.equivalence
+      n.equivalence
+      (list.equivalence text.equivalence)
+      ))
+
+(def: #export equivalence
+  (Equivalence Metadata)
+  ($_ product.equivalence
+      text.equivalence
+      text.equivalence
+      text.equivalence
+      ..versioning
+      ))
-- 
cgit v1.2.3