aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/parser/binary.lux19
-rw-r--r--stdlib/source/lux/control/try.lux8
-rw-r--r--stdlib/source/lux/data/format/binary.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/default/cache.lux35
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux33
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux.lux86
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/artifact.lux35
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux32
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/document.lux36
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/signature.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux26
-rw-r--r--stdlib/source/test/lux/abstract/enum.lux45
-rw-r--r--stdlib/source/test/lux/control/try.lux89
13 files changed, 353 insertions, 125 deletions
diff --git a/stdlib/source/lux/control/parser/binary.lux b/stdlib/source/lux/control/parser/binary.lux
index 0ee4112b1..dc1b95ac7 100644
--- a/stdlib/source/lux/control/parser/binary.lux
+++ b/stdlib/source/lux/control/parser/binary.lux
@@ -2,7 +2,8 @@
[lux (#- and or nat int rev list type)
[type (#+ :share)]
[abstract
- [monad (#+ do)]]
+ [monad (#+ do)]
+ [hash (#+ Hash)]]
[control
["." try (#+ Try)]
["." exception (#+ exception:)]]
@@ -15,7 +16,9 @@
["." encoding]
["%" format (#+ format)]]
[collection
- ["." row (#+ Row)]]]]
+ ["." list]
+ ["." row (#+ Row)]
+ ["." set (#+ Set)]]]]
["." // ("#@." monad)])
(type: #export Offset Nat)
@@ -176,6 +179,18 @@
(..or ..any
(//.and value recur)))))
+(exception: #export set-elements-are-not-unique)
+
+(def: #export (set hash value)
+ (All [a] (-> (Hash a) (Parser a) (Parser (Set a))))
+ (do //.monad
+ [raw (list value)
+ #let [output (set.from-list hash raw)]
+ _ (//.assert (exception.construct ..set-elements-are-not-unique [])
+ (n.= (list.size raw)
+ (set.size output)))]
+ (wrap output)))
+
(def: #export name
(Parser Name)
(//.and ..text ..text))
diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux
index 7202f5c75..749b05a53 100644
--- a/stdlib/source/lux/control/try.lux
+++ b/stdlib/source/lux/control/try.lux
@@ -78,13 +78,13 @@
(All [M a] (-> (Monad M) (-> (M a) (M (Try a)))))
(:: monad map (:: ..monad wrap)))
-(structure: #export (equivalence (^open ",@."))
+(structure: #export (equivalence (^open "_@."))
(All [a] (-> (Equivalence a) (Equivalence (Try a))))
(def: (= reference sample)
(case [reference sample]
[(#Success reference) (#Success sample)]
- (,@= reference sample)
+ (_@= reference sample)
[(#Failure reference) (#Failure sample)]
("lux text =" reference sample)
@@ -124,9 +124,9 @@
"if a (Try x) value turns out to be #Failure."
"Note: the expression for the default value will not be computed if the base computation succeeds."
(= "bar"
- (default "foo" (#Success "bar")))
+ (default "foo" (#..Success "bar")))
(= "foo"
- (default "foo" (#Failure "KABOOM!"))))}
+ (default "foo" (#..Failure "KABOOM!"))))}
(case tokens
(^ (list else try))
(#Success [compiler (list (` (case (~ try)
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
index 3e1282046..fd812a31a 100644
--- a/stdlib/source/lux/data/format/binary.lux
+++ b/stdlib/source/lux/data/format/binary.lux
@@ -7,11 +7,10 @@
[monad (#+ Monad do)]
[equivalence (#+ Equivalence)]]
[control
+ ["." function]
["." try (#+ Try)]
["<>" parser ("#@." monad)
- ["/" binary (#+ Offset Size Parser)]]
- ["." function]
- ["ex" exception (#+ exception:)]]
+ ["/" binary (#+ Offset Size Parser)]]]
[data
["." product]
["." binary (#+ Binary)]
@@ -24,7 +23,8 @@
["%" format (#+ format)]]
[collection
["." list]
- ["." row (#+ Row) ("#@." functor)]]]])
+ ["." row (#+ Row) ("#@." functor)]
+ ["." set (#+ Set)]]]])
(def: mask
(-> Size (I64 Any))
@@ -110,9 +110,8 @@
(def: #export (rec body)
(All [a] (-> (-> (Writer a) (Writer a)) (Writer a)))
- (function (_ value)
- (let [writer (body (rec body))]
- (writer value))))
+ (function (recur value)
+ (body recur value)))
(def: #export any
(Writer Any)
@@ -214,6 +213,10 @@
(|>> (..and value)
(..or ..any))))
+(def: #export (set value)
+ (All [a] (-> (Writer a) (Writer (Set a))))
+ (|>> set.to-list (..list value)))
+
(def: #export name
(Writer Name)
(..and ..text ..text))
diff --git a/stdlib/source/lux/tool/compiler/default/cache.lux b/stdlib/source/lux/tool/compiler/default/cache.lux
deleted file mode 100644
index 1770b4a82..000000000
--- a/stdlib/source/lux/tool/compiler/default/cache.lux
+++ /dev/null
@@ -1,35 +0,0 @@
-(.module:
- [lux #*
- [data
- [format
- ["_" binary (#+ Format)]]]])
-
-(def: definition
- (Format Definition)
- ($_ _.and _.type _.code _.any))
-
-(def: alias
- (Format [Text Text])
- (_.and _.text _.text))
-
-## TODO: Remove #module-hash, #imports & #module-state ASAP.
-## TODO: Not just from this parser, but from the lux.Module type.
-(def: #export module
- (Format Module)
- ($_ _.and
- ## #module-hash
- (_.ignore 0)
- ## #module-aliases
- (_.list ..alias)
- ## #definitions
- (_.list (_.and _.text ..definition))
- ## #imports
- (_.list _.text)
- ## #tags
- (_.ignore (list))
- ## #types
- (_.ignore (list))
- ## #module-annotations
- (_.maybe _.code)
- ## #module-state
- (_.ignore #.Cached)))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 0d31b1f2d..9a4c6f20c 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -16,7 +16,9 @@
["%" format (#+ format)]]
[collection
["." list]
- ["." row ("#@." functor)]]]
+ ["." row ("#@." functor)]]
+ [format
+ ["_" binary (#+ Writer)]]]
[world
["." file (#+ Path)]]]
["." // #_
@@ -25,6 +27,7 @@
["#." phase]
[language
[lux
+ ["$" /]
["." syntax]
["#." analysis
[macro (#+ Expander)]]
@@ -37,7 +40,8 @@
["." module]]]]]
[meta
["." archive (#+ Archive)
- [descriptor (#+ Module)]]
+ ["." descriptor (#+ Descriptor Module)]
+ ["." document (#+ Document)]]
[io
["." context]
["ioW" archive]]]]]
@@ -66,9 +70,14 @@
<State+> (as-is (///directive.State+ anchor expression directive))
<Bundle> (as-is (///generation.Bundle anchor expression directive))]
- (def: (cache-module platform host target-dir module-file-name module-id extension output)
+ (def: writer
+ (Writer [Descriptor (Document .Module)])
+ (_.and descriptor.writer
+ (document.writer $.writer)))
+
+ (def: (cache-module platform host target-dir module-file-name module-id extension [[descriptor document] output])
(All <type-vars>
- (-> <Platform> Host Path Path archive.ID Text Output
+ (-> <Platform> Host Path Path archive.ID Text [[Descriptor (Document Any)] Output]
(Promise (Try Any))))
(let [system (get@ #&file-system platform)
write-artifact! (: (-> [Text Binary] (Action Any))
@@ -79,12 +88,11 @@
_ (|> output
row.to-list
(monad.map ..monad write-artifact!)
- (: (Action (List Any))))]
- (wrap [])
- ## (&io.write target-dir
- ## (format module-name "/" cache.descriptor-name)
- ## (encoding.to-utf8 (%.code (cache/description.write module-file-name module))))
- )))
+ (: (Action (List Any))))
+ document (:: promise.monad wrap
+ (document.check //init.key document))]
+ (ioW.cache system host target-dir module-id
+ (_.run ..writer [descriptor document])))))
## TODO: Inline ASAP
(def: initialize-buffer!
@@ -220,7 +228,7 @@
(#.Left more)
(continue! archive state more)
- (#.Right [descriptor+document output])
+ (#.Right payload)
(do (try.with promise.monad)
[_ (..cache-module platform
host
@@ -228,7 +236,8 @@
(get@ #///.file input)
module-id
extension
- output)]
+ payload)
+ #let [[descriptor+document output] payload]]
(case (archive.add module descriptor+document archive)
(#try.Success archive)
(wrap [archive state])
diff --git a/stdlib/source/lux/tool/compiler/language/lux.lux b/stdlib/source/lux/tool/compiler/language/lux.lux
new file mode 100644
index 000000000..ed3b0ed9b
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux.lux
@@ -0,0 +1,86 @@
+(.module:
+ [lux #*
+ [control
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
+ [data
+ [format
+ ["_" binary (#+ Writer)]]]])
+
+## TODO: Remove #module-hash, #imports & #module-state ASAP.
+## TODO: Not just from this parser, but from the lux.Module type.
+(def: #export writer
+ (Writer .Module)
+ (let [definition (: (Writer Definition)
+ ($_ _.and _.bit _.type _.code _.any))
+ name (: (Writer Name)
+ (_.and _.text _.text))
+ alias name
+ global (: (Writer Global)
+ (_.or alias definition))
+ tag (: (Writer [Nat (List Name) Bit Type])
+ ($_ _.and
+ _.nat
+ (_.list name)
+ _.bit
+ _.type))
+ type (: (Writer [(List Name) Bit Type])
+ ($_ _.and
+ (_.list name)
+ _.bit
+ _.type))]
+ ($_ _.and
+ ## #module-hash
+ _.nat
+ ## #module-aliases
+ (_.list alias)
+ ## #definitions
+ (_.list (_.and _.text global))
+ ## #imports
+ (_.list _.text)
+ ## #tags
+ (_.list (_.and _.text tag))
+ ## #types
+ (_.list (_.and _.text type))
+ ## #module-annotations
+ (_.maybe _.code)
+ ## #module-state
+ _.any)))
+
+(def: #export parser
+ (Parser .Module)
+ (let [definition (: (Parser Definition)
+ ($_ <>.and <b>.bit <b>.type <b>.code <b>.any))
+ name (: (Parser Name)
+ (<>.and <b>.text <b>.text))
+ alias name
+ global (: (Parser Global)
+ (<>.or alias definition))
+ tag (: (Parser [Nat (List Name) Bit Type])
+ ($_ <>.and
+ <b>.nat
+ (<b>.list name)
+ <b>.bit
+ <b>.type))
+ type (: (Parser [(List Name) Bit Type])
+ ($_ <>.and
+ (<b>.list name)
+ <b>.bit
+ <b>.type))]
+ ($_ <>.and
+ ## #module-hash
+ <b>.nat
+ ## #module-aliases
+ (<b>.list alias)
+ ## #definitions
+ (<b>.list (<>.and <b>.text global))
+ ## #imports
+ (<b>.list <b>.text)
+ ## #tags
+ (<b>.list (<>.and <b>.text tag))
+ ## #types
+ (<b>.list (<>.and <b>.text type))
+ ## #module-annotations
+ (<b>.maybe <b>.code)
+ ## #module-state
+ (:: <>.monad wrap #.Cached))))
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
index 2d4559275..7f3e1654d 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
@@ -1,11 +1,19 @@
(.module:
[lux #*
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
[data
+ ["." product]
["." text]
[collection
- ["." list]
+ ["." list ("#@." functor fold)]
["." row (#+ Row)]
- ["." dictionary (#+ Dictionary)]]]
+ ["." dictionary (#+ Dictionary)]]
+ [format
+ ["." binary (#+ Writer)]]]
[type
abstract]])
@@ -17,6 +25,7 @@
(abstract: #export Registry
{}
+
{#artifacts (Row Artifact)
#resolver (Dictionary Text ID)}
@@ -63,4 +72,26 @@
(|> (:representation registry)
(get@ #resolver)
(dictionary.get name)))
+
+ (def: #export writer
+ (Writer Registry)
+ (let [writer|artifacts (binary.list (binary.maybe binary.text))]
+ (|>> :representation
+ (get@ #artifacts)
+ row.to-list
+ (list@map (get@ #name))
+ writer|artifacts)))
+
+ (def: #export parser
+ (Parser Registry)
+ (|> (<b>.list (<b>.maybe <b>.text))
+ (:: <>.monad map (list@fold (function (_ artifact registry)
+ (product.right
+ (case artifact
+ #.None
+ (..resource registry)
+
+ (#.Some name)
+ (..definition name registry))))
+ ..empty))))
)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
index c6e1e7841..24562367a 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
@@ -1,12 +1,18 @@
(.module:
[lux (#- Module)
+ [control
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
[data
+ ["." text]
[collection
- [set (#+ Set)]]]
+ [set (#+ Set)]]
+ [format
+ ["." binary (#+ Writer)]]]
[world
[file (#+ Path)]]]
[//
- [artifact (#+ Registry)]])
+ ["." artifact (#+ Registry)]])
(type: #export Module Text)
@@ -17,3 +23,25 @@
#state Module-State
#references (Set Module)
#registry Registry})
+
+(def: #export writer
+ (Writer Descriptor)
+ ($_ binary.and
+ binary.text
+ binary.text
+ binary.nat
+ binary.any
+ (binary.set binary.text)
+ artifact.writer
+ ))
+
+(def: #export parser
+ (Parser Descriptor)
+ ($_ <>.and
+ <b>.text
+ <b>.text
+ <b>.nat
+ (:: <>.monad wrap #.Cached)
+ (<b>.set text.hash <b>.text)
+ artifact.parser
+ ))
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/lux/tool/compiler/meta/archive/document.lux
index e6d5c0dfe..19b8576a1 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/document.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/document.lux
@@ -1,11 +1,17 @@
(.module:
[lux (#- Module)
+ [abstract
+ [monad (#+ do)]]
[control
["." try (#+ Try)]
- ["ex" exception (#+ exception:)]]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
[data
[collection
- ["." dictionary (#+ Dictionary)]]]
+ ["." dictionary (#+ Dictionary)]]
+ [format
+ ["." binary (#+ Writer)]]]
[type (#+ :share)
abstract]]
[//
@@ -14,8 +20,9 @@
[descriptor (#+ Module)]])
(exception: #export (invalid-signature {expected Signature} {actual Signature})
- (ex.report ["Expected" (signature.description expected)]
- ["Actual" (signature.description actual)]))
+ (exception.report
+ ["Expected" (signature.description expected)]
+ ["Actual" (signature.description actual)]))
(abstract: #export (Document d)
{}
@@ -34,15 +41,32 @@
key}
{e
document//content}))
- (ex.throw invalid-signature [(key.signature key)
- document//signature]))))
+ (exception.throw ..invalid-signature [(key.signature key)
+ document//signature]))))
(def: #export (write key content)
(All [d] (-> (Key d) d (Document d)))
(:abstraction {#signature (key.signature key)
#content content}))
+ (def: #export (check key document)
+ (All [d] (-> (Key d) (Document Any) (Try (Document d))))
+ (do try.monad
+ [_ (..read key document)]
+ (wrap (:assume document))))
+
(def: #export signature
(-> (Document Any) Signature)
(|>> :representation (get@ #signature)))
+
+ (def: #export (writer content)
+ (All [d] (-> (Writer d) (Writer (Document d))))
+ (let [writer (binary.and signature.writer
+ content)]
+ (|>> :representation writer)))
+
+ (def: #export parser
+ (All [d] (-> (Parser d) (Parser (Document d))))
+ (|>> (<>.and signature.parser)
+ (:: <>.monad map (|>> :abstraction))))
)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
index 551c54579..3d795ff50 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
@@ -2,10 +2,15 @@
[lux #*
[abstract
["." equivalence (#+ Equivalence)]]
+ [control
+ ["<>" parser
+ ["<b>" binary (#+ Parser)]]]
[data
["." name]
["." text
- ["%" format (#+ format)]]]]
+ ["%" format (#+ format)]]
+ [format
+ ["." binary (#+ Writer)]]]]
[////
[version (#+ Version)]])
@@ -20,3 +25,13 @@
(def: #export (description signature)
(-> Signature Text)
(format (%.name (get@ #name signature)) " " (get@ #version signature)))
+
+(def: #export writer
+ (Writer Signature)
+ (binary.and (binary.and binary.text binary.text)
+ binary.text))
+
+(def: #export parser
+ (Parser Signature)
+ (<>.and (<>.and <b>.text <b>.text)
+ <b>.text))
diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
index e71641727..ee7af993b 100644
--- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
@@ -38,7 +38,7 @@
(:: system separator)
//.lux-context))
-(def: #export (document system host root module-id)
+(def: (module system host root module-id)
(-> (System Promise) Host Path archive.ID Path)
(format (..lux-archive system host root)
(:: system separator)
@@ -46,7 +46,7 @@
(def: #export (artifact system host root module-id name extension)
(-> (System Promise) Host Path archive.ID Text Text Path)
- (format (document system host root module-id)
+ (format (..module system host root module-id)
(:: system separator)
name
extension))
@@ -54,13 +54,13 @@
(def: #export (prepare system host root module-id)
(-> (System Promise) Host Path archive.ID (Promise (Try Any)))
(do promise.monad
- [#let [document (..document system host root module-id)]
- document-exists? (file.exists? promise.monad system document)]
- (if document-exists?
+ [#let [module (..module system host root module-id)]
+ module-exists? (file.exists? promise.monad system module)]
+ (if module-exists?
(wrap (#try.Success []))
(do @
[_ (file.get-directory @ system (..lux-archive system host root))
- outcome (!.use (:: system create-directory) document)]
+ outcome (!.use (:: system create-directory) module)]
(case outcome
(#try.Success output)
(wrap (#try.Success []))
@@ -112,3 +112,17 @@
(#try.Failure error)
(wrap (#try.Success archive.empty)))))
+
+(def: (module-descriptor system host root module-id)
+ (-> (System Promise) Host Path archive.ID Path)
+ (format (..module system host root module-id)
+ (:: system separator)
+ "module-descriptor"))
+
+(def: #export (cache system host root module-id content)
+ (-> (System Promise) Host Path archive.ID Binary (Promise (Try Any)))
+ (do (try.with promise.monad)
+ [artifact (: (Promise (Try (File Promise)))
+ (file.get-file promise.monad system
+ (..module-descriptor system host root module-id)))]
+ (!.use (:: artifact over-write) content)))
diff --git a/stdlib/source/test/lux/abstract/enum.lux b/stdlib/source/test/lux/abstract/enum.lux
index b67f846f5..b6a490358 100644
--- a/stdlib/source/test/lux/abstract/enum.lux
+++ b/stdlib/source/test/lux/abstract/enum.lux
@@ -1,7 +1,6 @@
(.module:
[lux #*
[data
- ["%" text/format (#+ format)]
["." product]
["." maybe ("#@." functor)]
[number
@@ -26,35 +25,35 @@
[start end]
[end start])
range (/.range n.enum start end)]]
- (<| (_.context (%.name (name-of /.Enum)))
+ (<| (_.covering /._)
($_ _.and
- (_.test (%.name (name-of /.range))
- (let [expected-size (|> end (n.- start) inc)
- expected-start? (|> range list.head (maybe@map (n.= start)) (maybe.default false))
- expected-end? (|> range list.last (maybe@map (n.= end)) (maybe.default false))
- every-element-is-a-successor? (case range
- (#.Cons head tail)
- (|> (list@fold (function (_ next [verdict prev])
- [(and verdict
- (n.= next (:: n.enum succ prev)))
- next])
- [true head]
- tail)
- product.left)
-
- #.Nil
- false)]
- (and (n.= expected-size (list.size range))
- expected-start?
- expected-end?
- every-element-is-a-successor?)))
+ (_.cover [/.range]
+ (let [expected-size (|> end (n.- start) inc)
+ expected-start? (|> range list.head (maybe@map (n.= start)) (maybe.default false))
+ expected-end? (|> range list.last (maybe@map (n.= end)) (maybe.default false))
+ every-element-is-a-successor? (case range
+ (#.Cons head tail)
+ (|> (list@fold (function (_ next [verdict prev])
+ [(and verdict
+ (n.= next (:: n.enum succ prev)))
+ next])
+ [true head]
+ tail)
+ product.left)
+
+ #.Nil
+ false)]
+ (and (n.= expected-size (list.size range))
+ expected-start?
+ expected-end?
+ every-element-is-a-successor?)))
)))))
(def: #export (spec (^open "/@.") gen-sample)
(All [a] (-> (Enum a) (Random a) Test))
(do r.monad
[sample gen-sample]
- (<| (_.context (%.name (name-of /.Enum)))
+ (<| (_.with-cover [/.Enum])
($_ _.and
(_.test "Successor and predecessor are inverse functions."
(and (/@= (|> sample /@succ /@pred)
diff --git a/stdlib/source/test/lux/control/try.lux b/stdlib/source/test/lux/control/try.lux
index 47e51b54b..08c19794d 100644
--- a/stdlib/source/test/lux/control/try.lux
+++ b/stdlib/source/test/lux/control/try.lux
@@ -13,11 +13,11 @@
pipe
["." io]]
[data
- ["%" text/format (#+ format)]
+ ["." text ("#@." equivalence)]
[number
["n" nat]]]
[math
- ["r" random (#+ Random)]]]
+ ["." random (#+ Random)]]]
{1
["." / (#+ Try)]})
@@ -32,33 +32,72 @@
(def: #export (try element)
(All [a] (-> (Random a) (Random (Try a))))
- ($_ r.or
- (r.unicode 1)
+ ($_ random.or
+ (random.unicode 1)
element))
(def: #export test
Test
- (<| (_.context (%.name (name-of /._)))
+ (<| (_.covering /._)
+ (_.with-cover [/.Try])
+ (do random.monad
+ [expected random.nat
+ alternative (|> random.nat (random.filter (|>> (n.= expected) not)))
+ error (random.unicode 1)
+ #let [(^open "io@.") io.monad]])
($_ _.and
- ($equivalence.spec (/.equivalence n.equivalence) (..try r.nat))
- ($functor.spec ..injection ..comparison /.functor)
- ($apply.spec ..injection ..comparison /.apply)
- ($monad.spec ..injection ..comparison /.monad)
- (do r.monad
- [left r.nat
- right r.nat
- #let [expected (n.+ left right)
- (^open "io@.") io.monad]]
- (_.test "Can add try functionality to any monad."
- (let [lift (/.lift io.monad)]
- (|> (do (/.with io.monad)
- [a (lift (io@wrap left))
- b (wrap right)]
- (wrap (n.+ a b)))
- io.run
- (case> (#/.Success actual)
- (n.= expected actual)
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec (/.equivalence n.equivalence) (..try random.nat)))
+ (_.with-cover [/.functor]
+ ($functor.spec ..injection ..comparison /.functor))
+ (_.with-cover [/.apply]
+ ($apply.spec ..injection ..comparison /.apply))
+ (_.with-cover [/.monad]
+ ($monad.spec ..injection ..comparison /.monad))
- _
- false)))))
+ (_.cover [/.succeed]
+ (case (/.succeed expected)
+ (#/.Success actual)
+ (n.= expected actual)
+
+ _
+ false))
+ (_.cover [/.fail]
+ (case (/.fail error)
+ (#/.Failure message)
+ (text@= error message)
+
+ _
+ false))
+ (_.cover [/.assume]
+ (n.= expected
+ (/.assume (/.succeed expected))))
+ (_.cover [/.maybe]
+ (case [(/.maybe (/.succeed expected))
+ (/.maybe (/.fail error))]
+ [(#.Some actual) #.None]
+ (n.= expected actual)
+
+ _
+ false))
+ (_.cover [/.default]
+ (and (n.= expected
+ (/.default alternative (/.succeed expected)))
+ (n.= alternative
+ (/.default alternative (: (Try Nat)
+ (/.fail error))))))
+
+ (_.cover [/.with /.lift]
+ (let [lift (/.lift io.monad)]
+ (|> (do (/.with io.monad)
+ [a (lift (io@wrap expected))
+ b (wrap alternative)]
+ (wrap (n.+ a b)))
+ io.run
+ (case> (#/.Success result)
+ (n.= (n.+ expected alternative)
+ result)
+
+ _
+ false))))
)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 09:10:47 +0000