From 853642c340730b3bb23c1ac87660c5c7ecbffa93 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 19 May 2020 23:46:38 -0400 Subject: Can now write TAR files. --- stdlib/source/lux/abstract/apply.lux | 6 +- stdlib/source/lux/control/pipe.lux | 6 +- stdlib/source/lux/data/binary.lux | 9 + stdlib/source/lux/data/format/binary.lux | 13 + stdlib/source/lux/data/format/tar.lux | 565 ++++++++++++++++++++++++++++ stdlib/source/lux/data/number.lux | 4 +- stdlib/source/lux/data/text/encoding.lux | 4 +- stdlib/source/lux/time/duration.lux | 12 +- stdlib/source/lux/world/file.lux | 5 +- stdlib/source/test/lux/abstract.lux | 6 + stdlib/source/test/lux/abstract/apply.lux | 24 +- stdlib/source/test/lux/abstract/comonad.lux | 27 ++ stdlib/source/test/lux/abstract/functor.lux | 1 - stdlib/source/test/lux/abstract/hash.lux | 35 ++ 14 files changed, 699 insertions(+), 18 deletions(-) create mode 100644 stdlib/source/lux/data/format/tar.lux create mode 100644 stdlib/source/test/lux/abstract/comonad.lux create mode 100644 stdlib/source/test/lux/abstract/hash.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/abstract/apply.lux b/stdlib/source/lux/abstract/apply.lux index 5eb42b63d..febf31a73 100644 --- a/stdlib/source/lux/abstract/apply.lux +++ b/stdlib/source/lux/abstract/apply.lux @@ -1,8 +1,8 @@ (.module: - lux + [lux #*] [// - ["." functor (#+ Functor)] - [monad (#+ Monad)]]) + [monad (#+ Monad)] + ["." functor (#+ Functor)]]) (signature: #export (Apply f) {#.doc "Applicative functors."} diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index ed6b54311..691d5568b 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -11,7 +11,7 @@ ["n" nat] ["i" int]] [collection - ["." list ("#;." fold monad)]]] + ["." list ("#@." fold monad)]]] [macro (#+ with-gensyms) [syntax (#+ syntax:)] ["." code]]]) @@ -134,7 +134,7 @@ "Will become: [+50 +2 '+5']")} (with-gensyms [g!temp] (wrap (list (` (let [(~ g!temp) (~ prev)] - [(~+ (list;map (function (_ body) (` (|> (~ g!temp) (~+ body)))) + [(~+ (list@map (function (_ body) (` (|> (~ g!temp) (~+ body)))) paths))])))))) (syntax: #export (case> {branches (p.many (p.and s.any s.any))} @@ -154,5 +154,5 @@ +9 "nine" _ "???")))} (wrap (list (` (case (~ prev) - (~+ (list;join (list;map (function (_ [pattern body]) (list pattern body)) + (~+ (list@join (list@map (function (_ [pattern body]) (list pattern body)) branches)))))))) diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux index 33e0bdac3..defb62049 100644 --- a/stdlib/source/lux/data/binary.lux +++ b/stdlib/source/lux/data/binary.lux @@ -129,6 +129,15 @@ (~~ (static @.js)) (|>> .nat-to-frac [] ArrayBuffer::new Uint8Array::new)}))) +(def: #export (fold f init binary) + (All [a] (-> (-> I64 a a) a Binary a)) + (let [size (..!size binary)] + (loop [idx 0 + output init] + (if (n.< size idx) + (recur (inc idx) (f (!read idx binary) output)) + output)))) + (def: #export (read/8 idx binary) (-> Nat Binary (Try I64)) (if (n.< (..!size binary) idx) diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index 90e3cc468..ece895c38 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -127,6 +127,19 @@ (Writer Frac) (|>> frac.to-bits ..bits/64)) +(def: #export (segment size) + (-> Nat (Writer Binary)) + (function (_ value) + [size + (function (_ [offset binary]) + [(n.+ size offset) + (try.assume + (binary.copy (n.min size (binary.size value)) + 0 + value + offset + binary))])])) + (template [ ] [(def: #export (Writer Binary) diff --git a/stdlib/source/lux/data/format/tar.lux b/stdlib/source/lux/data/format/tar.lux new file mode 100644 index 000000000..a9bb06954 --- /dev/null +++ b/stdlib/source/lux/data/format/tar.lux @@ -0,0 +1,565 @@ +(.module: + [lux (#- Mode Name and) + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try (#+ Try)] + ["." exception (#+ exception:)] + ["<>" parser + ["" binary (#+ Parser)]]] + [data + ["." binary (#+ Binary)] + ["." text (#+ Char) + ["%" format (#+ format)] + ["." encoding]] + ["." number + ["n" nat] + ["." i64]] + ["." format #_ + ["#" binary (#+ Writer) ("#@." monoid)]] + [collection + ["." list ("#@." fold)] + ["." row (#+ Row) ("#@." fold)]]] + [time + ["." instant (#+ Instant)] + ["." duration]] + [world + ["." file]] + [type + abstract]]) + +(type: Size Nat) + +(def: octal-size Size 8) + +(def: (octal-padding max-size number) + (-> Size Text Text) + (let [padding-size (n.- (text.size number) + max-size) + padding (|> "0" + (list.repeat padding-size) + (text.join-with ""))] + (format padding number))) + +(def: blank " ") +(def: null text.null) + +(def: small-size Size 6) +(def: big-size Size 11) + +(template [ + + ] + [(def: + (|> ..octal-size + (list.repeat ) + (list@fold n.* 1))) + + (exception: #export ( {value Nat}) + (exception.report + ["Value" (%.nat value)] + ["Maximum" (%.nat )])) + + (abstract: + {} + + Nat + + (def: #export ( value) + (-> Nat (Try )) + (if (|> value (n.% ) (n.= value)) + (#try.Success (:abstraction value)) + (exception.throw [value]))) + + (def: + (-> Nat) + (|>> :representation)) + + (def: + (Writer ) + (let [suffix + padded-size (n.+ (text.size suffix) )] + (|>> :representation + (:: n.octal encode) + (..octal-padding ) + (text.suffix suffix) + encoding.to-utf8 + (format.segment padded-size)))) + + (def: + (-> Nat ) + (|>> (n.% ) + :abstraction)) + )] + + [not-a-small-number maximum-small-size ..small-size + Small small from-small + small-writer (format ..blank ..null) + coerce-small] + [not-a-big-number maximum-big-size ..big-size + Big big from-big + big-writer ..blank + coerce-big] + ) + +(abstract: Checksum + {} + + Text + + (def: dummy-checksum + Checksum + (:abstraction " ")) + + (def: checksum-suffix + (format ..blank ..null)) + + (def: checksum + (-> Binary Checksum) + (|>> (binary.fold n.+ 0) + ..coerce-small + ..from-small + (:: n.octal encode) + (..octal-padding ..small-size) + (text.suffix ..checksum-suffix) + :abstraction)) + + (def: checksum-writer + (Writer Checksum) + (let [padded-size (n.+ (text.size ..checksum-suffix) + ..small-size)] + (|>> :representation + encoding.to-utf8 + (format.segment padded-size)))) + ) + +(def: last-ascii + Char + (number.hex "007F")) + +(def: ascii? + (-> Text Bit) + (|>> encoding.to-utf8 + (binary.fold (function (_ char verdict) + (.and verdict + (n.<= ..last-ascii char))) + true))) + +(exception: #export (not-ascii {text Text}) + (exception.report + ["Text" (%.text text)])) + +(def: name-size Size 31) +(def: path-size Size 99) + +(template [ ] + [(abstract: + {} + + + + (exception: #export ( {value Text}) + (exception.report + ["Value" (%.text value)] + ["Size" (%.nat (text.size value))] + ["Maximum" (%.nat )])) + + (def: #export ( value) + (-> (Try )) + (if (..ascii? value) + (if (|> value encoding.to-utf8 binary.size (n.< )) + (#try.Success (:abstraction value)) + (exception.throw [value])) + (exception.throw ..not-ascii [value]))) + + (def: + (-> ) + (|>> :representation)) + + (def: + (Writer ) + (let [suffix ..null + padded-size (n.+ (text.size suffix) )] + (|>> :representation + (text.suffix suffix) + encoding.to-utf8 + (format.segment padded-size)))) + + (def: #export + + (try.assume ( ""))) + )] + + [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] + ) + +(def: magic-size Size 7) + +(abstract: Magic + {} + + Text + + (def: ustar (:abstraction "ustar ")) + + (def: from-magic + (-> Magic Text) + (|>> :representation)) + + (def: magic-writer + (Writer Magic) + (let [padded-size (n.+ (text.size ..null) + ..magic-size)] + (|>> :representation + encoding.to-utf8 + (format.segment padded-size)))) + ) + +(def: block-size Size 512) + +(def: owner-id-size ..small-size) + +(def: blank-size Size (text.size ..blank)) +(def: null-size Size (text.size ..null)) +(def: mode-size Size ..small-size) +(def: content-size Size ..big-size) +(def: modification-time-size Size ..big-size) +(def: checksum-size Size ..small-size) +(def: link-flag-size Size 1) +(def: device-size Size ..small-size) + +(def: small-number + (-> Size Size) + (|>> ($_ n.+ ..blank-size ..null-size))) + +(def: big-number + (-> Size Size) + (|>> ($_ n.+ ..blank-size))) + +(def: string + (-> Size Size) + (|>> ($_ n.+ ..null-size))) + +(def: header-size + ($_ n.+ + ## name + (..string ..path-size) + ## mode + (..small-number ..mode-size) + ## uid + (..small-number ..owner-id-size) + ## gid + (..small-number ..owner-id-size) + ## size + (..big-number ..content-size) + ## mtime + (..big-number ..modification-time-size) + ## chksum + (..small-number ..checksum-size) + ## linkflag + ..link-flag-size + ## linkname + (..string ..path-size) + ## magic + (..string ..magic-size) + ## uname + (..string ..name-size) + ## gname + (..string ..name-size) + ## devmajor + (..small-number ..device-size) + ## devminor + (..small-number ..device-size))) + +(abstract: Link-Flag + {} + + Char + + (def: old-normal + Link-Flag + (:abstraction 0)) + + (template [ ] + [(def: + Link-Flag + (:abstraction (char )))] + + ["0" normal] + ["1" link] + ["2" symbolic-link] + ["3" character] + ["4" block] + ["5" directory] + ["6" fifo] + ["7" contiguous] + ) + + (def: link-flag-writer + (Writer Link-Flag) + (|>> :representation + format.bits/8)) + ) + +(abstract: #export Mode + {} + + Nat + + (template [ ] + [(def: #export + Mode + (:abstraction (number.oct )))] + + ["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 (and left right) + (-> Mode Mode Mode) + (:abstraction + (i64.or (:representation left) + (:representation right)))) + + (def: mode-writer + (Writer Mode) + (|>> :representation + ..small + try.assume + ..small-writer)) + ) + +(def: maximum-content-size + Nat + (|> ..octal-size + (list.repeat ..content-size) + (list@fold n.* 1))) + +(abstract: Content + {} + + [Big Binary] + + (def: #export (content content) + (-> Binary (Try Content)) + (do try.monad + [size (..big (binary.size content))] + (wrap (:abstraction [size content])))) + + (def: from-content + (-> Content [Big Binary]) + (|>> :representation)) + ) + +(type: #export ID + Small) + +(def: #export no-id + ID + (..coerce-small 0)) + +(type: #export Owner + {#name Name + #id ID}) + +(type: #export Ownership + {#user Owner + #group Owner}) + +(type: #export File + [Path Instant Mode Ownership Content]) + +(type: #export Directory + Path) + +(type: #export Entry + (#Normal File) + (#Symbolic-Link Path) + (#Directory Directory) + (#Contiguous File)) + +(type: #export Device + Small) + +(def: no-device + Device + (try.assume (..small 0))) + +(type: #export Tar + (Row Entry)) + +(def: (blocks size) + (-> Big Nat) + (n.+ (n./ ..block-size + (..from-big size)) + (case (n.% ..block-size (..from-big size)) + 0 0 + _ 1))) + +(def: rounded-content-size + (-> Big Nat) + (|>> ..blocks + (n.* ..block-size))) + +(type: Header + {#path Path + #mode Mode + #user-id ID + #group-id ID + #size Big + #modification-time Big + #checksum Checksum + #link-flag Link-Flag + #link-name Path + #magic Magic + #user-name Name + #group-name Name + #major-device Device + #minor-device Device}) + +(def: header-writer' + (Writer Header) + ($_ format.and + ..path-writer + ..mode-writer + ..small-writer + ..small-writer + ..big-writer + ..big-writer + ..checksum-writer + ..link-flag-writer + ..path-writer + ..magic-writer + ..name-writer + ..name-writer + ..small-writer + ..small-writer + )) + +(def: (header-writer header) + (Writer Header) + (let [checksum (|> header + (set@ #checksum ..dummy-checksum) + (format.run ..header-writer') + ..checksum) + data (|> header + (set@ #checksum checksum) + (format.run ..header-writer'))] + (|> data + (format.segment ..block-size)))) + +(def: modification-time + (-> Instant Big) + (|>> instant.relative + (duration.query duration.second) + .nat + ..coerce-big)) + +(def: (file-writer link-flag) + (-> Link-Flag (Writer File)) + (function (_ [path modification-time mode ownership content]) + (let [[size content] (..from-content content) + writer ($_ format.and + ..header-writer + (format.segment (..rounded-content-size size)))] + (writer [{#path path + #mode mode + #user-id (get@ [#user #id] ownership) + #group-id (get@ [#group #id] ownership) + #size size + #modification-time (..modification-time modification-time) + #checksum ..dummy-checksum + #link-flag link-flag + #link-name ..no-path + #magic ..ustar + #user-name (get@ [#user #name] ownership) + #group-name (get@ [#group #name] ownership) + #major-device ..no-device + #minor-device ..no-device} + content])))) + +(def: normal-file-writer + (Writer File) + (..file-writer ..normal)) + +(def: contiguous-file-writer + (Writer File) + (..file-writer ..contiguous)) + +(def: (symbolic-link-writer path) + (Writer Path) + (..header-writer + {#path ..no-path + #mode ($_ ..and + ..read-by-other + ..read-by-group + ..read-by-owner) + #user-id ..no-id + #group-id ..no-id + #size (..coerce-big 0) + #modification-time (..coerce-big 0) + #checksum ..dummy-checksum + #link-flag ..symbolic-link + #link-name path + #magic ..ustar + #user-name ..anonymous + #group-name ..anonymous + #major-device ..no-device + #minor-device ..no-device})) + +(def: (directory-writer path) + (Writer Directory) + (..header-writer + {#path path + #mode ($_ ..and + ..read-by-other + ..read-by-group + ..read-by-owner) + #user-id ..no-id + #group-id ..no-id + #size (..coerce-big 0) + #modification-time (..coerce-big 0) + #checksum ..dummy-checksum + #link-flag ..directory + #link-name ..no-path + #magic ..ustar + #user-name ..anonymous + #group-name ..anonymous + #major-device ..no-device + #minor-device ..no-device})) + +(def: entry-writer + (Writer Entry) + (|>> (case> (#Normal value) (..normal-file-writer value) + (#Symbolic-Link value) (..symbolic-link-writer value) + (#Directory value) (..directory-writer value) + (#Contiguous value) (..contiguous-file-writer value)))) + +(def: end-of-archive-size Size (n.* 2 ..block-size)) + +(def: end-of-archive + Binary + (binary.create ..end-of-archive-size)) + +(def: #export (writer tar) + (Writer Tar) + (format@compose (row@fold (function (_ next total) + (format@compose total (..entry-writer next))) + format@identity + tar) + (format.segment ..end-of-archive-size ..end-of-archive))) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 9b8381491..07e093849 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -73,10 +73,10 @@ [bin /nat.binary /int.binary /rev.binary /frac.binary "Invalid binary syntax." - (encoding-doc "binary" (bin "+11001001") (bin "+11,00,10,01"))] + (encoding-doc "binary" (bin "11001001") (bin "11,00,10,01"))] [oct /nat.octal /int.octal /rev.octal /frac.octal "Invalid octal syntax." - (encoding-doc "octal" (oct "+615243") (oct "+615,243"))] + (encoding-doc "octal" (oct "615243") (oct "615,243"))] [hex /nat.hex /int.hex /rev.hex /frac.hex "Invalid hexadecimal syntax." (encoding-doc "hexadecimal" (hex "deadBEEF") (hex "dead,BEEF"))] diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux index 59e5efcc2..9e94f25af 100644 --- a/stdlib/source/lux/data/text/encoding.lux +++ b/stdlib/source/lux/data/text/encoding.lux @@ -219,6 +219,8 @@ (#try.Success (|> (TextDecoder::new [(..name ..utf-8)]) (TextDecoder::decode [value])))}))) -(structure: #export UTF-8 (Codec Binary Text) +(structure: #export UTF-8 + (Codec Binary Text) + (def: encode ..to-utf8) (def: decode ..from-utf8)) diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux index 58d06ee2d..47a480ab9 100644 --- a/stdlib/source/lux/time/duration.lux +++ b/stdlib/source/lux/time/duration.lux @@ -86,12 +86,12 @@ (template [ ] [(def: #export (scale-up ))] - [second 1,000 milli-second] - [minute 60 second] - [hour 60 minute] - [day 24 hour] - [week 7 day] - [normal-year 365 day] + [second 1,000 milli-second] + [minute 60 second] + [hour 60 minute] + [day 24 hour] + [week 7 day] + [normal-year 365 day] ) (def: #export leap-year (merge day normal-year)) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 6cd802296..8ef16a276 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -387,6 +387,7 @@ (structure: #export system (System IO) + (~~ (template [ ] [(def: (..can-open @@ -562,7 +563,9 @@ (function (discard _) (io.io (Fs::rmdirSync [path] (!fs))))))) - (structure: #export system (System IO) + (structure: #export system + (System IO) + (~~ (template [ ] [(def: (..can-open diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux index b9aa18c9c..ef7cb0774 100644 --- a/stdlib/source/test/lux/abstract.lux +++ b/stdlib/source/test/lux/abstract.lux @@ -2,11 +2,14 @@ [lux #* ["_" test (#+ Test)]] ["." / #_ + ["#." apply] ["#." codec] + ["#." comonad] ["#." enum] ["#." equivalence] ["#." fold] ["#." functor] + ["#." hash] ["#." interval] ["#." monad] ["#." monoid] @@ -16,11 +19,14 @@ (def: #export test Test ($_ _.and + /apply.test /codec.test + /comonad.test /enum.test /equivalence.test /fold.test /functor.test + /hash.test /interval.test /monad.test /monoid.test diff --git a/stdlib/source/test/lux/abstract/apply.lux b/stdlib/source/test/lux/abstract/apply.lux index 29e3e9d6f..eb8fd4e52 100644 --- a/stdlib/source/test/lux/abstract/apply.lux +++ b/stdlib/source/test/lux/abstract/apply.lux @@ -2,8 +2,11 @@ [lux #* [abstract/monad (#+ do)] [data + ["." maybe] [number - ["n" nat]]] + ["n" nat]] + [collection + ["." list]]] [control ["." function]] [math @@ -70,3 +73,22 @@ (..interchange injection comparison apply) (..composition injection comparison apply) ))) + +(def: #export test + Test + (do random.monad + [left random.nat + right random.nat] + (<| (_.covering /._) + ($_ _.and + (_.cover [/.compose] + (let [expected (n.+ left right)] + (case (:: (/.compose maybe.monad maybe.apply list.apply) apply + (#.Some (list (n.+ left))) + (#.Some (list right))) + (^ (#.Some (list actual))) + (n.= expected actual) + + _ + false))) + )))) diff --git a/stdlib/source/test/lux/abstract/comonad.lux b/stdlib/source/test/lux/abstract/comonad.lux new file mode 100644 index 000000000..2e63b4eb8 --- /dev/null +++ b/stdlib/source/test/lux/abstract/comonad.lux @@ -0,0 +1,27 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [data + ["." identity (#+ Identity)] + [number + ["n" nat]]] + [math + ["." random]] + ["_" test (#+ Test)]] + {1 + ["." /]}) + +(def: #export test + Test + (do random.monad + [sample random.nat] + (<| (_.covering /._) + ($_ _.and + (_.cover [/.be] + (n.= (inc sample) + (: (Identity Nat) + (/.be identity.comonad + [value (unwrap sample)] + (unwrap (inc value)))))) + )))) diff --git a/stdlib/source/test/lux/abstract/functor.lux b/stdlib/source/test/lux/abstract/functor.lux index fcceca39b..faef439c6 100644 --- a/stdlib/source/test/lux/abstract/functor.lux +++ b/stdlib/source/test/lux/abstract/functor.lux @@ -1,7 +1,6 @@ (.module: [lux #* ["_" test (#+ Test)] - ["%" data/text/format (#+ format)] [abstract [equivalence (#+ Equivalence)] [monad (#+ do)]] diff --git a/stdlib/source/test/lux/abstract/hash.lux b/stdlib/source/test/lux/abstract/hash.lux new file mode 100644 index 000000000..f7f82ffe2 --- /dev/null +++ b/stdlib/source/test/lux/abstract/hash.lux @@ -0,0 +1,35 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [data + ["." bit ("#@." equivalence)] + [number + ["n" nat] + ["i" int]]] + [math + ["." random]]] + {1 + ["." /]}) + +(def: #export test + Test + (do random.monad + [left random.nat + right random.int + other-left random.nat + other-right random.int] + (<| (_.covering /._) + ($_ _.and + (_.cover [/.product] + (and (n.= (:: (/.product n.hash i.hash) hash [left right]) + (n.* (:: n.hash hash left) + (:: i.hash hash right))) + (bit@= (:: (/.product n.hash i.hash) = [left right] [left right]) + (and (:: n.hash = left left) + (:: i.hash = right right))) + (bit@= (:: (/.product n.hash i.hash) = [left right] [other-left other-right]) + (and (:: n.hash = left other-left) + (:: i.hash = right other-right))))) + )))) -- cgit v1.2.3