aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/concurrency/frp.lux52
-rw-r--r--stdlib/source/lux/control/concurrency/promise.lux49
-rw-r--r--stdlib/source/lux/control/identity.lux60
-rw-r--r--stdlib/source/lux/control/security/capability.lux15
-rw-r--r--stdlib/source/lux/data/format/json.lux4
-rw-r--r--stdlib/source/lux/world/net/http.lux4
-rw-r--r--stdlib/source/lux/world/net/http/request.lux13
-rw-r--r--stdlib/source/lux/world/service/crud.lux35
-rw-r--r--stdlib/source/lux/world/service/inventory.lux43
-rw-r--r--stdlib/source/lux/world/service/mail.lux10
10 files changed, 121 insertions, 164 deletions
diff --git a/stdlib/source/lux/control/concurrency/frp.lux b/stdlib/source/lux/control/concurrency/frp.lux
index 84def78d1..5412e5342 100644
--- a/stdlib/source/lux/control/concurrency/frp.lux
+++ b/stdlib/source/lux/control/concurrency/frp.lux
@@ -1,14 +1,16 @@
(.module:
[lux (#- Source)
+ ["." io (#+ IO io)]
[control
+ [predicate (#+ Predicate)]
+ [equivalence (#+ Equivalence)]
[functor (#+ Functor)]
[apply (#+ Apply)]
- ["." monad (#+ do Monad)]
- [predicate (#+ Predicate)]
- [equivalence (#+ Equivalence)]]
- ["." io (#+ IO)]
+ ["." monad (#+ Monad do)]
+ ["ex" exception (#+ exception:)]]
[data
[maybe ("maybe/." functor)]
+ ["." error (#+ Error)]
[collection
[list ("list/." monoid)]]]
[type (#+ :share)
@@ -21,10 +23,12 @@
{#.doc "An asynchronous channel to distribute values."}
(Promise (Maybe [a (Channel a)])))
+(exception: #export channel-is-already-closed)
+
(signature: #export (Source a)
- (: (IO Bit)
+ (: (IO (Error Any))
close)
- (: (-> a (IO Bit))
+ (: (-> a (IO (Error Any)))
feed))
(def: (source resolve)
@@ -40,13 +44,13 @@
stopped? (current #.None)]
(if stopped?
## I closed the source.
- (wrap true)
+ (wrap (ex.return []))
## Someone else interacted with the source.
(do @
[latter (atom.read source)]
(if (is? current latter)
## Someone else closed the source.
- (wrap true)
+ (wrap (ex.throw channel-is-already-closed []))
## Someone else fed the source while I was closing it.
(recur [])))))))
@@ -63,13 +67,15 @@
fed? (current (#.Some [value next]))]
(if fed?
## I fed the source.
- (atom.compare-and-swap current resolve-next source)
+ (do @
+ [_ (atom.compare-and-swap current resolve-next source)]
+ (wrap (ex.return [])))
## Someone else interacted with the source.
(do @
[latter (atom.read source)]
(if (is? current latter)
## Someone else closed the source while I was feeding it.
- (wrap false)
+ (wrap (ex.throw channel-is-already-closed []))
## Someone else fed the source.
(recur []))))))))))
@@ -80,18 +86,18 @@
(def: #export (listen listener channel)
(All [a] (-> (-> a (IO Any)) (Channel a) (IO Any)))
- (io.io (exec (: (Promise Any)
- (loop [channel channel]
- (do promise.monad
- [cons channel]
- (case cons
- (#.Some [head tail])
- (exec (io.run (listener head))
- (recur tail))
-
- #.None
- (wrap [])))))
- [])))
+ (io (exec (: (Promise Any)
+ (loop [channel channel]
+ (do promise.monad
+ [cons channel]
+ (case cons
+ (#.Some [head tail])
+ (exec (io.run (listener head))
+ (recur tail))
+
+ #.None
+ (wrap [])))))
+ [])))
(structure: #export functor (Functor Channel)
(def: (map f)
@@ -190,7 +196,7 @@
(def: #export (periodic milli-seconds)
(-> Nat (Channel Any))
- (poll milli-seconds (io.io [])))
+ (poll milli-seconds (io [])))
(def: #export (iterate f init)
(All [a] (-> (-> a (Promise (Maybe a))) a (Channel a)))
diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux
index 244951139..72fe34bcb 100644
--- a/stdlib/source/lux/control/concurrency/promise.lux
+++ b/stdlib/source/lux/control/concurrency/promise.lux
@@ -21,26 +21,27 @@
(type: #export (Resolver a)
(-> a (IO Bit)))
- (def: (resolver (^:representation promise))
+ (def: (resolver promise)
{#.doc "Sets an promise's value if it has not been done yet."}
(All [a] (-> (Promise a) (Resolver a)))
(function (resolve value)
- (do io.monad
- [(^@ old [_value _observers]) (atom.read promise)]
- (case _value
- (#.Some _)
- (wrap #0)
-
- #.None
- (do @
- [#let [new [(#.Some value) #.None]]
- succeeded? (atom.compare-and-swap old new promise)]
- (if succeeded?
- (do @
- [_ (monad.map @ (function (_ f) (f value))
- _observers)]
- (wrap #1))
- (resolve value)))))))
+ (let [promise (:representation promise)]
+ (do io.monad
+ [(^@ old [_value _observers]) (atom.read promise)]
+ (case _value
+ (#.Some _)
+ (wrap #0)
+
+ #.None
+ (do @
+ [#let [new [(#.Some value) #.None]]
+ succeeded? (atom.compare-and-swap old new promise)]
+ (if succeeded?
+ (do @
+ [_ (monad.map @ (function (_ f) (f value))
+ _observers)]
+ (wrap #1))
+ (resolve value))))))))
(def: #export (resolved value)
(All [a] (-> a (Promise a)))
@@ -51,16 +52,18 @@
(let [promise (:abstraction (atom [#.None (list)]))]
[promise (..resolver promise)]))
- (def: #export (poll (^:representation promise))
+ (def: #export poll
{#.doc "Polls a promise's value."}
(All [a] (-> (Promise a) (Maybe a)))
- (|> (atom.read promise)
- io.run
- product.left))
+ (|>> :representation
+ atom.read
+ io.run
+ product.left))
- (def: #export (await f (^:representation promise))
+ (def: #export (await f promise)
(All [a] (-> (-> a (IO Any)) (Promise a) (IO Any)))
- (let [(^@ old [_value _observers]) (io.run (atom.read promise))]
+ (let [promise (:representation promise)
+ (^@ old [_value _observers]) (io.run (atom.read promise))]
(case _value
(#.Some value)
(f value)
diff --git a/stdlib/source/lux/control/identity.lux b/stdlib/source/lux/control/identity.lux
deleted file mode 100644
index ff79bedca..000000000
--- a/stdlib/source/lux/control/identity.lux
+++ /dev/null
@@ -1,60 +0,0 @@
-(.module:
- [lux #*
- [control
- [equivalence (#+ Equivalence)]
- [security
- [capability (#+ Capability)]]]
- [type
- abstract]])
-
-(abstract: #export (ID code entity storage)
- {#.doc "A value that uniquely identifies an entity in some foreign data storage (such as a database)."}
-
- code
-
- (structure: #export (equivalence Equivalence<code>)
- (All [code entity storage]
- (-> (Equivalence code)
- (Equivalence (ID code entity storage))))
- (def: (= reference sample)
- (:: Equivalence<code> =
- (:representation reference)
- (:representation sample))))
-
- (type: #export (Can-Identify code storage)
- (All [entity]
- (Capability code
- (ID code entity storage))))
-
- (type: #export (Can-Anonymize code storage)
- (All [entity]
- (Capability (ID code entity storage)
- code)))
-
- (type: #export (Service code)
- (Ex [storage]
- [(Can-Identify code storage)
- (Can-Anonymize code storage)]))
-
- (def: Service<_>
- (All [code storage] (Service code storage))
- [(|>> :abstraction)
- (|>> :representation)])
-
- (type: #export (Context code scope storage)
- (-> (Service code storage)
- (scope storage)))
-
- (def: #export (service _)
- (All [code]
- (Ex [storage]
- (-> Any (Service code storage))))
- ..Service<_>)
-
- (def: #export (with-identity context)
- (All [code scope]
- (Ex [storage]
- (-> (Context code scope storage)
- (scope storage))))
- (context ..Service<_>))
- )
diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux
index 09421e4ee..914a141ab 100644
--- a/stdlib/source/lux/control/security/capability.lux
+++ b/stdlib/source/lux/control/security/capability.lux
@@ -1,8 +1,11 @@
(.module:
[lux #*
+ ["." io (#+ IO)]
[control
[monad (#+ do)]
- ["p" parser]]
+ ["p" parser]
+ [concurrency
+ ["." promise (#+ Promise)]]]
[data
[text
format]
@@ -23,7 +26,7 @@
(-> input output)
- (def: default-forge
+ (def: forge
(All [brand input output]
(-> (-> input output)
(Capability brand input output)))
@@ -54,6 +57,12 @@
(All [(~+ (list/map code.local-identifier vars))]
(-> (-> (~ input) (~ output))
(~ capability)))
- (~! ..default-forge)))
+ (~! ..forge)))
))))
+
+ (def: #export (async capability)
+ (All [brand input output]
+ (-> (Capability brand input (IO output))
+ (Capability brand input (Promise output))))
+ (..forge (|>> ((:representation capability)) promise.future)))
)
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index d4dc36ad0..e06948838 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -5,7 +5,7 @@
["." monad (#+ Monad do)]
[equivalence (#+ Equivalence)]
codec
- ["p" parser ("parser/." monad)]
+ ["p" parser (#+ Parser) ("parser/." monad)]
["ex" exception (#+ exception:)]]
[data
["." bit]
@@ -51,7 +51,7 @@
(type: #export (Reader a)
{#.doc "JSON reader."}
- (p.Parser (List JSON) a))
+ (Parser (List JSON) a))
(syntax: #export (json token)
{#.doc (doc "A simple way to produce JSON literals."
diff --git a/stdlib/source/lux/world/net/http.lux b/stdlib/source/lux/world/net/http.lux
index e84472710..d3bbf5a37 100644
--- a/stdlib/source/lux/world/net/http.lux
+++ b/stdlib/source/lux/world/net/http.lux
@@ -5,6 +5,7 @@
[promise (#+ Promise)]
[frp (#+ Channel)]]]
[data
+ [error (#+ Error)]
[format
[context (#+ Context)]]]
[world
@@ -72,3 +73,6 @@
(type: #export Server
(-> Request (Promise Response)))
+
+(type: #export Client
+ (-> [Method URL Context Data] (Promise (Error Response))))
diff --git a/stdlib/source/lux/world/net/http/request.lux b/stdlib/source/lux/world/net/http/request.lux
index ad8a2e450..b8c4b6b4e 100644
--- a/stdlib/source/lux/world/net/http/request.lux
+++ b/stdlib/source/lux/world/net/http/request.lux
@@ -48,16 +48,17 @@
(def: failure (//response.bad-request ""))
-(def: #export (json server)
- (-> (-> JSON Server) Server)
+(def: #export (json reader server)
+ (All [a] (-> (json.Reader a) (-> a Server) Server))
(function (_ (^@ request [identification protocol resource message]))
(do promise.monad
[?raw (read-text-body (get@ #//.body message))]
(case (do error.monad
- [raw ?raw]
- (:: json.codec decode raw))
- (#error.Success content)
- (server content request)
+ [raw ?raw
+ content (:: json.codec decode raw)]
+ (json.run content reader))
+ (#error.Success input)
+ (server input request)
(#error.Failure error)
(promise.resolved ..failure)))))
diff --git a/stdlib/source/lux/world/service/crud.lux b/stdlib/source/lux/world/service/crud.lux
index f27bda2a3..8e1e99277 100644
--- a/stdlib/source/lux/world/service/crud.lux
+++ b/stdlib/source/lux/world/service/crud.lux
@@ -1,36 +1,33 @@
(.module:
[lux #*
[control
- [identity (#+ ID)]
[security
- [capability (#+ Capability)]]]
+ ["!" capability (#+ capability:)]]]
[data
["." error (#+ Error)]]
[time
["." instant (#+ Instant)]]])
+(type: #export ID Nat)
+
(type: #export Time
{#created Instant
#updated Instant})
-(type: #export (Can-Create ! code entity storage)
- (Capability [Instant entity]
- (! (Error (ID code entity storage)))))
+(capability: #export (Can-Create ! entity)
+ (can-create [Instant entity] (! (Error ID))))
-(type: #export (Can-Retrieve ! code entity storage)
- (Capability (ID code entity storage)
- (! (Error [Time entity]))))
+(capability: #export (Can-Retrieve ! entity)
+ (can-retrieve ID (! (Error [Time entity]))))
-(type: #export (Can-Update ! code entity storage)
- (Capability [(ID code entity storage) Instant entity]
- (! (Error Any))))
+(capability: #export (Can-Update ! entity)
+ (can-update [ID Instant entity] (! (Error Any))))
-(type: #export (Can-Delete ! code entity storage)
- (Capability (ID code entity storage)
- (! (Error Any))))
+(capability: #export (Can-Delete ! entity)
+ (can-delete ID (! (Error Any))))
-(type: #export (CRUD ! code entity storage)
- [(Can-Create ! code entity storage)
- (Can-Retrieve ! code entity storage)
- (Can-Update ! code entity storage)
- (Can-Delete ! code entity storage)])
+(type: #export (CRUD ! entity)
+ {#can-create (Can-Create ! entity)
+ #can-retrieve (Can-Retrieve ! entity)
+ #can-update (Can-Update ! entity)
+ #can-delete (Can-Delete ! entity)})
diff --git a/stdlib/source/lux/world/service/inventory.lux b/stdlib/source/lux/world/service/inventory.lux
index 00b20e71a..0e3fae6be 100644
--- a/stdlib/source/lux/world/service/inventory.lux
+++ b/stdlib/source/lux/world/service/inventory.lux
@@ -1,34 +1,31 @@
(.module:
[lux #*
[control
- [identity (#+ ID)]
[security
- [capability (#+ Capability)]]]
+ ["!" capability (#+ capability:)]]]
[data
[error (#+ Error)]]])
-(with-expansions [<vars> (as-is ! $ @ owner property)
- <owner> (as-is (ID @ owner $))
- <property> (as-is (ID @ property $))]
- (type: #export (Can-Own <vars>)
- (Capability [<owner> <property>]
- (! (Error Any))))
+(type: #export ID Nat)
- (type: #export (Can-Disown <vars>)
- (Capability [<owner> <property>]
- (! (Error Any))))
+(type: #export Ownership
+ {#owner ID
+ #property ID})
- (type: #export (Can-Check <vars>)
- (Capability [<owner> <property>]
- (! (Error Bit))))
+(capability: #export (Can-Own !)
+ (can-own Ownership (! (Error Any))))
- (type: #export (Can-List <vars>)
- (Capability <owner>
- (! (Error (List <property>)))))
+(capability: #export (Can-Disown !)
+ (can-disown Ownership (! (Error Any))))
- (type: #export (Inventory <vars>)
- [(Can-Own <vars>)
- (Can-Disown <vars>)
- (Can-Check <vars>)
- (Can-List <vars>)])
- )
+(capability: #export (Can-Check !)
+ (can-check Ownership (! (Error Bit))))
+
+(capability: #export (Can-List-Property !)
+ (can-list-property ID (! (Error (List ID)))))
+
+(type: #export (Inventory !)
+ {#can-own (Can-Own !)
+ #can-disown (Can-Disown !)
+ #can-check (Can-Check !)
+ #can-list-property (Can-List-Property !)})
diff --git a/stdlib/source/lux/world/service/mail.lux b/stdlib/source/lux/world/service/mail.lux
index 115afb5e3..ce5eb91b3 100644
--- a/stdlib/source/lux/world/service/mail.lux
+++ b/stdlib/source/lux/world/service/mail.lux
@@ -4,15 +4,15 @@
[concurrency
[frp (#+ Channel)]]
[security
- [capability (#+ Capability)]]]
+ ["!" capability (#+ capability:)]]]
[data
[error (#+ Error)]]])
-(type: #export (Can-Send ! address message)
- (Capability [address message] (! (Error Any))))
+(capability: #export (Can-Send ! address message)
+ (can-send [address message] (! (Error Any))))
-(type: #export (Can-Subscribe ! address message)
- (Capability [address] (! (Error (Channel message)))))
+(capability: #export (Can-Subscribe ! address message)
+ (can-subscribe [address] (! (Error (Channel message)))))
(type: #export (Service ! address message)
{#can-send (Can-Send ! address message)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 17:19:48 +0000