From 19395f5184abf1f8a61fe31d436e0d743854f79e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 21 Aug 2017 23:36:59 -0400 Subject: - Renamed "model" to "opaque". --- lux-mode/lux-mode.el | 2 +- stdlib/source/lux/concurrency/actor.lux | 10 +- stdlib/source/lux/data/lazy.lux | 22 ++--- stdlib/source/lux/data/tainted.lux | 6 +- stdlib/source/lux/time/duration.lux | 10 +- stdlib/source/lux/time/instant.lux | 12 +-- stdlib/source/lux/type/model.lux | 164 -------------------------------- stdlib/source/lux/type/opaque.lux | 164 ++++++++++++++++++++++++++++++++ 8 files changed, 195 insertions(+), 195 deletions(-) delete mode 100644 stdlib/source/lux/type/model.lux create mode 100644 stdlib/source/lux/type/opaque.lux diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el index f93281d44..c26c2f77e 100644 --- a/lux-mode/lux-mode.el +++ b/lux-mode/lux-mode.el @@ -222,7 +222,7 @@ Called by `imenu--generic-function'." "actor:" "message:" "on:" "exception:" "word:" - "model:" + "opaque:" "unit:" "scale:" "function" "case" ":" ":!" ":!!" "undefined" "ident-for" "and" "or" diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index 04a0db61e..c742b8d75 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -14,7 +14,7 @@ (common ["csr" reader] ["csw" writer]))) [type] - (type model)) + (type opaque)) (.. ["A" atom] ["P" promise "P/" Monad] ["T" task] @@ -29,7 +29,7 @@ (with-expansions [ (as-is (-> s (Actor s) (T;Task s))) (as-is [Text s (List )])] - (model: #export (Actor s) + (opaque: #export (Actor s) {#;doc "An actor, defined as all the necessities it requires."} {#mailbox (stm;Var ) #kill-switch (P;Promise Unit) @@ -51,9 +51,9 @@ (All [s] (-> (Behavior s) s (IO (Actor s)))) (io (let [[handle end] behavior self (: (Actor ($ +0)) - (@model {#mailbox (stm;var (:! (Message ($ +0)) [])) - #kill-switch (P;promise Unit) - #obituary (P;promise (Obituary ($ +0)))})) + (@opaque {#mailbox (stm;var (:! (Message ($ +0)) [])) + #kill-switch (P;promise Unit) + #obituary (P;promise (Obituary ($ +0)))})) mailbox-channel (io;run (stm;follow (get@ #mailbox (@repr self)))) |mailbox| (stm;var mailbox-channel) _ (P/map (function [_] diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux index d2533644a..1891f0100 100644 --- a/stdlib/source/lux/data/lazy.lux +++ b/stdlib/source/lux/data/lazy.lux @@ -7,23 +7,23 @@ (concurrency ["A" atom]) [macro] (macro ["s" syntax #+ syntax:]) - (type model))) + (type opaque))) -(model: #export (Lazy a) +(opaque: #export (Lazy a) (-> [] a) (def: #hidden (freeze' generator) (All [a] (-> (-> [] a) (Lazy a))) (let [cache (A;atom (: (Maybe ($ +0)) #;None))] - (@model (function [_] - (case (io;run (A;get cache)) - (#;Some value) - value - - _ - (let [value (generator [])] - (exec (io;run (A;compare-and-swap _ (#;Some value) cache)) - value))))))) + (@opaque (function [_] + (case (io;run (A;get cache)) + (#;Some value) + value + + _ + (let [value (generator [])] + (exec (io;run (A;compare-and-swap _ (#;Some value) cache)) + value))))))) (def: #export (thaw l-value) (All [a] (-> (Lazy a) a)) diff --git a/stdlib/source/lux/data/tainted.lux b/stdlib/source/lux/data/tainted.lux index 9060d1da5..ffe128022 100644 --- a/stdlib/source/lux/data/tainted.lux +++ b/stdlib/source/lux/data/tainted.lux @@ -1,14 +1,14 @@ (;module: lux (lux (data [product]) - (type model))) + (type opaque))) -(model: #export (Tainted a) +(opaque: #export (Tainted a) a (def: #export taint (All [a] (-> a (Tainted a))) - (|>. @model)) + (|>. @opaque)) (def: #export trust (All [a] (-> (Tainted a) a)) diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux index d4f8bd52c..61f2452a6 100644 --- a/stdlib/source/lux/time/duration.lux +++ b/stdlib/source/lux/time/duration.lux @@ -9,15 +9,15 @@ [text "text/" Monoid] (text ["l" lexer]) ["R" result]) - (type model))) + (type opaque))) -(model: #export Duration +(opaque: #export Duration {#;doc "Durations have a resolution of milliseconds."} Int (def: #export from-millis (-> Int Duration) - (|>. @model)) + (|>. @opaque)) (def: #export to-millis (-> Duration Int) @@ -26,7 +26,7 @@ (do-template [ ] [(def: #export ( param subject) (-> Duration Duration Duration) - (@model ( (@repr param) (@repr subject))))] + (@opaque ( (@repr param) (@repr subject))))] [merge i.+] [frame i.%] @@ -34,7 +34,7 @@ (def: #export (scale scalar duration) (-> Int Duration Duration) - (@model (i.* scalar (@repr duration)))) + (@opaque (i.* scalar (@repr duration)))) (def: #export (query param subject) (-> Duration Duration Int) diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index 5177ffb44..5fb8bf4f1 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -13,17 +13,17 @@ ["R" result] (coll [list "L/" Fold Functor] ["v" vector "v/" Functor Fold])) - (type model)) + (type opaque)) (.. [duration "duration/" Order] [date])) -(model: #export Instant +(opaque: #export Instant {#;doc "Instant is defined as milliseconds since the epoch."} Int (def: #export from-millis (-> Int Instant) - (|>. @model)) + (|>. @opaque)) (def: #export to-millis (-> Instant Int) @@ -35,7 +35,7 @@ (def: #export (shift duration instant) (-> duration;Duration Instant Instant) - (@model (i.+ (duration;to-millis duration) (@repr instant)))) + (@opaque (i.+ (duration;to-millis duration) (@repr instant)))) (def: #export (relative instant) (-> Instant duration;Duration) @@ -43,7 +43,7 @@ (def: #export (absolute offset) (-> duration;Duration Instant) - (|> offset duration;to-millis @model)) + (|> offset duration;to-millis @opaque)) (struct: #export _ (Eq Instant) (def: (= param subject) @@ -62,7 +62,7 @@ (def: order Order) (do-template [] [(def: - (|>. @repr (:: number;Enum ) @model))] + (|>. @repr (:: number;Enum ) @opaque))] [succ] [pred] )) diff --git a/stdlib/source/lux/type/model.lux b/stdlib/source/lux/type/model.lux deleted file mode 100644 index e77a8ac70..000000000 --- a/stdlib/source/lux/type/model.lux +++ /dev/null @@ -1,164 +0,0 @@ -(;module: - lux - (lux (control [applicative] - [monad #+ do Monad] - ["p" parser "p/" Monad]) - (data [text "text/" Eq Monoid] - ["R" result] - (coll [list "L/" Functor Monoid])) - [macro #+ Monad] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))))) - -(def: (get k plist) - (All [a] - (-> Text (List [Text a]) (Maybe a))) - (case plist - #;Nil - #;None - - (#;Cons [k' v] plist') - (if (text/= k k') - (#;Some v) - (get k plist')))) - -(def: (put k v plist) - (All [a] - (-> Text a (List [Text a]) (List [Text a]))) - (case plist - #;Nil - (list [k v]) - - (#;Cons [k' v'] plist') - (if (text/= k k') - (#;Cons [k' v] plist') - (#;Cons [k' v'] (put k v plist'))))) - -(def: (remove k plist) - (All [a] - (-> Text (List [Text a]) (List [Text a]))) - (case plist - #;Nil - #;Nil - - (#;Cons [k' v'] plist') - (if (text/= k k') - plist' - (#;Cons [k' v'] (remove k plist'))))) - -(def: down-cast Text "@model") -(def: up-cast Text "@repr") -(def: macro-anns Anns (list [["lux" "macro?"] (#;BoolA true)])) - -(def: representation-name - (-> Text Text) - (|>. ($_ text/append "{" kind "@" module "}") - (let [[module kind] (ident-for #;;Representation)]))) - -(def: (install-casts' this-module-name name type-vars) - (-> Text Text (List Text) (Lux Unit)) - (do Monad - [this-module (macro;find-module this-module-name) - #let [type-varsC (L/map code;local-symbol type-vars) - model-declaration (` ((~ (code;local-symbol name)) (~@ type-varsC))) - representation-declaration (` ((~ (code;local-symbol (representation-name name))) (~@ type-varsC))) - this-module (|> this-module - (update@ #;defs (put down-cast (: Def - [Macro macro-anns - (function [tokens] - (case tokens - (^ (list value)) - (wrap (list (` ((: (All [(~@ type-varsC)] - (-> (~ representation-declaration) (~ model-declaration))) - (|>. :!!)) - (~ value))))) - - _ - (macro;fail ($_ text/append "Wrong syntax for " down-cast))))]))) - (update@ #;defs (put up-cast (: Def - [Macro macro-anns - (function [tokens] - (case tokens - (^ (list value)) - (wrap (list (` ((: (All [(~@ type-varsC)] - (-> (~ model-declaration) (~ representation-declaration))) - (|>. :!!)) - (~ value))))) - - _ - (macro;fail ($_ text/append "Wrong syntax for " up-cast))))]))))]] - (function [compiler] - (#R;Success [(update@ #;modules (put this-module-name this-module) compiler) - []])))) - -(def: (un-install-casts' this-module-name) - (-> Text (Lux Unit)) - (do Monad - [this-module (macro;find-module this-module-name) - #let [this-module (|> this-module - (update@ #;defs (remove down-cast)) - (update@ #;defs (remove up-cast)))]] - (function [compiler] - (#R;Success [(update@ #;modules (put this-module-name this-module) compiler) - []])))) - -(syntax: #hidden (install-casts [name s;local-symbol] - [type-vars (s;tuple (p;some s;local-symbol))]) - (do @ - [this-module-name macro;current-module-name - ?down-cast (macro;find-macro [this-module-name down-cast]) - ?up-cast (macro;find-macro [this-module-name up-cast])] - (case [?down-cast ?up-cast] - [#;None #;None] - (do @ - [_ (install-casts' this-module-name name type-vars)] - (wrap (list))) - - _ - (macro;fail ($_ text/append - "Cannot temporarily define casting functions (" - down-cast " & " up-cast - ") because definitions like that already exist."))))) - -(syntax: #hidden (un-install-casts) - (do Monad - [this-module-name macro;current-module-name - ?down-cast (macro;find-macro [this-module-name down-cast]) - ?up-cast (macro;find-macro [this-module-name up-cast])] - (case [?down-cast ?up-cast] - [(#;Some _) (#;Some _)] - (do @ - [_ (un-install-casts' this-module-name)] - (wrap (list))) - - _ - (macro;fail ($_ text/append - "Cannot un-define casting functions (" - down-cast " & " up-cast - ") because they do not exist."))))) - -(def: declaration - (s;Syntax [Text (List Text)]) - (p;either (s;form (p;seq s;local-symbol (p;some s;local-symbol))) - (p;seq s;local-symbol (:: p;Monad wrap (list))))) - -(syntax: #export (model: [export csr;export] - [[name type-vars] declaration] - [annotations (p;default cs;empty-annotations csr;annotations)] - representation-type - [primitives (p;some s;any)]) - (let [hidden-name (code;local-symbol (representation-name name)) - type-varsC (L/map code;local-symbol type-vars) - model-declaration (` ((~ (code;local-symbol name)) (~@ type-varsC))) - representation-declaration (` ((~ hidden-name) (~@ type-varsC)))] - (wrap (list& (` (type: (~@ (csw;export export)) (~ model-declaration) - (~ (csw;annotations annotations)) - (host (~ hidden-name) [(~@ type-varsC)]))) - (` (type: (~@ (csw;export export)) (~ representation-declaration) - (~ representation-type))) - (` (install-casts (~ (code;local-symbol name)) [(~@ type-varsC)])) - (L/append primitives - (list (` (un-install-casts)))))))) diff --git a/stdlib/source/lux/type/opaque.lux b/stdlib/source/lux/type/opaque.lux new file mode 100644 index 000000000..4dae66f11 --- /dev/null +++ b/stdlib/source/lux/type/opaque.lux @@ -0,0 +1,164 @@ +(;module: + lux + (lux (control [applicative] + [monad #+ do Monad] + ["p" parser "p/" Monad]) + (data [text "text/" Eq Monoid] + ["R" result] + (coll [list "L/" Functor Monoid])) + [macro #+ Monad] + (macro [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) + +(def: (get k plist) + (All [a] + (-> Text (List [Text a]) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [k' v] plist') + (if (text/= k k') + (#;Some v) + (get k plist')))) + +(def: (put k v plist) + (All [a] + (-> Text a (List [Text a]) (List [Text a]))) + (case plist + #;Nil + (list [k v]) + + (#;Cons [k' v'] plist') + (if (text/= k k') + (#;Cons [k' v] plist') + (#;Cons [k' v'] (put k v plist'))))) + +(def: (remove k plist) + (All [a] + (-> Text (List [Text a]) (List [Text a]))) + (case plist + #;Nil + #;Nil + + (#;Cons [k' v'] plist') + (if (text/= k k') + plist' + (#;Cons [k' v'] (remove k plist'))))) + +(def: down-cast Text "@opaque") +(def: up-cast Text "@repr") +(def: macro-anns Anns (list [["lux" "macro?"] (#;BoolA true)])) + +(def: representation-name + (-> Text Text) + (|>. ($_ text/append "{" kind "@" module "}") + (let [[module kind] (ident-for #;;Representation)]))) + +(def: (install-casts' this-module-name name type-vars) + (-> Text Text (List Text) (Lux Unit)) + (do Monad + [this-module (macro;find-module this-module-name) + #let [type-varsC (L/map code;local-symbol type-vars) + opaque-declaration (` ((~ (code;local-symbol name)) (~@ type-varsC))) + representation-declaration (` ((~ (code;local-symbol (representation-name name))) (~@ type-varsC))) + this-module (|> this-module + (update@ #;defs (put down-cast (: Def + [Macro macro-anns + (function [tokens] + (case tokens + (^ (list value)) + (wrap (list (` ((: (All [(~@ type-varsC)] + (-> (~ representation-declaration) (~ opaque-declaration))) + (|>. :!!)) + (~ value))))) + + _ + (macro;fail ($_ text/append "Wrong syntax for " down-cast))))]))) + (update@ #;defs (put up-cast (: Def + [Macro macro-anns + (function [tokens] + (case tokens + (^ (list value)) + (wrap (list (` ((: (All [(~@ type-varsC)] + (-> (~ opaque-declaration) (~ representation-declaration))) + (|>. :!!)) + (~ value))))) + + _ + (macro;fail ($_ text/append "Wrong syntax for " up-cast))))]))))]] + (function [compiler] + (#R;Success [(update@ #;modules (put this-module-name this-module) compiler) + []])))) + +(def: (un-install-casts' this-module-name) + (-> Text (Lux Unit)) + (do Monad + [this-module (macro;find-module this-module-name) + #let [this-module (|> this-module + (update@ #;defs (remove down-cast)) + (update@ #;defs (remove up-cast)))]] + (function [compiler] + (#R;Success [(update@ #;modules (put this-module-name this-module) compiler) + []])))) + +(syntax: #hidden (install-casts [name s;local-symbol] + [type-vars (s;tuple (p;some s;local-symbol))]) + (do @ + [this-module-name macro;current-module-name + ?down-cast (macro;find-macro [this-module-name down-cast]) + ?up-cast (macro;find-macro [this-module-name up-cast])] + (case [?down-cast ?up-cast] + [#;None #;None] + (do @ + [_ (install-casts' this-module-name name type-vars)] + (wrap (list))) + + _ + (macro;fail ($_ text/append + "Cannot temporarily define casting functions (" + down-cast " & " up-cast + ") because definitions like that already exist."))))) + +(syntax: #hidden (un-install-casts) + (do Monad + [this-module-name macro;current-module-name + ?down-cast (macro;find-macro [this-module-name down-cast]) + ?up-cast (macro;find-macro [this-module-name up-cast])] + (case [?down-cast ?up-cast] + [(#;Some _) (#;Some _)] + (do @ + [_ (un-install-casts' this-module-name)] + (wrap (list))) + + _ + (macro;fail ($_ text/append + "Cannot un-define casting functions (" + down-cast " & " up-cast + ") because they do not exist."))))) + +(def: declaration + (s;Syntax [Text (List Text)]) + (p;either (s;form (p;seq s;local-symbol (p;some s;local-symbol))) + (p;seq s;local-symbol (:: p;Monad wrap (list))))) + +(syntax: #export (opaque: [export csr;export] + [[name type-vars] declaration] + [annotations (p;default cs;empty-annotations csr;annotations)] + representation-type + [primitives (p;some s;any)]) + (let [hidden-name (code;local-symbol (representation-name name)) + type-varsC (L/map code;local-symbol type-vars) + opaque-declaration (` ((~ (code;local-symbol name)) (~@ type-varsC))) + representation-declaration (` ((~ hidden-name) (~@ type-varsC)))] + (wrap (list& (` (type: (~@ (csw;export export)) (~ opaque-declaration) + (~ (csw;annotations annotations)) + (host (~ hidden-name) [(~@ type-varsC)]))) + (` (type: (~@ (csw;export export)) (~ representation-declaration) + (~ representation-type))) + (` (install-casts (~ (code;local-symbol name)) [(~@ type-varsC)])) + (L/append primitives + (list (` (un-install-casts)))))))) -- cgit v1.2.3