From a7ee9bfcaf9d85105b2ee0e34c203bfc86d1ce15 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 10 Feb 2019 21:33:09 -0400 Subject: Various small improments and changes. --- stdlib/source/lux/control/concurrency/frp.lux | 52 +++++++++++--------- stdlib/source/lux/control/concurrency/promise.lux | 49 +++++++++--------- stdlib/source/lux/control/identity.lux | 60 ----------------------- stdlib/source/lux/control/security/capability.lux | 15 ++++-- stdlib/source/lux/data/format/json.lux | 4 +- stdlib/source/lux/world/net/http.lux | 4 ++ stdlib/source/lux/world/net/http/request.lux | 13 ++--- stdlib/source/lux/world/service/crud.lux | 35 ++++++------- stdlib/source/lux/world/service/inventory.lux | 43 ++++++++-------- stdlib/source/lux/world/service/mail.lux | 10 ++-- 10 files changed, 121 insertions(+), 164 deletions(-) delete mode 100644 stdlib/source/lux/control/identity.lux 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) - (All [code entity storage] - (-> (Equivalence code) - (Equivalence (ID code entity storage)))) - (def: (= reference sample) - (:: Equivalence = - (: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 [ (as-is ! $ @ owner property) - (as-is (ID @ owner $)) - (as-is (ID @ property $))] - (type: #export (Can-Own ) - (Capability [ ] - (! (Error Any)))) +(type: #export ID Nat) - (type: #export (Can-Disown ) - (Capability [ ] - (! (Error Any)))) +(type: #export Ownership + {#owner ID + #property ID}) - (type: #export (Can-Check ) - (Capability [ ] - (! (Error Bit)))) +(capability: #export (Can-Own !) + (can-own Ownership (! (Error Any)))) - (type: #export (Can-List ) - (Capability - (! (Error (List ))))) +(capability: #export (Can-Disown !) + (can-disown Ownership (! (Error Any)))) - (type: #export (Inventory ) - [(Can-Own ) - (Can-Disown ) - (Can-Check ) - (Can-List )]) - ) +(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) -- cgit v1.2.3