path: root/stdlib/source/program/aedifex/metadata/snapshot.lux

(.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 ..<build-number>)))

(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-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: (versioning-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}))))

(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
  (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-equivalence
      ))