aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/program/aedifex
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/program/aedifex')
-rw-r--r--stdlib/source/program/aedifex/artifact/extension.lux8
-rw-r--r--stdlib/source/program/aedifex/metadata/snapshot.lux286
2 files changed, 292 insertions, 2 deletions
diff --git a/stdlib/source/program/aedifex/artifact/extension.lux b/stdlib/source/program/aedifex/artifact/extension.lux
index 78939260a..e108a3727 100644
--- a/stdlib/source/program/aedifex/artifact/extension.lux
+++ b/stdlib/source/program/aedifex/artifact/extension.lux
@@ -1,7 +1,7 @@
(.module:
- [lux #*
+ [lux (#- type)
[data
- [text
+ ["." text
["%" format (#+ format)]]]
[macro
["." template]]]
@@ -18,6 +18,10 @@
(-> //.Type Extension)
(|>> (format ..separator)))
+(def: #export type
+ (-> Extension //.Type)
+ (text.replace-all ..separator ""))
+
(template [<name>]
[(def: #export <name>
Extension
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
+ ))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 23:48:14 +0000