diff options
author | Eduardo Julian | 2020-05-28 02:18:02 -0400 |
---|---|---|
committer | Eduardo Julian | 2020-05-28 02:18:02 -0400 |
commit | 2139e72d8e7c58cb355799d4a8412a0c38fb481c (patch) | |
tree | abc4dd07dc9ab0342e3cb379b40fa2c4a337e552 /stdlib | |
parent | 853642c340730b3bb23c1ac87660c5c7ecbffa93 (diff) |
Can now parse TAR files.
Diffstat (limited to '')
-rw-r--r-- | stdlib/source/lux/abstract/monad/free.lux | 2 | ||||
-rw-r--r-- | stdlib/source/lux/control/parser.lux | 35 | ||||
-rw-r--r-- | stdlib/source/lux/control/parser/binary.lux | 62 | ||||
-rw-r--r-- | stdlib/source/lux/data/binary.lux | 4 | ||||
-rw-r--r-- | stdlib/source/lux/data/format/tar.lux | 466 | ||||
-rw-r--r-- | stdlib/source/lux/time/duration.lux | 12 | ||||
-rw-r--r-- | stdlib/source/lux/time/instant.lux | 39 | ||||
-rw-r--r-- | stdlib/source/spec/lux/abstract/functor/contravariant.lux | 31 | ||||
-rw-r--r-- | stdlib/source/test/lux/abstract.lux | 13 | ||||
-rw-r--r-- | stdlib/source/test/lux/abstract/equivalence.lux | 20 | ||||
-rw-r--r-- | stdlib/source/test/lux/abstract/functor/contravariant.lux | 10 | ||||
-rw-r--r-- | stdlib/source/test/lux/abstract/order.lux | 23 | ||||
-rw-r--r-- | stdlib/source/test/lux/data.lux | 2 | ||||
-rw-r--r-- | stdlib/source/test/lux/data/format/tar.lux | 409 |
14 files changed, 991 insertions, 137 deletions
diff --git a/stdlib/source/lux/abstract/monad/free.lux b/stdlib/source/lux/abstract/monad/free.lux index 214261450..5194963b4 100644 --- a/stdlib/source/lux/abstract/monad/free.lux +++ b/stdlib/source/lux/abstract/monad/free.lux @@ -1,5 +1,5 @@ (.module: - lux + [lux #*] [/// [functor (#+ Functor)] [apply (#+ Apply)] diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux index 88eefcdaf..d854be6d0 100644 --- a/stdlib/source/lux/control/parser.lux +++ b/stdlib/source/lux/control/parser.lux @@ -92,29 +92,28 @@ (-> (Parser s a) s (Try [s a]))) (p input)) -(def: #export (some p) +(def: #export (some parser) {#.doc "0-or-more combinator."} (All [s a] (-> (Parser s a) (Parser s (List a)))) (function (_ input) - (case (p input) + (case (parser input) (#try.Failure _) (#try.Success [input (list)]) - (#try.Success [input' x]) - (run (do ..monad - [xs (some p)] - (wrap (list& x xs))) + (#try.Success [input' head]) + (run (:: ..monad map (|>> (list& head)) + (some parser)) input')))) -(def: #export (many p) +(def: #export (many parser) {#.doc "1-or-more combinator."} (All [s a] (-> (Parser s a) (Parser s (List a)))) - (do ..monad - [x p - xs (some p)] - (wrap (list& x xs)))) + (do {@ ..monad} + [head parser] + (:: @ map (|>> (list& head)) + (some parser)))) (def: #export (and p1 p2) {#.doc "Sequencing combinator."} @@ -289,7 +288,17 @@ (#try.Success [input' _]) (#try.Success [input' true])))) -(def: #export (codec Codec<a,z> parser) +(def: #export (speculative parser) + (All [s a] (-> (Parser s a) (Parser s a))) + (function (_ input) + (case (parser input) + (#try.Success [input' output]) + (#try.Success [input output]) + + output + output))) + +(def: #export (codec codec parser) (All [s a z] (-> (Codec a z) (Parser s a) (Parser s z))) (function (_ input) (case (parser input) @@ -297,7 +306,7 @@ (#try.Failure error) (#try.Success [input' to-decode]) - (case (:: Codec<a,z> decode to-decode) + (case (:: codec decode to-decode) (#try.Failure error) (#try.Failure error) diff --git a/stdlib/source/lux/control/parser/binary.lux b/stdlib/source/lux/control/parser/binary.lux index b2a1b1b52..3dc061940 100644 --- a/stdlib/source/lux/control/parser/binary.lux +++ b/stdlib/source/lux/control/parser/binary.lux @@ -8,7 +8,7 @@ ["." try (#+ Try)] ["." exception (#+ exception:)]] [data - ["." binary (#+ Binary)] + ["/" binary (#+ Binary)] [number ["n" nat] ["." frac]] @@ -40,11 +40,21 @@ (#try.Failure msg) (#try.Success [[end _] output]) - (let [length (binary.size input)] + (let [length (/.size input)] (if (n.= end length) (#try.Success output) (exception.throw ..binary-was-not-fully-read [length end]))))) +(def: #export end? + (Parser Bit) + (function (_ (^@ input [offset data])) + (#try.Success [input (n.= offset (/.size data))]))) + +(def: #export remaining + (Parser Nat) + (function (_ (^@ input [offset data])) + (#try.Success [input (n.- offset (/.size data))]))) + (type: #export Size Nat) (def: #export size/8 Size 1) @@ -63,10 +73,10 @@ (#try.Failure error) (#try.Failure error))))] - [bits/8 ..size/8 binary.read/8] - [bits/16 ..size/16 binary.read/16] - [bits/32 ..size/32 binary.read/32] - [bits/64 ..size/64 binary.read/64] + [bits/8 ..size/8 /.read/8] + [bits/16 ..size/16 /.read/16] + [bits/32 ..size/32 /.read/32] + [bits/64 ..size/64 /.read/64] ) (template [<name> <type>] @@ -126,23 +136,27 @@ 1 (wrap #1) _ (//.lift (exception.throw ..not-a-bit [value]))))) -(template [<name> <bits> <size>] +(def: #export (segment size) + (-> Nat (Parser Binary)) + (function (_ [offset binary]) + (case size + 0 (#try.Success [[offset binary] (/.create 0)]) + _ (do try.monad + [#let [end (n.+ size offset)] + output (/.slice offset (.dec end) binary)] + (wrap [[end binary] output]))))) + +(template [<name> <bits>] [(def: #export <name> (Parser Binary) (do //.monad [size (//@map .nat <bits>)] - (function (_ [offset binary]) - (case size - 0 (#try.Success [[offset binary] (binary.create 0)]) - _ (do try.monad - [#let [end (n.+ size offset)] - output (binary.slice offset (.dec end) binary)] - (wrap [[end binary] output]))))))] - - [binary/8 ..bits/8 ..size/8] - [binary/16 ..bits/16 ..size/16] - [binary/32 ..bits/32 ..size/32] - [binary/64 ..bits/64 ..size/64] + (..segment size)))] + + [binary/8 ..bits/8] + [binary/16 ..bits/16] + [binary/32 ..bits/32] + [binary/64 ..bits/64] ) (template [<name> <binary>] @@ -160,7 +174,7 @@ (def: #export text ..utf8/64) -(template [<name> <bits> <size>] +(template [<name> <bits>] [(def: #export (<name> valueP) (All [v] (-> (Parser v) (Parser (Row v)))) (do //.monad @@ -179,10 +193,10 @@ (row.add value output))) (//@wrap output)))))] - [row/8 ..bits/8 ..size/8] - [row/16 ..bits/16 ..size/16] - [row/32 ..bits/32 ..size/32] - [row/64 ..bits/64 ..size/64] + [row/8 ..bits/8] + [row/16 ..bits/16] + [row/32 ..bits/32] + [row/64 ..bits/64] ) (def: #export maybe diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux index defb62049..3853e6aa5 100644 --- a/stdlib/source/lux/data/binary.lux +++ b/stdlib/source/lux/data/binary.lux @@ -219,7 +219,9 @@ (#try.Success binary)) (exception.throw ..index-out-of-bounds [(..!size binary) idx]))) -(structure: #export equivalence (Equivalence Binary) +(structure: #export equivalence + (Equivalence Binary) + (def: (= reference sample) (`` (for {(~~ (static @.old)) (java/util/Arrays::equals reference sample) diff --git a/stdlib/source/lux/data/format/tar.lux b/stdlib/source/lux/data/format/tar.lux index a9bb06954..42e8103e7 100644 --- a/stdlib/source/lux/data/format/tar.lux +++ b/stdlib/source/lux/data/format/tar.lux @@ -9,6 +9,7 @@ ["<>" parser ["<b>" binary (#+ Parser)]]] [data + ["." product] ["." binary (#+ Binary)] ["." text (#+ Char) ["%" format (#+ format)] @@ -48,31 +49,33 @@ (def: small-size Size 6) (def: big-size Size 11) -(template [<exception> <maximum> <size> +(template [<exception> <limit> <size> <type> <in> <out> <writer> <suffix> <coercion>] - [(def: <maximum> + [(def: #export <limit> + Nat (|> ..octal-size (list.repeat <size>) - (list@fold n.* 1))) + (list@fold n.* 1) + inc)) (exception: #export (<exception> {value Nat}) (exception.report ["Value" (%.nat value)] - ["Maximum" (%.nat <maximum>)])) + ["Maximum" (%.nat (dec <limit>))])) - (abstract: <type> + (abstract: #export <type> {} Nat (def: #export (<in> value) (-> Nat (Try <type>)) - (if (|> value (n.% <maximum>) (n.= value)) + (if (|> value (n.% <limit>) (n.= value)) (#try.Success (:abstraction value)) (exception.throw <exception> [value]))) - (def: <out> + (def: #export <out> (-> <type> Nat) (|>> :representation)) @@ -89,25 +92,74 @@ (def: <coercion> (-> Nat <type>) - (|>> (n.% <maximum>) + (|>> (n.% <limit>) :abstraction)) )] - [not-a-small-number maximum-small-size ..small-size + [not-a-small-number small-limit ..small-size Small small from-small small-writer (format ..blank ..null) coerce-small] - [not-a-big-number maximum-big-size ..big-size + [not-a-big-number big-limit ..big-size Big big from-big big-writer ..blank coerce-big] ) +(exception: #export (wrong-character {expected Char} {actual Char}) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)])) + +(def: verify-small-suffix + (Parser Any) + (do <>.monad + [pre-end <b>.bits/8 + end <b>.bits/8 + _ (let [expected (`` (char (~~ (static ..blank))))] + (<>.assert (exception.construct ..wrong-character [expected pre-end]) + (n.= expected pre-end))) + _ (let [expected (`` (char (~~ (static ..null))))] + (<>.assert (exception.construct ..wrong-character [expected end]) + (n.= expected end)))] + (wrap []))) + +(def: small-parser + (Parser Small) + (do <>.monad + [digits (<b>.segment ..small-size) + digits (<>.lift + (encoding.from-utf8 digits)) + _ ..verify-small-suffix] + (<>.lift + (do {@ try.monad} + [value (:: n.octal decode digits)] + (..small value))))) + +(def: big-parser + (Parser Big) + (do <>.monad + [digits (<b>.segment ..big-size) + digits (<>.lift + (encoding.from-utf8 digits)) + end <b>.bits/8 + _ (let [expected (`` (char (~~ (static ..blank))))] + (<>.assert (exception.construct ..wrong-character [expected end]) + (n.= expected end)))] + (<>.lift + (do {@ try.monad} + [value (:: n.octal decode digits)] + (..big value))))) + (abstract: Checksum {} Text + (def: from-checksum + (-> Checksum Text) + (|>> :representation)) + (def: dummy-checksum Checksum (:abstraction " ")) @@ -116,8 +168,15 @@ (format ..blank ..null)) (def: checksum + (-> Binary Nat) + (binary.fold n.+ 0)) + + (def: checksum-checksum + (|> ..dummy-checksum :representation encoding.to-utf8 ..checksum)) + + (def: checksum-code (-> Binary Checksum) - (|>> (binary.fold n.+ 0) + (|>> ..checksum ..coerce-small ..from-small (:: n.octal encode) @@ -132,6 +191,18 @@ (|>> :representation encoding.to-utf8 (format.segment padded-size)))) + + (def: checksum-parser + (Parser [Nat Checksum]) + (do <>.monad + [ascii (<b>.segment ..small-size) + digits (<>.lift + (encoding.from-utf8 ascii)) + _ ..verify-small-suffix + value (<>.lift + (:: n.octal decode digits))] + (wrap [value + (:abstraction (format digits ..checksum-suffix))]))) ) (def: last-ascii @@ -150,11 +221,27 @@ (exception.report ["Text" (%.text text)])) -(def: name-size Size 31) -(def: path-size Size 99) - -(template [<type> <representation> <size> <exception> <in> <out> <writer> <none>] - [(abstract: <type> +(def: #export name-size Size 31) +(def: #export path-size Size 99) + +(def: (un-pad string) + (-> Binary (Try Binary)) + (case (binary.size string) + 0 (#try.Success string) + size (loop [end (dec size)] + (case end + 0 (#try.Success (encoding.to-utf8 "")) + _ (do try.monad + [last-char (binary.read/8 end string)] + (`` (case (.nat last-char) + (^ (char (~~ (static ..null)))) + (recur (dec end)) + + _ + (binary.slice 0 end string)))))))) + +(template [<type> <representation> <size> <exception> <in> <out> <writer> <parser> <none>] + [(abstract: #export <type> {} <representation> @@ -168,12 +255,12 @@ (def: #export (<in> value) (-> <representation> (Try <type>)) (if (..ascii? value) - (if (|> value encoding.to-utf8 binary.size (n.< <size>)) + (if (|> value encoding.to-utf8 binary.size (n.<= <size>)) (#try.Success (:abstraction value)) (exception.throw <exception> [value])) (exception.throw ..not-ascii [value]))) - (def: <out> + (def: #export <out> (-> <type> <representation>) (|>> :representation)) @@ -186,13 +273,27 @@ encoding.to-utf8 (format.segment padded-size)))) + (def: <parser> + (Parser <type>) + (do <>.monad + [string (<b>.segment <size>) + end <b>.bits/8 + #let [expected (`` (char (~~ (static ..null))))] + _ (<>.assert (exception.construct ..wrong-character [expected end]) + (n.= expected end))] + (<>.lift + (do {@ try.monad} + [ascii (..un-pad string) + text (encoding.from-utf8 ascii)] + (<in> text))))) + (def: #export <none> <type> (try.assume (<in> ""))) )] - [Name Text ..name-size name-is-too-long name from-name name-writer anonymous] - [Path file.Path ..path-size path-is-too-long path from-path path-writer no-path] + [Name Text ..name-size name-is-too-long name from-name name-writer name-parser anonymous] + [Path file.Path ..path-size path-is-too-long path from-path path-writer path-parser no-path] ) (def: magic-size Size 7) @@ -215,6 +316,18 @@ (|>> :representation encoding.to-utf8 (format.segment padded-size)))) + + (def: magic-parser + (Parser Magic) + (do <>.monad + [string (<b>.segment ..magic-size) + end <b>.bits/8 + #let [expected (`` (char (~~ (static ..null))))] + _ (<>.assert (exception.construct ..wrong-character [expected end]) + (n.= expected end))] + (<>.lift + (:: try.monad map (|>> :abstraction) + (encoding.from-utf8 string))))) ) (def: block-size Size 512) @@ -278,29 +391,49 @@ Char - (def: old-normal - Link-Flag - (:abstraction 0)) - - (template [<flag> <name>] - [(def: <name> - Link-Flag - (:abstraction (char <flag>)))] - - ["0" normal] - ["1" link] - ["2" symbolic-link] - ["3" character] - ["4" block] - ["5" directory] - ["6" fifo] - ["7" contiguous] - ) + (def: link-flag + (-> Link-Flag Char) + (|>> :representation)) (def: link-flag-writer (Writer Link-Flag) (|>> :representation format.bits/8)) + + (with-expansions [<options> (as-is [0 old-normal] + [(char "0") normal] + [(char "1") link] + [(char "2") symbolic-link] + [(char "3") character] + [(char "4") block] + [(char "5") directory] + [(char "6") fifo] + [(char "7") contiguous])] + (template [<flag> <name>] + [(def: <name> + Link-Flag + (:abstraction <flag>))] + + <options> + ) + + (exception: #export (invalid-link-flag {value Nat}) + (exception.report + ["Value" (%.nat value)])) + + (def: link-flag-parser + (Parser Link-Flag) + (do <>.monad + [linkflag <b>.bits/8] + (case (.nat linkflag) + (^template [<value> <link-flag>] + (^ <value>) + (wrap <link-flag>)) + (<options>) + + _ + (<>.lift + (exception.throw ..invalid-link-flag [(.nat linkflag)])))))) ) (abstract: #export Mode @@ -308,27 +441,9 @@ Nat - (template [<code> <name>] - [(def: #export <name> - Mode - (:abstraction (number.oct <code>)))] - - ["0001" execute-by-other] - ["0002" write-by-other] - ["0004" read-by-other] - - ["0010" execute-by-group] - ["0020" write-by-group] - ["0040" read-by-group] - - ["0100" execute-by-owner] - ["0200" write-by-owner] - ["0400" read-by-owner] - - ["1000" save-text] - ["2000" set-group-id-on-execution] - ["4000" set-user-id-on-execution] - ) + (def: #export mode + (-> Mode Nat) + (|>> :representation)) (def: #export (and left right) (-> Mode Mode Mode) @@ -342,6 +457,67 @@ ..small try.assume ..small-writer)) + + (exception: #export (invalid-mode {value Nat}) + (exception.report + ["Value" (%.nat value)])) + + (with-expansions [<options> (as-is ["0000" none] + + ["0001" execute-by-other] + ["0002" write-by-other] + ["0004" read-by-other] + + ["0010" execute-by-group] + ["0020" write-by-group] + ["0040" read-by-group] + + ["0100" execute-by-owner] + ["0200" write-by-owner] + ["0400" read-by-owner] + + ["1000" save-text] + ["2000" set-group-id-on-execution] + ["4000" set-user-id-on-execution])] + (template [<code> <name>] + [(def: #export <name> + Mode + (:abstraction (number.oct <code>)))] + + <options> + ) + + (def: maximum-mode + Mode + ($_ and + ..none + + ..execute-by-other + ..write-by-other + ..read-by-other + + ..execute-by-group + ..write-by-group + ..read-by-group + + ..execute-by-owner + ..write-by-owner + ..read-by-owner + + ..save-text + ..set-group-id-on-execution + ..set-user-id-on-execution + )) + + (def: mode-parser + (Parser Mode) + (do {@ <>.monad} + [value (:: @ map ..from-small ..small-parser)] + (if (n.<= (:representation ..maximum-mode) + value) + (wrap (:abstraction value)) + (<>.lift + (exception.throw ..invalid-mode [value])))))) ) (def: maximum-content-size @@ -350,7 +526,7 @@ (list.repeat ..content-size) (list@fold n.* 1))) -(abstract: Content +(abstract: #export Content {} [Big Binary] @@ -364,6 +540,10 @@ (def: from-content (-> Content [Big Binary]) (|>> :representation)) + + (def: #export data + (-> Content Binary) + (|>> :representation product.right)) ) (type: #export ID @@ -384,14 +564,16 @@ (type: #export File [Path Instant Mode Ownership Content]) -(type: #export Directory - Path) +(type: #export Normal File) +(type: #export Symbolic-Link Path) +(type: #export Directory Path) +(type: #export Contiguous File) (type: #export Entry - (#Normal File) - (#Symbolic-Link Path) - (#Directory Directory) - (#Contiguous File)) + (#Normal ..Normal) + (#Symbolic-Link ..Symbolic-Link) + (#Directory ..Directory) + (#Contiguous ..Contiguous)) (type: #export Device Small) @@ -456,11 +638,10 @@ (let [checksum (|> header (set@ #checksum ..dummy-checksum) (format.run ..header-writer') - ..checksum) - data (|> header - (set@ #checksum checksum) - (format.run ..header-writer'))] - (|> data + ..checksum-code)] + (|> header + (set@ #checksum checksum) + (format.run ..header-writer') (format.segment ..block-size)))) (def: modification-time @@ -523,7 +704,7 @@ #minor-device ..no-device})) (def: (directory-writer path) - (Writer Directory) + (Writer Path) (..header-writer {#path path #mode ($_ ..and @@ -563,3 +744,144 @@ format@identity tar) (format.segment ..end-of-archive-size ..end-of-archive))) + +(exception: #export (wrong-checksum {expected Nat} {actual Nat}) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)])) + +(def: header-padding-size + (n.- header-size block-size)) + +## When the checksum gets originally calculated, the assumption is that all the characters in the checksum field +## of the header will be spaces. +## This means that just calculating the checksum of the 512 bytes of the header, when reading them, would yield +## an incorrect result, as the contents of the checksum field would be an actual checksum, instead of just spaces. +## To correct for this, it is necessary to calculate the checksum of just the checksum field, subtract that, and then +## add-in the checksum of the spaces. +(def: (expected-checksum checksum header) + (-> Checksum Binary Nat) + (let [|checksum| (|> checksum ..from-checksum encoding.to-utf8 ..checksum)] + (|> (..checksum header) + (n.- |checksum|) + (n.+ ..checksum-checksum)))) + +(def: header-parser + (Parser Header) + (do <>.monad + [binary-header (<>.speculative (<b>.segment block-size)) + path ..path-parser + mode ..mode-parser + user-id ..small-parser + group-id ..small-parser + size ..big-parser + modification-time ..big-parser + [actual checksum-code] ..checksum-parser + _ (let [expected (expected-checksum checksum-code binary-header)] + (<>.lift + (exception.assert ..wrong-checksum [expected actual] + (n.= expected actual)))) + link-flag ..link-flag-parser + link-name ..path-parser + magic ..magic-parser + user-name ..name-parser + group-name ..name-parser + major-device ..small-parser + minor-device ..small-parser + _ (<b>.segment ..header-padding-size)] + (wrap {#path path + #mode mode + #user-id user-id + #group-id group-id + #size size + #modification-time modification-time + #checksum checksum-code + #link-flag link-flag + #link-name link-name + #magic magic + #user-name user-name + #group-name group-name + #major-device major-device + #minor-device minor-device}))) + +(exception: #export (wrong-link-flag {expected Link-Flag} {actual Link-Flag}) + (exception.report + ["Expected" (%.nat (..link-flag expected))] + ["Actual" (%.nat (..link-flag actual))])) + +(def: (file-parser expected) + (-> Link-Flag (Parser File)) + (do <>.monad + [header ..header-parser + _ (<>.assert (exception.construct ..wrong-link-flag [expected (get@ #link-flag header)]) + (is? expected (get@ #link-flag header))) + #let [size (get@ #size header) + rounded-size (..rounded-content-size size)] + content (<b>.segment (..from-big size)) + content (<>.lift (..content content)) + _ (<b>.segment (n.- (..from-big size) rounded-size))] + (wrap [(get@ #path header) + (|> header + (get@ #modification-time) + ..from-big + .int + duration.from-millis + (duration.scale-up (|> duration.second duration.to-millis .nat)) + instant.absolute) + (get@ #mode header) + {#user {#name (get@ #user-name header) + #id (get@ #user-id header)} + #group {#name (get@ #group-name header) + #id (get@ #group-id header)}} + content]))) + +(def: (file-name-parser expected extractor) + (-> Link-Flag (-> Header Path) (Parser Path)) + (do <>.monad + [header ..header-parser + _ (<>.lift + (exception.assert ..wrong-link-flag [expected (get@ #link-flag header)] + (n.= (..link-flag expected) + (..link-flag (get@ #link-flag header)))))] + (wrap (extractor header)))) + +(def: entry-parser + (Parser Entry) + ($_ <>.either + (:: <>.monad map (|>> #..Normal) + (<>.either (..file-parser ..normal) + (..file-parser ..old-normal))) + (:: <>.monad map (|>> #..Symbolic-Link) + (..file-name-parser ..symbolic-link (get@ #link-name))) + (:: <>.monad map (|>> #..Directory) + (..file-name-parser ..directory (get@ #path))) + (:: <>.monad map (|>> #..Contiguous) + (..file-parser ..contiguous)))) + +## It's safe to implement the parser this way because the range of values for Nat is 2^64 +## Whereas the maximum possible value for the checksum of a 512 block is (256 × 512) = 131,072 +(def: end-of-archive-block-parser + (Parser Any) + (do <>.monad + [block (<b>.segment ..block-size)] + (let [actual (..checksum block)] + (<>.lift + (exception.assert ..wrong-checksum [0 actual] + (n.= 0 actual)))))) + +(exception: #export invalid-end-of-archive) + +(def: end-of-archive-parser + (Parser Any) + (do <>.monad + [_ (<>.at-most 2 end-of-archive-block-parser) + done? <b>.end?] + (<>.lift + (exception.assert ..invalid-end-of-archive [] + done?)))) + +(def: #export parser + (Parser Tar) + (|> (<>.some entry-parser) + (:: <>.monad map row.from-list) + (<>.before ..end-of-archive-parser))) diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux index 47a480ab9..b87c2e2d3 100644 --- a/stdlib/source/lux/time/duration.lux +++ b/stdlib/source/lux/time/duration.lux @@ -60,11 +60,15 @@ (-> Duration Duration Int) (i./ (:representation param) (:representation subject))) - (structure: #export equivalence (Equivalence Duration) + (structure: #export equivalence + (Equivalence Duration) + (def: (= param subject) (i.= (:representation param) (:representation subject)))) - (structure: #export order (Order Duration) + (structure: #export order + (Order Duration) + (def: &equivalence ..equivalence) (def: (< param subject) (i.< (:representation param) (:representation subject)))) @@ -96,7 +100,9 @@ (def: #export leap-year (merge day normal-year)) -(structure: #export monoid (Monoid Duration) +(structure: #export monoid + (Monoid Duration) + (def: identity ..empty) (def: compose ..merge)) diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index bd378016a..ab7fe6953 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -14,7 +14,7 @@ [data ["." maybe] [number - ["n" nat] + ["n" nat ("#@." decimal)] ["i" int ("#@." decimal)]] ["." text ("#@." monoid)] [collection @@ -56,16 +56,22 @@ (-> Duration Instant) (|> offset duration.to-millis :abstraction)) - (structure: #export equivalence (Equivalence Instant) + (structure: #export equivalence + (Equivalence Instant) + (def: (= param subject) (:: i.equivalence = (:representation param) (:representation subject)))) - (structure: #export order (Order Instant) + (structure: #export order + (Order Instant) + (def: &equivalence ..equivalence) (def: (< param subject) (:: i.order < (:representation param) (:representation subject)))) - (`` (structure: #export enum (Enum Instant) + (`` (structure: #export enum + (Enum Instant) + (def: &order ..order) (~~ (template [<name>] [(def: <name> @@ -126,10 +132,10 @@ (row.reverse months)))) (def: (pad value) - (-> Int Text) - (if (i.< +10 value) - (text@compose "0" (i@encode value)) - (i@encode value))) + (-> Nat Text) + (if (n.< 10 value) + (text@compose "0" (n@encode value)) + (n@encode value))) (def: (adjust-negative space duration) (-> Duration Duration Duration) @@ -138,12 +144,12 @@ duration)) (def: (encode-millis millis) - (-> Int Text) - (cond (i.= +0 millis) "" - (i.< +10 millis) ($_ text@compose ".00" (i@encode millis)) - (i.< +100 millis) ($_ text@compose ".0" (i@encode millis)) - ## (i.< +1,000 millis) - ($_ text@compose "." (i@encode millis)))) + (-> Nat Text) + (cond (n.= 0 millis) "" + (n.< 10 millis) ($_ text@compose ".00" (n@encode millis)) + (n.< 100 millis) ($_ text@compose ".0" (n@encode millis)) + ## (n.< 1,000 millis) + ($_ text@compose "." (n@encode millis)))) (def: seconds-per-day Int (duration.query duration.second duration.day)) (def: days-up-to-epoch Int +719468) @@ -196,11 +202,12 @@ [hours day-time] [(duration.query duration.hour day-time) (duration.frame duration.hour day-time)] [minutes day-time] [(duration.query duration.minute day-time) (duration.frame duration.minute day-time)] [seconds millis] [(duration.query duration.second day-time) (duration.frame duration.second day-time)]] - ($_ text@compose (i@encode year) "-" (pad month) "-" (pad day) "T" - (pad hours) ":" (pad minutes) ":" (pad seconds) + ($_ text@compose (i@encode year) "-" (pad (.nat month)) "-" (pad (.nat day)) "T" + (pad (.nat hours)) ":" (pad (.nat minutes)) ":" (pad (.nat seconds)) (|> millis (adjust-negative duration.second) duration.to-millis + .nat encode-millis) "Z"))) diff --git a/stdlib/source/spec/lux/abstract/functor/contravariant.lux b/stdlib/source/spec/lux/abstract/functor/contravariant.lux new file mode 100644 index 000000000..b21e28e68 --- /dev/null +++ b/stdlib/source/spec/lux/abstract/functor/contravariant.lux @@ -0,0 +1,31 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [data + [number + ["n" nat]]] + [control + ["." function]] + [math + ["." random]] + ["_" test (#+ Test)]] + {1 + ["." / (#+ Functor)]}) + +(def: (identity equivalence value (^open "/@.")) + (All [f a] (-> (Equivalence (f a)) (f a) (Functor f) Test)) + (_.test "Law of identity." + (equivalence + (/@map function.identity value) + value))) + +(def: #export (spec equivalence value functor) + (All [f a] (-> (Equivalence (f a)) (f a) (Functor f) Test)) + (do random.monad + [sample random.nat] + (<| (_.with-cover [/.Functor]) + ($_ _.and + (..identity equivalence value functor) + )))) diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux index ef7cb0774..aa93df86f 100644 --- a/stdlib/source/test/lux/abstract.lux +++ b/stdlib/source/test/lux/abstract.lux @@ -14,7 +14,16 @@ ["#." monad] ["#." monoid] ["#." order] - ["#." predicate]]) + ["#." predicate] + [functor + ["#." contravariant]]]) + +(def: functor + Test + ($_ _.and + /functor.test + /contravariant.test + )) (def: #export test Test @@ -25,7 +34,7 @@ /enum.test /equivalence.test /fold.test - /functor.test + ..functor /hash.test /interval.test /monad.test diff --git a/stdlib/source/test/lux/abstract/equivalence.lux b/stdlib/source/test/lux/abstract/equivalence.lux index 7cc5c95f9..d79803e31 100644 --- a/stdlib/source/test/lux/abstract/equivalence.lux +++ b/stdlib/source/test/lux/abstract/equivalence.lux @@ -1,7 +1,12 @@ (.module: [lux #* ["_" test (#+ Test)] - [abstract/monad (#+ do)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + [functor + ["." contravariant]]]}] [data ["." bit ("#@." equivalence)] [number @@ -20,9 +25,20 @@ leftI random.int rightI random.int sample random.nat - different (|> random.nat (random.filter (|>> (n.= sample) not)))] + different (|> random.nat (random.filter (|>> (n.= sample) not))) + #let [equivalence (: (Equivalence (Equivalence Nat)) + (structure + (def: (= left right) + (and (bit@= (:: left = leftN leftN) + (:: right = leftN leftN)) + (bit@= (:: left = rightN rightN) + (:: right = rightN rightN)) + (bit@= (:: left = leftN rightN) + (:: right = leftN rightN))))))]] (<| (_.covering /._) ($_ _.and + (_.with-cover [/.functor] + (contravariant.spec equivalence n.equivalence /.functor)) (_.cover [/.sum] (let [equivalence (/.sum n.equivalence i.equivalence)] (and (bit@= (:: n.equivalence = leftN leftN) diff --git a/stdlib/source/test/lux/abstract/functor/contravariant.lux b/stdlib/source/test/lux/abstract/functor/contravariant.lux new file mode 100644 index 000000000..93d1f18ad --- /dev/null +++ b/stdlib/source/test/lux/abstract/functor/contravariant.lux @@ -0,0 +1,10 @@ +(.module: + [lux #* + ["_" test (#+ Test)]] + {1 + ["." /]}) + +(def: #export test + Test + (<| (_.covering /._) + (_.in-parallel (list)))) diff --git a/stdlib/source/test/lux/abstract/order.lux b/stdlib/source/test/lux/abstract/order.lux index 7157a6c01..dff849034 100644 --- a/stdlib/source/test/lux/abstract/order.lux +++ b/stdlib/source/test/lux/abstract/order.lux @@ -2,7 +2,11 @@ [lux #* ["_" test (#+ Test)] [abstract - [monad (#+ do)]] + [monad (#+ do)] + {[0 #spec] + [/ + [functor + ["." contravariant]]]}] [data ["." bit ("#@." equivalence)] [number @@ -10,15 +14,28 @@ [math ["." random (#+ Random)]]] {1 - ["." / (#+ Order)]}) + ["." / (#+ Order) + [// + [equivalence (#+ Equivalence)]]]}) (def: #export test Test (<| (_.covering /._) (do random.monad [left random.nat - right (|> random.nat (random.filter (|>> (n.= left) not)))]) + right (|> random.nat (random.filter (|>> (n.= left) not))) + #let [equivalence (: (Equivalence (Order Nat)) + (structure + (def: (= leftO rightO) + (and (bit@= (:: leftO < left left) + (:: rightO < left left)) + (bit@= (:: leftO < right right) + (:: rightO < right right)) + (bit@= (:: leftO < left right) + (:: rightO < left right))))))]]) ($_ _.and + (_.with-cover [/.functor] + (contravariant.spec equivalence n.order /.functor)) (_.cover [/.Choice /.min /.max] (n.< (/.max n.order left right) (/.min n.order left right))) diff --git a/stdlib/source/test/lux/data.lux b/stdlib/source/test/lux/data.lux index fa544ccd5..47a79b530 100644 --- a/stdlib/source/test/lux/data.lux +++ b/stdlib/source/test/lux/data.lux @@ -30,6 +30,7 @@ ["#/." regex]] [format ["#." json] + ["#." tar] ["#." xml]] ["#." collection]]) @@ -71,6 +72,7 @@ (def: format ($_ _.and /json.test + /tar.test /xml.test )) diff --git a/stdlib/source/test/lux/data/format/tar.lux b/stdlib/source/test/lux/data/format/tar.lux new file mode 100644 index 000000000..b8ba1af51 --- /dev/null +++ b/stdlib/source/test/lux/data/format/tar.lux @@ -0,0 +1,409 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." exception] + ["<>" parser + ["<b>" binary]]] + [data + ["." product] + ["." maybe] + ["." binary ("#@." equivalence)] + ["." text ("#@." equivalence) + ["." encoding] + ["." unicode] + ["%" format (#+ format)]] + [number + ["n" nat] + ["i" int]] + [collection + ["." row] + ["." list ("#@." fold)]] + ["." format #_ + ["#" binary]]] + [time + ["." instant (#+ Instant)] + ["." duration]] + [math + ["." random (#+ Random)]]] + {1 + ["." /]}) + +(def: path + Test + (_.with-cover [/.Path] + (do {@ random.monad} + [expected (random.ascii/lower-alpha /.path-size) + invalid (random.ascii/lower-alpha (inc /.path-size)) + not-ascii (random.text (random.char (unicode.set (list unicode.katakana))) + /.path-size)] + (`` ($_ _.and + (_.cover [/.path /.from-path] + (case (/.path expected) + (#try.Success actual) + (text@= expected + (/.from-path actual)) + + (#try.Failure error) + false)) + (_.cover [/.path-size /.path-is-too-long] + (case (/.path invalid) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.path-is-too-long error))) + (_.cover [/.not-ascii] + (case (/.path not-ascii) + (#try.Success actual) + false + + (#try.Failure error) + (exception.match? /.not-ascii error))) + ))))) + +(def: name + Test + (_.with-cover [/.Name] + (do {@ random.monad} + [expected (random.ascii/lower-alpha /.name-size) + invalid (random.ascii/lower-alpha (inc /.name-size)) + not-ascii (random.text (random.char (unicode.set (list unicode.katakana))) + /.name-size)] + (`` ($_ _.and + (_.cover [/.name /.from-name] + (case (/.name expected) + (#try.Success actual) + (text@= expected + (/.from-name actual)) + + (#try.Failure error) + false)) + (_.cover [/.name-size /.name-is-too-long] + (case (/.name invalid) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.name-is-too-long error))) + (_.cover [/.not-ascii] + (case (/.name not-ascii) + (#try.Success actual) + false + + (#try.Failure error) + (exception.match? /.not-ascii error))) + ))))) + +(def: small + Test + (_.with-cover [/.Small] + (do {@ random.monad} + [expected (|> random.nat (:: @ map (n.% /.small-limit))) + invalid (|> random.nat (:: @ map (n.max /.small-limit)))] + (`` ($_ _.and + (_.cover [/.small /.from-small] + (case (/.small expected) + (#try.Success actual) + (n.= expected + (/.from-small actual)) + + (#try.Failure error) + false)) + (_.cover [/.small-limit /.not-a-small-number] + (case (/.small invalid) + (#try.Success actual) + false + + (#try.Failure error) + (exception.match? /.not-a-small-number error))) + ))))) + +(def: big + Test + (_.with-cover [/.Big] + (do {@ random.monad} + [expected (|> random.nat (:: @ map (n.% /.big-limit))) + invalid (|> random.nat (:: @ map (n.max /.big-limit)))] + (`` ($_ _.and + (_.cover [/.big /.from-big] + (case (/.big expected) + (#try.Success actual) + (n.= expected + (/.from-big actual)) + + (#try.Failure error) + false)) + (_.cover [/.big-limit /.not-a-big-number] + (case (/.big invalid) + (#try.Success actual) + false + + (#try.Failure error) + (exception.match? /.not-a-big-number error))) + ))))) + +(def: chunk-size 32) + +(def: entry + Test + (do {@ random.monad} + [expected-path (random.ascii/lower-alpha (dec /.path-size)) + expected-moment (:: @ map (|>> (n.% 1,00,00,00,00,00,000) .int instant.from-millis) + random.nat) + chunk (random.ascii/lower-alpha chunk-size) + chunks (:: @ map (n.% 100) random.nat) + #let [content (|> chunk + (list.repeat chunks) + (text.join-with "") + encoding.to-utf8)]] + (`` ($_ _.and + (~~ (template [<type> <tag>] + [(_.cover [<type>] + (|> (do try.monad + [expected-path (/.path expected-path) + tar (|> (row.row (<tag> expected-path)) + (format.run /.writer) + (<b>.run /.parser))] + (wrap (case (row.to-list tar) + (^ (list (<tag> actual-path))) + (text@= (/.from-path expected-path) + (/.from-path actual-path)) + + _ + false))) + (try.default false)))] + + [/.Symbolic-Link #/.Symbolic-Link] + [/.Directory #/.Directory] + )) + (_.with-cover [/.File /.Content /.content /.data] + ($_ _.and + (~~ (template [<type> <tag>] + [(_.cover [<type>] + (|> (do try.monad + [expected-path (/.path expected-path) + expected-content (/.content content) + tar (|> (row.row (<tag> [expected-path + expected-moment + /.none + {#/.user {#/.name /.anonymous + #/.id /.no-id} + #/.group {#/.name /.anonymous + #/.id /.no-id}} + expected-content])) + (format.run /.writer) + (<b>.run /.parser))] + (wrap (case (row.to-list tar) + (^ (list (<tag> [actual-path actual-moment actual-mode actual-ownership actual-content]))) + (let [seconds (: (-> Instant Int) + (|>> instant.relative (duration.query duration.second)))] + (and (text@= (/.from-path expected-path) + (/.from-path actual-path)) + (i.= (seconds expected-moment) + (seconds actual-moment)) + (binary@= (/.data expected-content) + (/.data actual-content)))) + + _ + false))) + (try.default false)))] + + [/.Normal #/.Normal] + [/.Contiguous #/.Contiguous] + )))))))) + +(def: random-mode + (Random /.Mode) + (do {@ random.monad} + [] + (random.either (random.either (random.either (wrap /.execute-by-other) + (wrap /.write-by-other)) + (random.either (wrap /.read-by-other) + (wrap /.execute-by-group))) + (random.either (random.either (random.either (wrap /.write-by-group) + (wrap /.read-by-group)) + (random.either (wrap /.execute-by-owner) + (wrap /.write-by-owner))) + (random.either (random.either (wrap /.read-by-owner) + (wrap /.save-text)) + (random.either (wrap /.set-group-id-on-execution) + (wrap /.set-user-id-on-execution))))))) + +(def: mode + Test + (_.with-cover [/.Mode /.mode] + (do {@ random.monad} + [path (random.ascii/lower-alpha 10) + modes (random.list 4 ..random-mode) + #let [expected-mode (list@fold /.and /.none modes)]] + (`` ($_ _.and + (_.cover [/.and] + (|> (do try.monad + [path (/.path path) + content (/.content (binary.create 0)) + tar (|> (row.row (#/.Normal [path + (instant.from-millis +0) + expected-mode + {#/.user {#/.name /.anonymous + #/.id /.no-id} + #/.group {#/.name /.anonymous + #/.id /.no-id}} + content])) + (format.run /.writer) + (<b>.run /.parser))] + (wrap (case (row.to-list tar) + (^ (list (#/.Normal [_ _ actual-mode _ _]))) + (n.= (/.mode expected-mode) + (/.mode actual-mode)) + + _ + false))) + (try.default false))) + (~~ (template [<expected-mode>] + [(_.cover [<expected-mode>] + (|> (do try.monad + [path (/.path path) + content (/.content (binary.create 0)) + tar (|> (row.row (#/.Normal [path + (instant.from-millis +0) + <expected-mode> + {#/.user {#/.name /.anonymous + #/.id /.no-id} + #/.group {#/.name /.anonymous + #/.id /.no-id}} + content])) + (format.run /.writer) + (<b>.run /.parser))] + (wrap (case (row.to-list tar) + (^ (list (#/.Normal [_ _ actual-mode _ _]))) + (n.= (/.mode <expected-mode>) + (/.mode actual-mode)) + + _ + false))) + (try.default false)))] + + [/.none] + + [/.execute-by-other] + [/.write-by-other] + [/.read-by-other] + + [/.execute-by-group] + [/.write-by-group] + [/.read-by-group] + + [/.execute-by-owner] + [/.write-by-owner] + [/.read-by-owner] + + [/.save-text] + [/.set-group-id-on-execution] + [/.set-user-id-on-execution] + ))))))) + +(def: ownership + Test + (do {@ random.monad} + [path (random.ascii/lower-alpha /.path-size) + expected (random.ascii/lower-alpha /.name-size) + invalid (random.ascii/lower-alpha (inc /.name-size)) + not-ascii (random.text (random.char (unicode.set (list unicode.katakana))) + /.name-size)] + (_.with-cover [/.Ownership /.Owner /.ID] + ($_ _.and + (_.cover [/.name-size /.name-is-too-long] + (case (/.name invalid) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.name-is-too-long error))) + (_.cover [/.not-ascii] + (case (/.name not-ascii) + (#try.Success actual) + false + + (#try.Failure error) + (exception.match? /.not-ascii error))) + (_.cover [/.Name /.name /.from-name] + (|> (do try.monad + [path (/.path path) + content (/.content (binary.create 0)) + expected (/.name expected) + tar (|> (row.row (#/.Normal [path + (instant.from-millis +0) + /.none + {#/.user {#/.name expected + #/.id /.no-id} + #/.group {#/.name /.anonymous + #/.id /.no-id}} + content])) + (format.run /.writer) + (<b>.run /.parser))] + (wrap (case (row.to-list tar) + (^ (list (#/.Normal [_ _ _ actual-ownership _]))) + (and (text@= (/.from-name expected) + (/.from-name (get@ [#/.user #/.name] actual-ownership))) + (text@= (/.from-name /.anonymous) + (/.from-name (get@ [#/.group #/.name] actual-ownership)))) + + _ + false))) + (try.default false))) + (_.cover [/.anonymous /.no-id] + (|> (do try.monad + [path (/.path path) + content (/.content (binary.create 0)) + tar (|> (row.row (#/.Normal [path + (instant.from-millis +0) + /.none + {#/.user {#/.name /.anonymous + #/.id /.no-id} + #/.group {#/.name /.anonymous + #/.id /.no-id}} + content])) + (format.run /.writer) + (<b>.run /.parser))] + (wrap (case (row.to-list tar) + (^ (list (#/.Normal [_ _ _ actual-ownership _]))) + (and (text@= (/.from-name /.anonymous) + (/.from-name (get@ [#/.user #/.name] actual-ownership))) + (n.= (/.from-small /.no-id) + (/.from-small (get@ [#/.user #/.id] actual-ownership))) + (text@= (/.from-name /.anonymous) + (/.from-name (get@ [#/.group #/.name] actual-ownership))) + (n.= (/.from-small /.no-id) + (/.from-small (get@ [#/.group #/.id] actual-ownership)))) + + _ + false))) + (try.default false))) + )))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Tar] + ($_ _.and + (_.cover [/.writer /.parser] + (|> row.empty + (format.run /.writer) + (<b>.run /.parser) + (:: try.monad map row.empty?) + (try.default false))) + ..path + ..name + ..small + ..big + (_.with-cover [/.Entry] + ($_ _.and + ..entry + ..mode + ..ownership + )) + )))) |