Improved parsing speed for Lux code.

1 files changed, 151 insertions, 0 deletions

diff --git a/stdlib/source/program/aedifex/metadata/artifact.lux b/stdlib/source/program/aedifex/metadata/artifact.lux
new file mode 100644
index 000000000..1f8068111
--- /dev/null
+++ b/stdlib/source/program/aedifex/metadata/artifact.lux
@@ -0,0 +1,151 @@
+(.module:
+  [lux (#- Name)
+   [abstract
+    [monad (#+ do)]
+    [equivalence (#+ Equivalence)]]
+   [control
+    ["<>" 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: #export Metadata
+  {#group Group
+   #name Name
+   #versions (List Version)
+   #last-updated Instant})
+
+(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 [<definition> <tag>]
+  [(def: <definition> xml.Tag ["" <tag>])]
+
+  [<group> "groupId"]
+  [<name> "artifactId"]
+  [<version> "version"]
+  [<versions> "versions"]
+  [<last-updated> "lastUpdated"]
+  [<metadata> "metadata"]
+  )
+
+(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]
+  )
+
+(def: write-versions
+  (-> (List Version) XML)
+  (|>> (list\map ..write-version) (#xml.Node ..<versions> xml.attributes)))
+
+(def: #export (write value)
+  (-> Metadata XML)
+  (#xml.Node ..<metadata>
+             xml.attributes
+             (list (..write-group (get@ #group value))
+                   (..write-name (get@ #name value))
+                   (..write-versions (get@ #versions value))
+                   (..write-last-updated (get@ #last-updated value)))))
+
+(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: #export parser
+  (Parser Metadata)
+  (<| (..sub ..<metadata>)
+      ($_ <>.and
+          (<xml>.somewhere (..text ..<group>))
+          (<xml>.somewhere (..text ..<name>))
+          (<xml>.somewhere (<| (..sub ..<versions>)
+                               (<>.many (..text ..<version>))))
+          (<xml>.somewhere ..last-updated-parser)
+          )))
+
+(def: #export equivalence
+  (Equivalence Metadata)
+  ($_ product.equivalence
+      text.equivalence
+      text.equivalence
+      (list.equivalence text.equivalence)
+      instant.equivalence
+      ))