From f11c10f72d003555d76c9803954e2bd8b347362d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Nov 2017 22:30:57 -0400 Subject: - Moved "/type/*" to from "lux/meta/" to "lux/". --- stdlib/source/lux/concurrency/actor.lux | 4 +- stdlib/source/lux/data/color.lux | 2 +- stdlib/source/lux/data/format/json.lux | 74 ++-- stdlib/source/lux/data/lazy.lux | 4 +- stdlib/source/lux/data/store.lux | 2 +- stdlib/source/lux/data/tainted.lux | 2 +- stdlib/source/lux/data/text/format.lux | 6 +- stdlib/source/lux/meta/poly.lux | 54 +-- stdlib/source/lux/meta/poly/eq.lux | 4 +- stdlib/source/lux/meta/poly/json.lux | 4 +- stdlib/source/lux/meta/type/implicit.lux | 363 -------------------- stdlib/source/lux/meta/type/object.lux | 515 ---------------------------- stdlib/source/lux/meta/type/opaque.lux | 164 --------- stdlib/source/lux/meta/type/unit.lux | 183 ---------- stdlib/source/lux/time/date.lux | 4 +- stdlib/source/lux/time/duration.lux | 6 +- stdlib/source/lux/time/instant.lux | 6 +- stdlib/source/lux/type/implicit.lux | 363 ++++++++++++++++++++ stdlib/source/lux/type/object.lux | 515 ++++++++++++++++++++++++++++ stdlib/source/lux/type/opaque.lux | 164 +++++++++ stdlib/source/lux/type/unit.lux | 183 ++++++++++ stdlib/source/lux/world/net/tcp.jvm.lux | 24 +- stdlib/source/lux/world/net/udp.jvm.lux | 18 +- stdlib/test/test/lux/data/format/json.lux | 12 +- stdlib/test/test/lux/meta/type/implicit.lux | 38 -- stdlib/test/test/lux/meta/type/object.lux | 83 ----- stdlib/test/test/lux/type/implicit.lux | 38 ++ stdlib/test/test/lux/type/object.lux | 83 +++++ stdlib/test/tests.lux | 8 +- 29 files changed, 1463 insertions(+), 1463 deletions(-) delete mode 100644 stdlib/source/lux/meta/type/implicit.lux delete mode 100644 stdlib/source/lux/meta/type/object.lux delete mode 100644 stdlib/source/lux/meta/type/opaque.lux delete mode 100644 stdlib/source/lux/meta/type/unit.lux create mode 100644 stdlib/source/lux/type/implicit.lux create mode 100644 stdlib/source/lux/type/object.lux create mode 100644 stdlib/source/lux/type/opaque.lux create mode 100644 stdlib/source/lux/type/unit.lux delete mode 100644 stdlib/test/test/lux/meta/type/implicit.lux delete mode 100644 stdlib/test/test/lux/meta/type/object.lux create mode 100644 stdlib/test/test/lux/type/implicit.lux create mode 100644 stdlib/test/test/lux/type/object.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index fea0ca422..7d5c41583 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -12,8 +12,8 @@ ["s" syntax #+ syntax: Syntax] (syntax ["cs" common] (common ["csr" reader] - ["csw" writer])) - (type opaque)) + ["csw" writer]))) + (type opaque) (lang [type])) (.. ["A" atom] ["P" promise "P/" Monad] diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux index 490e31094..61ee1249a 100644 --- a/stdlib/source/lux/data/color.lux +++ b/stdlib/source/lux/data/color.lux @@ -3,7 +3,7 @@ (lux (control [eq]) (data (coll [list "L/" Functor])) [math] - (meta (type opaque)))) + (type opaque))) (def: rgb Nat +256) (def: top Nat (n.dec rgb)) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 8f664d6ea..ddc2b48cf 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -11,7 +11,7 @@ (text ["l" lexer]) [number "frac/" Codec "nat/" Codec] [maybe] - ["E" error] + ["e" error] [sum] [product] (coll [list "list/" Fold Monad] @@ -96,52 +96,52 @@ (def: #export (get-fields json) {#;doc "Get all the fields in a JSON object."} - (-> JSON (E;Error (List String))) + (-> JSON (e;Error (List String))) (case json (#Object obj) - (#E;Success (dict;keys obj)) + (#e;Success (dict;keys obj)) _ - (#E;Error ($_ text/compose "Cannot get the fields of a non-object.")))) + (#e;Error ($_ text/compose "Cannot get the fields of a non-object.")))) (def: #export (get key json) {#;doc "A JSON object field getter."} - (-> String JSON (E;Error JSON)) + (-> String JSON (e;Error JSON)) (case json (#Object obj) (case (dict;get key obj) (#;Some value) - (#E;Success value) + (#e;Success value) #;None - (#E;Error ($_ text/compose "Missing field \"" key "\" on object."))) + (#e;Error ($_ text/compose "Missing field \"" key "\" on object."))) _ - (#E;Error ($_ text/compose "Cannot get field \"" key "\" of a non-object.")))) + (#e;Error ($_ text/compose "Cannot get field \"" key "\" of a non-object.")))) (def: #export (set key value json) {#;doc "A JSON object field setter."} - (-> String JSON JSON (E;Error JSON)) + (-> String JSON JSON (e;Error JSON)) (case json (#Object obj) - (#E;Success (#Object (dict;put key value obj))) + (#e;Success (#Object (dict;put key value obj))) _ - (#E;Error ($_ text/compose "Cannot set field \"" key "\" of a non-object.")))) + (#e;Error ($_ text/compose "Cannot set field \"" key "\" of a non-object.")))) (do-template [ ] [(def: #export ( key json) {#;doc (code;text ($_ text/compose "A JSON object field getter for " "."))} - (-> Text JSON (E;Error )) + (-> Text JSON (e;Error )) (case (get key json) - (#E;Success ( value)) - (#E;Success value) + (#e;Success ( value)) + (#e;Success value) - (#E;Success _) - (#E;Error ($_ text/compose "Wrong value type at key: " key)) + (#e;Success _) + (#e;Error ($_ text/compose "Wrong value type at key: " key)) - (#E;Error error) - (#E;Error error)))] + (#e;Error error) + (#e;Error error)))] [get-boolean #Boolean Boolean "booleans"] [get-number #Number Number "numbers"] @@ -195,23 +195,23 @@ (def: unconsumed-input-error Text "Unconsumed JSON.") (def: #export (run json parser) - (All [a] (-> JSON (Reader a) (E;Error a))) + (All [a] (-> JSON (Reader a) (e;Error a))) (case (p;run (list json) parser) - (#E;Success [remainder output]) + (#e;Success [remainder output]) (case remainder #;Nil - (#E;Success output) + (#e;Success output) _ - (#E;Error unconsumed-input-error)) + (#e;Error unconsumed-input-error)) - (#E;Error error) - (#E;Error error))) + (#e;Error error) + (#e;Error error))) (def: #export (fail error) (All [a] (-> Text (Reader a))) (function [inputs] - (#E;Error error))) + (#e;Error error))) (def: #export any {#;doc "Just returns the JSON input without applying any logic."} @@ -219,10 +219,10 @@ (<| (function [inputs]) (case inputs #;Nil - (#E;Error "Empty JSON stream.") + (#e;Error "Empty JSON stream.") (#;Cons head tail) - (#E;Success [tail head])))) + (#e;Success [tail head])))) (do-template [ ] [(def: #export @@ -289,10 +289,10 @@ (case head (#Array values) (case (p;run (sequence;to-list values) parser) - (#E;Error error) + (#e;Error error) (fail error) - (#E;Success [remainder output]) + (#e;Success [remainder output]) (case remainder #;Nil (wrap output) @@ -310,7 +310,7 @@ [head any] (case head (#Object object) - (case (do E;Monad + (case (do e;Monad [] (|> (dict;entries object) (monad;map @ (function [[key val]] @@ -318,10 +318,10 @@ [val (run val parser)] (wrap [key val])))) (:: @ map (dict;from-list text;Hash)))) - (#E;Success table) + (#e;Success table) (wrap table) - (#E;Error error) + (#e;Error error) (fail error)) _ @@ -337,13 +337,13 @@ (case (dict;get field-name object) (#;Some value) (case (run value parser) - (#E;Success output) + (#e;Success output) (function [tail] - (#E;Success [(#;Cons (#Object (dict;remove field-name object)) + (#e;Success [(#;Cons (#Object (dict;remove field-name object)) tail) output])) - (#E;Error error) + (#e;Error error) (fail error)) _ @@ -438,10 +438,10 @@ offset (l;many l;decimal)] (wrap ($_ text/compose mark (if signed?' "-" "") offset))))] (case (frac/decode ($_ text/compose (if signed? "-" "") digits "." decimals exp)) - (#E;Error message) + (#e;Error message) (p;fail message) - (#E;Success value) + (#e;Success value) (wrap value)))) (def: escaped~ diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux index 0b0bf8a1d..547418d51 100644 --- a/stdlib/source/lux/data/lazy.lux +++ b/stdlib/source/lux/data/lazy.lux @@ -6,8 +6,8 @@ monad) (concurrency ["a" atom]) [meta] - (meta ["s" syntax #+ syntax:] - (type opaque)))) + (meta ["s" syntax #+ syntax:]) + (type opaque))) (opaque: #export (Lazy a) (-> [] a) diff --git a/stdlib/source/lux/data/store.lux b/stdlib/source/lux/data/store.lux index f2713c6b8..535254ad9 100644 --- a/stdlib/source/lux/data/store.lux +++ b/stdlib/source/lux/data/store.lux @@ -2,7 +2,7 @@ lux (lux (control ["F" functor] comonad) - (meta (type implicit)))) + (type implicit))) (type: #export (Store s a) {#cursor s diff --git a/stdlib/source/lux/data/tainted.lux b/stdlib/source/lux/data/tainted.lux index ad91ea8ab..ffe128022 100644 --- a/stdlib/source/lux/data/tainted.lux +++ b/stdlib/source/lux/data/tainted.lux @@ -1,7 +1,7 @@ (;module: lux (lux (data [product]) - (meta (type opaque)))) + (type opaque))) (opaque: #export (Tainted a) a diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 161288d86..7fdd9f552 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -1,12 +1,12 @@ (;module: lux - (lux (control ["M" monad #+ do Monad] + (lux (control [monad #+ do Monad] ["p" parser]) (data [bool] [number] [text] [ident] - (coll [list "L/" Monad]) + (coll [list "list/" Monad]) (format [xml] [json])) (time [instant] @@ -64,4 +64,4 @@ "(list)" _ - (format "(list " (text;join-with " " (L/map formatter values)) ")")))) + (format "(list " (text;join-with " " (list/map formatter values)) ")")))) diff --git a/stdlib/source/lux/meta/poly.lux b/stdlib/source/lux/meta/poly.lux index 432d9385a..08d91c5f0 100644 --- a/stdlib/source/lux/meta/poly.lux +++ b/stdlib/source/lux/meta/poly.lux @@ -12,7 +12,7 @@ [bool] [maybe] [ident "ident/" Eq Codec] - ["E" error]) + ["e" error]) [meta #+ with-gensyms] (meta [code] ["s" syntax #+ syntax: Syntax] @@ -31,70 +31,70 @@ (def: #export fresh Env (dict;new number;Hash)) (def: (run' env types poly) - (All [a] (-> Env (List Type) (Poly a) (E;Error a))) + (All [a] (-> Env (List Type) (Poly a) (e;Error a))) (case (p;run [env types] poly) - (#E;Error error) - (#E;Error error) + (#e;Error error) + (#e;Error error) - (#E;Success [[env' remaining] output]) + (#e;Success [[env' remaining] output]) (case remaining #;Nil - (#E;Success output) + (#e;Success output) _ - (#E;Error (|> remaining + (#e;Error (|> remaining (list/map type;to-text) (text;join-with ", ") (text/compose "Unconsumed types: ")))))) (def: #export (run type poly) - (All [a] (-> Type (Poly a) (E;Error a))) + (All [a] (-> Type (Poly a) (e;Error a))) (run' fresh (list type) poly)) (def: #export env (Poly Env) (;function [[env inputs]] - (#E;Success [[env inputs] env]))) + (#e;Success [[env inputs] env]))) (def: (with-env temp poly) (All [a] (-> Env (Poly a) (Poly a))) (;function [[env inputs]] (case (p;run [temp inputs] poly) - (#E;Error error) - (#E;Error error) + (#e;Error error) + (#e;Error error) - (#E;Success [[_ remaining] output]) - (#E;Success [[env remaining] output])))) + (#e;Success [[_ remaining] output]) + (#e;Success [[env remaining] output])))) (def: #export peek (Poly Type) (;function [[env inputs]] (case inputs #;Nil - (#E;Error "Empty stream of types.") + (#e;Error "Empty stream of types.") (#;Cons headT tail) - (#E;Success [[env inputs] headT])))) + (#e;Success [[env inputs] headT])))) (def: #export any (Poly Type) (;function [[env inputs]] (case inputs #;Nil - (#E;Error "Empty stream of types.") + (#e;Error "Empty stream of types.") (#;Cons headT tail) - (#E;Success [[env tail] headT])))) + (#e;Success [[env tail] headT])))) (def: #export (local types poly) (All [a] (-> (List Type) (Poly a) (Poly a))) (;function [[env pass-through]] (case (run' env types poly) - (#E;Error error) - (#E;Error error) + (#e;Error error) + (#e;Error error) - (#E;Success output) - (#E;Success [[env pass-through] output])))) + (#e;Success output) + (#e;Success [[env pass-through] output])))) (def: (label idx) (-> Nat Code) @@ -108,11 +108,11 @@ (case (p;run [(dict;put current-id [type g!var] env) inputs] poly) - (#E;Error error) - (#E;Error error) + (#e;Error error) + (#e;Error error) - (#E;Success [[_ inputs'] output]) - (#E;Success [[env inputs'] [g!var output]]))))) + (#e;Success [[_ inputs'] output]) + (#e;Success [[env inputs'] [g!var output]]))))) (do-template [ ] [(def: #export @@ -149,10 +149,10 @@ deg frac text)) - (#E;Error error) + (#e;Error error) (p;fail error) - (#E;Success _) + (#e;Success _) (wrap headT)))) (do-template [ ] diff --git a/stdlib/source/lux/meta/poly/eq.lux b/stdlib/source/lux/meta/poly/eq.lux index a57a9e5de..0d63f0d35 100644 --- a/stdlib/source/lux/meta/poly/eq.lux +++ b/stdlib/source/lux/meta/poly/eq.lux @@ -23,8 +23,8 @@ (meta [code] [syntax #+ syntax: Syntax] (syntax [common]) - [poly #+ poly:] - (type [unit])) + [poly #+ poly:]) + (type [unit]) (lang [type]) )) diff --git a/stdlib/source/lux/meta/poly/json.lux b/stdlib/source/lux/meta/poly/json.lux index 703bbf109..282c8ad7c 100644 --- a/stdlib/source/lux/meta/poly/json.lux +++ b/stdlib/source/lux/meta/poly/json.lux @@ -23,8 +23,8 @@ [meta #+ with-gensyms] (meta ["s" syntax #+ syntax:] [code] - [poly #+ poly:] - (type [unit])) + [poly #+ poly:]) + (type [unit]) (lang [type]) )) diff --git a/stdlib/source/lux/meta/type/implicit.lux b/stdlib/source/lux/meta/type/implicit.lux deleted file mode 100644 index 54fec2626..000000000 --- a/stdlib/source/lux/meta/type/implicit.lux +++ /dev/null @@ -1,363 +0,0 @@ -(;module: - lux - (lux (control ["M" monad #+ do Monad] - [eq] - ["p" parser]) - (data [text "Text/" Eq] - text/format - [number] - (coll [list "List/" Monad Fold] - [dict]) - [bool] - [product] - [maybe]) - [meta #+ Monad] - (meta [code] - ["s" syntax #+ syntax: Syntax]) - (lang [type] - (type ["tc" check #+ Check Monad])) - )) - -(def: (find-type-var id env) - (-> Nat Type-Context (Meta Type)) - (case (list;find (|>. product;left (n.= id)) - (get@ #;var-bindings env)) - (#;Some [_ (#;Some type)]) - (case type - (#;Var id') - (find-type-var id' env) - - _ - (:: Monad wrap type)) - - (#;Some [_ #;None]) - (meta;fail (format "Unbound type-var " (%n id))) - - #;None - (meta;fail (format "Unknown type-var " (%n id))) - )) - -(def: (resolve-type var-name) - (-> Ident (Meta Type)) - (do Monad - [raw-type (meta;find-type var-name) - compiler meta;get-compiler] - (case raw-type - (#;Var id) - (find-type-var id (get@ #;type-context compiler)) - - _ - (wrap raw-type)))) - -(def: (find-member-type idx sig-type) - (-> Nat Type (Check Type)) - (case sig-type - (#;Named _ sig-type') - (find-member-type idx sig-type') - - (#;Apply arg func) - (case (type;apply (list arg) func) - #;None - (tc;fail (format "Cannot apply type " (%type func) " to type " (%type arg))) - - (#;Some sig-type') - (find-member-type idx sig-type')) - - (#;Product left right) - (if (n.= +0 idx) - (:: Monad wrap left) - (find-member-type (n.dec idx) right)) - - _ - (if (n.= +0 idx) - (:: Monad wrap sig-type) - (tc;fail (format "Cannot find member type " (%n idx) " for " (%type sig-type)))))) - -(def: (find-member-name member) - (-> Ident (Meta Ident)) - (case member - ["" simple-name] - (meta;either (do Monad - [member (meta;normalize member) - _ (meta;resolve-tag member)] - (wrap member)) - (do Monad - [this-module-name meta;current-module-name - imp-mods (meta;imported-modules this-module-name) - tag-lists (M;map @ meta;tag-lists imp-mods) - #let [tag-lists (|> tag-lists List/join (List/map product;left) List/join) - candidates (list;filter (. (Text/= simple-name) product;right) - tag-lists)]] - (case candidates - #;Nil - (meta;fail (format "Unknown tag: " (%ident member))) - - (#;Cons winner #;Nil) - (wrap winner) - - _ - (meta;fail (format "Too many candidate tags: " (%list %ident candidates)))))) - - _ - (:: Monad wrap member))) - -(def: (resolve-member member) - (-> Ident (Meta [Nat Type])) - (do Monad - [member (find-member-name member) - [idx tag-list sig-type] (meta;resolve-tag member)] - (wrap [idx sig-type]))) - -(def: (prepare-defs this-module-name defs) - (-> Text (List [Text Def]) (List [Ident Type])) - (|> defs - (list;filter (function [[name [def-type def-anns def-value]]] - (meta;struct? def-anns))) - (List/map (function [[name [def-type def-anns def-value]]] - [[this-module-name name] def-type])))) - -(def: local-env - (Meta (List [Ident Type])) - (do Monad - [local-batches meta;locals - #let [total-locals (List/fold (function [[name type] table] - (dict;put~ name type table)) - (: (dict;Dict Text Type) - (dict;new text;Hash)) - (List/join local-batches))]] - (wrap (|> total-locals - dict;entries - (List/map (function [[name type]] [["" name] type])))))) - -(def: local-structs - (Meta (List [Ident Type])) - (do Monad - [this-module-name meta;current-module-name - defs (meta;defs this-module-name)] - (wrap (prepare-defs this-module-name defs)))) - -(def: import-structs - (Meta (List [Ident Type])) - (do Monad - [this-module-name meta;current-module-name - imp-mods (meta;imported-modules this-module-name) - export-batches (M;map @ (function [imp-mod] - (do @ - [exports (meta;exports imp-mod)] - (wrap (prepare-defs imp-mod exports)))) - imp-mods)] - (wrap (List/join export-batches)))) - -(def: (apply-function-type func arg) - (-> Type Type (Check Type)) - (case func - (#;Named _ func') - (apply-function-type func' arg) - - (#;UnivQ _) - (do Monad - [[id var] tc;var] - (apply-function-type (maybe;assume (type;apply (list var) func)) - arg)) - - (#;Function input output) - (do Monad - [_ (tc;check input arg)] - (wrap output)) - - _ - (tc;fail (format "Invalid function type: " (%type func))))) - -(def: (concrete-type type) - (-> Type (Check [(List Nat) Type])) - (case type - (#;UnivQ _) - (do Monad - [[id var] tc;var - [ids final-output] (concrete-type (maybe;assume (type;apply (list var) type)))] - (wrap [(#;Cons id ids) - final-output])) - - _ - (:: Monad wrap [(list) type]))) - -(def: (check-apply member-type input-types output-type) - (-> Type (List Type) Type (Check [])) - (do Monad - [member-type' (M;fold Monad - (function [input member] - (apply-function-type member input)) - member-type - input-types)] - (tc;check output-type member-type'))) - -(type: #rec Instance - {#constructor Ident - #dependencies (List Instance)}) - -(def: (test-provision provision context dep alts) - (-> (-> Compiler Type-Context Type (Check Instance)) - Type-Context Type (List [Ident Type]) - (Meta (List Instance))) - (do Monad - [compiler meta;get-compiler] - (case (|> alts - (List/map (function [[alt-name alt-type]] - (case (tc;run context - (do Monad - [[tvars alt-type] (concrete-type alt-type) - #let [[deps alt-type] (type;flatten-function alt-type)] - _ (tc;check dep alt-type) - context' tc;get-context - =deps (M;map @ (provision compiler context') deps)] - (wrap =deps))) - (#;Left error) - (list) - - (#;Right =deps) - (list [alt-name =deps])))) - List/join) - #;Nil - (meta;fail (format "No candidates for provisioning: " (%type dep))) - - found - (wrap found)))) - -(def: (provision compiler context dep) - (-> Compiler Type-Context Type (Check Instance)) - (case (meta;run compiler - ($_ meta;either - (do Monad [alts local-env] (test-provision provision context dep alts)) - (do Monad [alts local-structs] (test-provision provision context dep alts)) - (do Monad [alts import-structs] (test-provision provision context dep alts)))) - (#;Left error) - (tc;fail error) - - (#;Right candidates) - (case candidates - #;Nil - (tc;fail (format "No candidates for provisioning: " (%type dep))) - - (#;Cons winner #;Nil) - (:: Monad wrap winner) - - _ - (tc;fail (format "Too many candidates for provisioning: " (%type dep) " --- " (%list (. %ident product;left) candidates)))) - )) - -(def: (test-alternatives sig-type member-idx input-types output-type alts) - (-> Type Nat (List Type) Type (List [Ident Type]) (Meta (List Instance))) - (do Monad - [compiler meta;get-compiler - context meta;type-context] - (case (|> alts - (List/map (function [[alt-name alt-type]] - (case (tc;run context - (do Monad - [[tvars alt-type] (concrete-type alt-type) - #let [[deps alt-type] (type;flatten-function alt-type)] - _ (tc;check alt-type sig-type) - member-type (find-member-type member-idx alt-type) - _ (check-apply member-type input-types output-type) - context' tc;get-context - =deps (M;map @ (provision compiler context') deps)] - (wrap =deps))) - (#;Left error) - (list) - - (#;Right =deps) - (list [alt-name =deps])))) - List/join) - #;Nil - (meta;fail (format "No alternatives for " (%type (type;function input-types output-type)))) - - found - (wrap found)))) - -(def: (find-alternatives sig-type member-idx input-types output-type) - (-> Type Nat (List Type) Type (Meta (List Instance))) - (let [test (test-alternatives sig-type member-idx input-types output-type)] - ($_ meta;either - (do Monad [alts local-env] (test alts)) - (do Monad [alts local-structs] (test alts)) - (do Monad [alts import-structs] (test alts))))) - -(def: (var? input) - (-> Code Bool) - (case input - [_ (#;Symbol _)] - true - - _ - false)) - -(def: (join-pair [l r]) - (All [a] (-> [a a] (List a))) - (list l r)) - -(def: (instance$ [constructor dependencies]) - (-> Instance Code) - (case dependencies - #;Nil - (code;symbol constructor) - - _ - (` ((~ (code;symbol constructor)) (~@ (List/map instance$ dependencies)))))) - -(syntax: #export (::: [member s;symbol] - [args (p;alt (p;seq (p;some s;symbol) s;end!) - (p;seq (p;some s;any) s;end!))]) - {#;doc (doc "Automatic structure selection (for type-class style polymorphism)." - "This feature layers type-class style polymorphism on top of Lux's signatures and structures." - "When calling a polymorphic function, or using a polymorphic constant," - "this macro will check the types of the arguments, and the expected type for the whole expression" - "and it will search in the local scope, the module's scope and the imports' scope" - "in order to find suitable structures to satisfy those requirements." - "If a single alternative is found, that one will be used automatically." - "If no alternative is found, or if more than one alternative is found (ambiguity)" - "a compile-time error will be raised, to alert the user." - "Examples:" - "Nat equality" - (:: number;Eq = x y) - (::: = x y) - "Can optionally add the prefix of the module where the signature was defined." - (::: eq;= x y) - "(List Nat) equality" - (::: = - (list;n.range +1 +10) - (list;n.range +1 +10)) - "(Functor List) map" - (::: map n.inc (list;n.range +0 +9)) - "Caveat emptor: You need to make sure to import the module of any structure you want to use." - "Otherwise, this macro will not find it.")} - (case args - (#;Left [args _]) - (do @ - [[member-idx sig-type] (resolve-member member) - input-types (M;map @ resolve-type args) - output-type meta;expected-type - chosen-ones (find-alternatives sig-type member-idx input-types output-type)] - (case chosen-ones - #;Nil - (meta;fail (format "No structure option could be found for member: " (%ident member))) - - (#;Cons chosen #;Nil) - (wrap (list (` (:: (~ (instance$ chosen)) - (~ (code;local-symbol (product;right member))) - (~@ (List/map code;symbol args)))))) - - _ - (meta;fail (format "Too many options available: " - (|> chosen-ones - (List/map (. %ident product;left)) - (text;join-with ", ")) - " --- for type: " (%type sig-type))))) - - (#;Right [args _]) - (do @ - [labels (M;seq @ (list;repeat (list;size args) - (meta;gensym ""))) - #let [retry (` (let [(~@ (|> (list;zip2 labels args) (List/map join-pair) List/join))] - (;;::: (~ (code;symbol member)) (~@ labels))))]] - (wrap (list retry))) - )) diff --git a/stdlib/source/lux/meta/type/object.lux b/stdlib/source/lux/meta/type/object.lux deleted file mode 100644 index 0eb354242..000000000 --- a/stdlib/source/lux/meta/type/object.lux +++ /dev/null @@ -1,515 +0,0 @@ -(;module: - lux - (lux (control ["M" monad #+ do Monad] - ["p" parser "p/" Monad]) - (data [text] - text/format - [product] - [maybe] - [ident #+ "Ident/" Eq] - (coll [list "L/" Functor Fold Monoid] - [set #+ Set])) - [meta #+ Monad "Meta/" Monad] - (meta [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))) - (lang [type]))) - -## [Common] -(type: Declaration - [Text (List Text)]) - -(type: Alias Text) - -(def: default-alias Alias "@") - -(def: (var-set vars) - (-> (List Text) (Set Text)) - (set;from-list text;Hash vars)) - -(def: (unique-type-vars parser) - (-> (s;Syntax (List Text)) (s;Syntax (List Text))) - (do p;Monad - [raw parser - _ (p;assert "Cannot repeat the names of type variables/parameters." - (n.= (set;size (var-set raw)) - (list;size raw)))] - (wrap raw))) - -(def: (safe-type-vars exclusions) - (-> (Set Text) (s;Syntax Text)) - (do p;Monad - [raw s;local-symbol - _ (p;assert "Cannot re-use names between method type-variables and interface type-parameters." - (|> raw (set;member? exclusions) not))] - (wrap raw))) - -(def: declarationS - (s;Syntax Declaration) - (p;either (s;form (p;seq s;local-symbol - (unique-type-vars (p;some s;local-symbol)))) - (p;seq s;local-symbol - (p/wrap (list))))) - -(def: aliasS - (s;Syntax Alias) - (|> s;local-symbol - (p;after (s;this (' #as))) - (p;default default-alias))) - -(def: (ancestor-inputs ancestors) - (-> (List Ident) (List Code)) - (if (list;empty? ancestors) - (list) - (|> (list;size ancestors) - n.dec - (list;n.range +0) - (L/map (|>. %n (format "ancestor") code;local-symbol))))) - -## [Methods] -(type: Method - {#type-vars (List Text) - #name Text - #inputs (List Code) - #output Code}) - -(def: (method exclusions) - (-> (Set Text) (s;Syntax Method)) - (s;form ($_ p;seq - (p;either (unique-type-vars (s;tuple (p;some (safe-type-vars exclusions)))) - (p/wrap (list))) - s;local-symbol - (s;tuple (p;some s;any)) - s;any))) - -(def: (declarationM g!self (^open)) - (-> Code Method Code) - (let [g!type-vars (L/map code;local-symbol type-vars) - g!method (code;local-symbol name)] - (` (: (All [(~@ g!type-vars)] - (-> (~@ inputs) (~ g!self) (~ output))) - (~ g!method))))) - -(def: (definition export [interface parameters] g!self-object g!ext g!states (^open)) - (-> (Maybe cs;Export) Declaration Code Code (List Code) Method Code) - (let [g!method (code;local-symbol name) - g!parameters (L/map code;local-symbol parameters) - g!type-vars (L/map code;local-symbol type-vars) - g!_temp (code;symbol ["" "_temp"]) - g!_object (code;symbol ["" "_object"]) - g!_behavior (code;symbol ["" "_behavior"]) - g!_state (code;symbol ["" "_state"]) - g!_extension (code;symbol ["" "_extension"]) - g!_args (L/map (|>. product;left nat-to-int %i (format "_") code;local-symbol) - (list;enumerate inputs)) - g!destructuring (L/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) - (maybe;default g!states (list;tail g!states)))] - (` (def: (~@ (csw;export export)) ((~ g!method) (~@ g!_args) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!states) (~@ g!type-vars)] - (-> (~@ inputs) (~ g!self-object) (~ output))) - (let [(~ g!destructuring) (~ g!_object)] - (:: (~ g!_behavior) (~ g!method) (~@ g!_args) (~ g!_object))))))) - -## [Inheritance] -(type: Reference - [Ident (List Code)]) - -(def: no-parent Ident ["" ""]) - -(def: (no-parent? parent) - (-> Ident Bool) - (Ident/= no-parent parent)) - -(def: (with-interface parent interface) - (-> Ident Ident cs;Annotations cs;Annotations) - (|>. (#;Cons [(ident-for #;;interface-name) - (code;tag interface)]) - (#;Cons [(ident-for #;;interface-parent) - (code;tag parent)]))) - -(def: (with-class interface parent class) - (-> Ident Ident Ident cs;Annotations cs;Annotations) - (|>. (#;Cons [(ident-for #;;class-interface) - (code;tag interface)]) - (#;Cons [(ident-for #;;class-parent) - (code;tag parent)]) - (#;Cons [(ident-for #;;class-name) - (code;tag class)]))) - -(do-template [ ] - [(def: ( name) - (-> Ident (Meta [Ident (List Ident)])) - (do Monad - [name (meta;normalize name) - [_ annotations _] (meta;find-def name)] - (case [(meta;get-tag-ann (ident-for ) annotations) - (meta;get-tag-ann (ident-for ) annotations)] - [(#;Some real-name) (#;Some parent)] - (if (Ident/= no-parent parent) - (wrap [real-name (list)]) - (do @ - [[_ ancestors] ( parent)] - (wrap [real-name (#;Cons parent ancestors)]))) - - _ - (meta;fail (format "Wrong format for " " lineage.")))))] - - [interfaceN #;;interface-name #;;interface-parent "interface"] - [classN #;;class-name #;;class-parent "class"] - ) - -(def: (extract newT) - (-> Type (Meta [Nat (List Type)])) - (loop [depth +0 - currentT newT] - (case currentT - (#;UnivQ _ bodyT) - (recur (n.inc depth) bodyT) - - (#;Function inputT outputT) - (let [[stateT+ objectT] (type;flatten-function currentT)] - (Meta/wrap [depth stateT+])) - - _ - (meta;fail (format "Cannot extract inheritance from type: " (type;to-text newT)))))) - -(def: (specialize mappings typeC) - (-> (List Code) Code Code) - (case (list;size mappings) - +0 - typeC - - size - (|> (n.dec size) - (list;n.range +0) - (L/map (|>. (n.* +2) n.inc code;nat (~) #;Bound (`))) - (list;zip2 (list;reverse mappings)) - (L/fold (function [[mappingC boundC] genericC] - (code;replace boundC mappingC genericC)) - typeC)))) - -(def: referenceS - (s;Syntax Reference) - (p;either (s;form (p;seq s;symbol - (p;some s;any))) - (p;seq s;symbol - (p/wrap (list))))) - -(do-template [ ] - [(def: - (s;Syntax Reference) - (|> referenceS - (p;after (s;this (' )))))] - - [extension #super] - [inheritance #super] - ) - -## [Notation] -## Utils -(def: (nest ancestors bottom) - (-> (List Code) Code Code) - (L/fold (function [[level _] g!bottom] - (let [g!_behavior' (code;local-symbol (format "_behavior" (%n level))) - g!_state' (code;local-symbol (format "_state" (%n level)))] - (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)]))) - bottom - (list;enumerate ancestors))) - -## Names -(do-template [ ] - [(def: ( base) - (-> Text Text) - (|> base (format "@")))] - - [newN "new"] - [getN "get"] - [setN "set"] - [updateN "update"] - ) - -(do-template [ ] - [(def: ( raw) - (-> Text Text) - (let [[module kind] (ident-for )] - (format "{" kind "@" module "}" raw)))] - - [signatureN #;;Signature] - [stateN #;;State] - [structN #;;Struct] - ) - -(def: (getterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) - Code) - (let [g!get (code;local-symbol (getN interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - g!tear-down (nest g!ancestors - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))] - (` (def: (~@ (csw;export export)) ((~ g!get) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] - (-> (~ g!object) (~ g!child))) - (let [(~ g!tear-down) (~ g!_object)] - (~ g!_state)))))) - -(def: (setterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) - Code) - (let [g!set (code;local-symbol (setN interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_input (' _input) - g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - g!tear-down (nest g!ancestors - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) - g!build-up (nest g!ancestors - (` [(~ g!_behavior) (~ g!_input) (~ g!_extension)]))] - (` (def: (~@ (csw;export export)) - ((~ g!set) (~ g!_input) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] - (-> (~ g!child) (~ g!object) (~ g!object))) - (let [(~ g!tear-down) (~ g!_object)] - (~ g!build-up)))))) - -(def: (updaterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) - Code) - (let [g!update (code;local-symbol (updateN interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_change (' _change) - g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - g!tear-down (nest g!ancestors - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) - g!build-up (nest g!ancestors - (` [(~ g!_behavior) ((~ g!_change) (~ g!_state)) (~ g!_extension)]))] - (` (def: (~@ (csw;export export)) - ((~ g!update) (~ g!_change) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] - (-> (-> (~ g!child) (~ g!child)) - (-> (~ g!object) (~ g!object)))) - (let [(~ g!tear-down) (~ g!_object)] - (~ g!build-up)))))) - -## [Macros] -(def: (type-to-code type) - (-> Type (Meta Code)) - (case type - (#;Primitive name params) - (do Monad - [paramsC+ (M;map @ type-to-code params)] - (wrap (` (;primitive (~ (code;symbol ["" name])) - (~@ paramsC+))))) - - #;Void - (Meta/wrap (` (;|))) - - #;Unit - (Meta/wrap (` (;&))) - - (^template [ ] - ( _) - (do Monad - [partsC+ (M;map @ type-to-code ( type))] - (wrap (` ( (~@ partsC+)))))) - ([#;Sum ;| type;flatten-variant] - [#;Product ;& type;flatten-tuple]) - - (#;Function input output) - (do Monad - [#let [[insT+ outT] (type;flatten-function type)] - insC+ (M;map @ type-to-code insT+) - outC (type-to-code outT)] - (wrap (` (;-> (~@ insC+) (~ outC))))) - - (^template [] - ( idx) - (Meta/wrap (` ( (~ (code;nat idx)))))) - ([#;Bound] - [#;Var] - [#;Ex]) - - (#;Apply param fun) - (do Monad - [#let [[funcT argsT+] (type;flatten-application type)] - funcC (type-to-code funcT) - argsC+ (M;map @ type-to-code argsT+)] - (wrap (` ((~ funcC) (~@ argsC+))))) - - (#;Named name unnamedT) - (Meta/wrap (code;symbol name)) - - _ - (meta;fail (format "Cannot convert type to code: " (type;to-text type))))) - -(syntax: #export (interface: [export csr;export] - [(^@ decl [interface parameters]) declarationS] - [?extends (p;maybe extension)] - [alias aliasS] - [annotations (p;default cs;empty-annotations csr;annotations)] - [methods (p;many (method (var-set parameters)))]) - (meta;with-gensyms [g!self-class g!child g!ext] - (do @ - [module meta;current-module-name - [parent ancestors mappings] (: (Meta [Ident (List Ident) (List Code)]) - (case ?extends - #;None - (wrap [no-parent (list) (list)]) - - (#;Some [super mappings]) - (do @ - [[parent ancestors] (interfaceN super)] - (wrap [parent (list& parent ancestors) mappings])))) - #let [g!signature (code;local-symbol (signatureN interface)) - g!interface (code;local-symbol interface) - g!parameters (L/map code;local-symbol parameters) - g!self-ref (if (list;empty? g!parameters) - (list g!interface) - (list)) - g!interface-def (if (no-parent? parent) - (let [g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~ g!child)))] - (` (Ex (~@ g!self-ref) [(~ g!ext) (~ g!child)] - [((~ g!signature) (~@ g!parameters) (~ g!recur)) - (~ g!child) - (~ g!ext)]))) - (let [g!parent (code;symbol parent) - g!ancestors (ancestor-inputs ancestors) - g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))] - (` (Ex (~@ g!self-ref) [(~ g!ext) (~@ g!ancestors) (~ g!child)] - ((~ g!parent) (~@ mappings) - [((~ g!signature) (~@ g!parameters) (~ g!recur)) - (~ g!child) - (~ g!ext)] - (~@ g!ancestors))))))]] - (wrap (list& (` (sig: (~@ (csw;export export)) - ((~ g!signature) (~@ g!parameters) (~ g!self-class)) - (~@ (let [de-alias (code;replace (code;local-symbol alias) g!self-class)] - (L/map (|>. (update@ #inputs (L/map de-alias)) - (update@ #output de-alias) - (declarationM g!self-class)) - methods))))) - - (` (type: (~@ (csw;export export)) ((~ g!interface) (~@ g!parameters)) - (~ (|> annotations - (with-interface parent [module interface]) - csw;annotations)) - (~ g!interface-def))) - - (getterN export interface g!parameters g!ext g!child ancestors) - (setterN export interface g!parameters g!ext g!child ancestors) - (updaterN export interface g!parameters g!ext g!child ancestors) - - (let [g!ancestors (ancestor-inputs ancestors) - g!states (L/compose g!ancestors (list g!child)) - g!self-object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - de-alias (code;replace (code;symbol ["" alias]) g!self-object)] - (L/map (|>. (update@ #inputs (L/map de-alias)) - (update@ #output de-alias) - (definition export decl g!self-object g!ext g!states)) - methods)))) - ))) - -(syntax: #export (class: [export csr;export] - [[instance parameters] declarationS] - [annotations (p;default cs;empty-annotations csr;annotations)] - [[interface interface-mappings] referenceS] - [super (p;maybe inheritance)] - state-type - [impls (p;many s;any)]) - (meta;with-gensyms [g!init g!extension] - (do @ - [module meta;current-module-name - [interface _] (interfaceN interface) - [parent ancestors parent-mappings] (: (Meta [Ident (List Ident) (List Code)]) - (case super - (#;Some [super-class super-mappings]) - (do @ - [[parent ancestors] (classN super-class)] - (wrap [parent ancestors super-mappings])) - - #;None - (wrap [no-parent (list) (list)]))) - g!inheritance (: (Meta (List Code)) - (if (no-parent? parent) - (wrap (list)) - (do @ - [newT (meta;find-def-type (product;both id newN parent)) - [depth rawT+] (extract newT) - codeT+ (M;map @ type-to-code rawT+)] - (wrap (L/map (specialize parent-mappings) codeT+))))) - #let [g!parameters (L/map code;local-symbol parameters) - - g!state (code;local-symbol (stateN instance)) - g!struct (code;local-symbol (structN instance)) - g!class (code;local-symbol instance) - - g!signature (code;symbol (product;both id signatureN interface)) - g!interface (code;symbol interface) - - g!parent-structs (if (no-parent? parent) - (list) - (L/map (|>. (product;both id structN) code;symbol) (list& parent ancestors)))] - g!parent-inits (M;map @ (function [_] (meta;gensym "parent-init")) - g!parent-structs) - #let [g!full-init (L/fold (function [[parent-struct parent-state] child] - (` [(~ parent-struct) (~ parent-state) (~ child)])) - (` [(~ g!struct) (~ g!init) []]) - (list;zip2 g!parent-structs g!parent-inits)) - g!new (code;local-symbol (newN instance)) - g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension))) - g!rec (if (list;empty? g!parameters) - (list (' #rec)) - (list))]] - (wrap (list (` (type: (~@ (csw;export export)) - ((~ g!state) (~@ g!parameters)) - (~ state-type))) - - (` (type: (~@ (csw;export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters)) - (~ (|> annotations - (with-class interface parent [module instance]) - csw;annotations)) - (Ex [(~ g!extension)] - (~ (if (no-parent? parent) - (` ((~ g!interface) (~@ interface-mappings) - (~ g!extension) - ((~ g!state) (~@ g!parameters)))) - (let [g!parent (code;symbol parent)] - (` ((~ g!parent) (~@ parent-mappings) - [((~ g!signature) (~@ interface-mappings) (~ g!recur)) - ((~ g!state) (~@ g!parameters)) - (~ g!extension)])))))))) - - (` (struct: (~@ (csw;export export)) (~ g!struct) - (All [(~@ g!parameters) (~ g!extension)] - ((~ g!signature) (~@ interface-mappings) - ((~ g!interface) (~@ interface-mappings) - (~ g!extension) - (~@ g!inheritance) - ((~ g!state) (~@ g!parameters))))) - (~@ impls))) - - (` (def: (~@ (csw;export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init)) - (All [(~@ g!parameters)] - (-> (~@ g!inheritance) - ((~ g!state) (~@ g!parameters)) - ((~ g!class) (~@ g!parameters)))) - (~ g!full-init))) - )) - ))) diff --git a/stdlib/source/lux/meta/type/opaque.lux b/stdlib/source/lux/meta/type/opaque.lux deleted file mode 100644 index acd73d6a4..000000000 --- a/stdlib/source/lux/meta/type/opaque.lux +++ /dev/null @@ -1,164 +0,0 @@ -(;module: - lux - (lux (control [applicative] - [monad #+ do Monad] - ["p" parser]) - (data [text "text/" Eq Monoid] - ["E" error] - (coll [list "list/" Functor Monoid])) - [meta] - (meta [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 Code (' {#;macro? true})) - -(def: representation-name - (-> Text Text) - (|>. ($_ text/compose "{" kind "@" module "}") - (let [[module kind] (ident-for #;;Representation)]))) - -(def: (install-casts' this-module-name name type-vars) - (-> Text Text (List Text) (Meta Unit)) - (do meta;Monad - [this-module (meta;find-module this-module-name) - #let [type-varsC (list/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))))) - - _ - (meta;fail ($_ text/compose "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))))) - - _ - (meta;fail ($_ text/compose "Wrong syntax for " up-cast))))]))))]] - (function [compiler] - (#E;Success [(update@ #;modules (put this-module-name this-module) compiler) - []])))) - -(def: (un-install-casts' this-module-name) - (-> Text (Meta Unit)) - (do meta;Monad - [this-module (meta;find-module this-module-name) - #let [this-module (|> this-module - (update@ #;defs (remove down-cast)) - (update@ #;defs (remove up-cast)))]] - (function [compiler] - (#E;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 meta;current-module-name - ?down-cast (meta;find-macro [this-module-name down-cast]) - ?up-cast (meta;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))) - - _ - (meta;fail ($_ text/compose - "Cannot temporarily define casting functions (" - down-cast " & " up-cast - ") because definitions like that already exist."))))) - -(syntax: #hidden (un-install-casts) - (do meta;Monad - [this-module-name meta;current-module-name - ?down-cast (meta;find-macro [this-module-name down-cast]) - ?up-cast (meta;find-macro [this-module-name up-cast])] - (case [?down-cast ?up-cast] - [(#;Some _) (#;Some _)] - (do @ - [_ (un-install-casts' this-module-name)] - (wrap (list))) - - _ - (meta;fail ($_ text/compose - "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 (list/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)) - (primitive (~ hidden-name) [(~@ type-varsC)]))) - (` (type: (~@ (csw;export export)) (~ representation-declaration) - (~ representation-type))) - (` (install-casts (~ (code;local-symbol name)) [(~@ type-varsC)])) - (list/compose primitives - (list (` (un-install-casts)))))))) diff --git a/stdlib/source/lux/meta/type/unit.lux b/stdlib/source/lux/meta/type/unit.lux deleted file mode 100644 index de00fb82d..000000000 --- a/stdlib/source/lux/meta/type/unit.lux +++ /dev/null @@ -1,183 +0,0 @@ -(;module: - lux - (lux (control [monad #+ do Monad] - ["p" parser "p/" Monad] - [eq #+ Eq] - [order #+ Order] - [enum #+ Enum]) - (data text/format - (number ["r" ratio])) - [meta] - (meta [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))))) - -(type: #export (Qty unit) - [Int unit]) - -(sig: #export (Scale s) - (: (All [u] (-> (Qty u) (Qty (s u)))) - scale) - (: (All [u] (-> (Qty (s u)) (Qty u))) - de-scale) - (: r;Ratio - ratio)) - -(type: #export Pure - (Qty [])) - -(type: #export (Per d n) - (-> d n)) - -(type: #export (Inverse u) - (|> Pure (Per u))) - -(type: #export (Product p s) - (|> s (Per (Inverse p)))) - -(def: #export (in carrier magnitude) - (All [unit] (-> unit Int (Qty unit))) - [magnitude carrier]) - -(def: #export (pure magnitude) - (-> Int Pure) - (in [] magnitude)) - -(def: #export (out quantity) - (All [unit] (-> (Qty unit) Int)) - (let [[magnitude carrier] quantity] - magnitude)) - -(def: (carrier quantity) - (All [unit] (-> (Qty unit) unit)) - (let [[magnitude carrier] quantity] - carrier)) - -(do-template [ ] - [(def: - (-> Text Text) - (|>. (format "{" kind "@" module "}") - (let [[module kind] (ident-for )])))] - - [unit-name #;;Unit] - [scale-name #;;Scale] - ) - -(syntax: #export (unit: [export csr;export] - [name s;local-symbol] - [annotations (p;default cs;empty-annotations csr;annotations)]) - (wrap (list (` (type: (~@ (csw;export export)) (~ (code;local-symbol name)) - (~ (csw;annotations annotations)) - (primitive (~ (code;local-symbol (unit-name name)))))) - (` (def: (~@ (csw;export export)) (~ (code;local-symbol (format "@" name))) - (~ (code;local-symbol name)) - (:!! []))) - ))) - -(def: ratio^ - (s;Syntax r;Ratio) - (s;tuple (do p;Monad - [numerator s;int - _ (p;assert (format "Numerator must be positive: " (%i numerator)) - (i.> 0 numerator)) - denominator s;int - _ (p;assert (format "Denominator must be positive: " (%i denominator)) - (i.> 0 denominator))] - (wrap [(int-to-nat numerator) (int-to-nat denominator)])))) - -(syntax: #export (scale: [export csr;export] - [name s;local-symbol] - [(^slots [#r;numerator #r;denominator]) ratio^] - [annotations (p;default cs;empty-annotations csr;annotations)]) - (let [g!scale (code;local-symbol name)] - (wrap (list (` (type: (~@ (csw;export export)) ((~ g!scale) (~' u)) - (~ (csw;annotations annotations)) - (primitive (~ (code;local-symbol (scale-name name))) [(~' u)]))) - (` (struct: (~@ (csw;export export)) (~ (code;local-symbol (format "@" name))) - (;;Scale (~ g!scale)) - (def: (~' scale) - (|>. ;;out - (i.* (~ (code;int (nat-to-int numerator)))) - (i./ (~ (code;int (nat-to-int denominator)))) - (;;in (:! ((~ g!scale) ($ +0)) [])))) - (def: (~' de-scale) - (|>. ;;out - (i.* (~ (code;int (nat-to-int denominator)))) - (i./ (~ (code;int (nat-to-int numerator)))) - (;;in (:! ($ +0) [])))) - (def: (~' ratio) - [(~ (code;nat numerator)) (~ (code;nat denominator))]))) - )))) - -(do-template [ ] - [(def: #export ( param subject) - (All [unit] (-> (Qty unit) (Qty unit) (Qty unit))) - (|> (out subject) ( (out param)) (in (carrier subject))))] - - [++ i.+] - [-- i.-] - ) - -(def: #export (// param subject) - (All [p s] (-> (Qty p) (Qty s) (|> (Qty s) (Per (Qty p))))) - (function [input] - (|> (out subject) - (i.* (out input)) - (i./ (out param)) - (in (carrier subject))))) - -(def: #export (** param subject) - (All [p s] (-> (Qty p) (Qty s) (Product (Qty p) (Qty s)))) - (function [input] - (|> (out subject) - (i.* (out (input param))) - (in (carrier subject))))) - -(def: #export (re-scale from to quantity) - (All [si so u] (-> (Scale si) (Scale so) (Qty (si u)) (Qty (so u)))) - (let [[numerator denominator] (|> (:: to ratio) (r;q./ (:: from ratio)))] - (|> quantity out - (i.* (nat-to-int numerator)) - (i./ (nat-to-int denominator)) - (in (:! (($ +1) ($ +2)) []))))) - -(scale: #export Kilo [1 1_000]) -(scale: #export Mega [1 1_000_000]) -(scale: #export Giga [1 1_000_000_000]) - -(scale: #export Milli [ 1_000 1]) -(scale: #export Micro [ 1_000_000 1]) -(scale: #export Nano [1_000_000_000 1]) - -(def: #export (as scale unit magnitude) - (All [s u] (-> (Scale s) u Int (Qty (s u)))) - (let [[_ carrier] (|> 0 (in unit) (:: scale scale))] - [magnitude carrier])) - -(unit: #export Gram) -(unit: #export Meter) -(unit: #export Litre) -(unit: #export Second) - -(struct: #export Eq (All [unit] (Eq (Qty unit))) - (def: (= reference sample) - (i.= (out reference) (out sample)))) - -(struct: #export Order (All [unit] (Order (Qty unit))) - (def: eq Eq) - - (do-template [ ] - [(def: ( reference sample) - ( (out reference) (out sample)))] - - [< i.<] - [<= i.<=] - [> i.>] - [>= i.>=])) - -(struct: #export Enum (All [unit] (Enum (Qty unit))) - (def: order Order) - (def: (succ qty) (|> (out qty) i.inc (in (carrier qty)))) - (def: (pred qty) (|> (out qty) i.dec (in (carrier qty))))) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 3f2dc7255..5b124a669 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -6,7 +6,7 @@ codec ["p" parser] [monad #+ do]) - (data ["E" error] + (data ["e" error] [maybe] [number "int/" Codec] [text "text/" Monoid] @@ -311,7 +311,7 @@ #day (int-to-nat utc-day)}))) (def: (decode input) - (-> Text (E;Error Date)) + (-> Text (e;Error Date)) (l;run input lex-date)) (struct: #export _ diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux index e063a30ce..283b48c91 100644 --- a/stdlib/source/lux/time/duration.lux +++ b/stdlib/source/lux/time/duration.lux @@ -8,8 +8,8 @@ (data [number "int/" Codec Number] [text "text/" Monoid] (text ["l" lexer]) - ["E" error]) - (meta (type opaque)))) + ["e" error]) + (type opaque))) (opaque: #export Duration {#;doc "Durations have a resolution of milliseconds."} @@ -134,7 +134,7 @@ (merge (scale (sign utc-millis) milli)))))) (def: (decode input) - (-> Text (E;Error Duration)) + (-> Text (e;Error Duration)) (l;run input lex-duration)) (struct: #export _ diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index a9d10fd4f..2d4c1c58b 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -10,11 +10,11 @@ (data [text "text/" Monoid] (text ["l" lexer]) [number "int/" Codec] - ["E" error] + ["e" error] [maybe] (coll [list "L/" Fold Functor] [sequence #+ Sequence sequence "sequence/" Functor Fold])) - (meta (type opaque))) + (type opaque)) (.. [duration "duration/" Order] [date])) @@ -296,7 +296,7 @@ (shift (duration;scale utc-millis duration;milli)))))) (def: (decode input) - (-> Text (E;Error Instant)) + (-> Text (e;Error Instant)) (l;run input lex-instant)) (struct: #export _ diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux new file mode 100644 index 000000000..54fec2626 --- /dev/null +++ b/stdlib/source/lux/type/implicit.lux @@ -0,0 +1,363 @@ +(;module: + lux + (lux (control ["M" monad #+ do Monad] + [eq] + ["p" parser]) + (data [text "Text/" Eq] + text/format + [number] + (coll [list "List/" Monad Fold] + [dict]) + [bool] + [product] + [maybe]) + [meta #+ Monad] + (meta [code] + ["s" syntax #+ syntax: Syntax]) + (lang [type] + (type ["tc" check #+ Check Monad])) + )) + +(def: (find-type-var id env) + (-> Nat Type-Context (Meta Type)) + (case (list;find (|>. product;left (n.= id)) + (get@ #;var-bindings env)) + (#;Some [_ (#;Some type)]) + (case type + (#;Var id') + (find-type-var id' env) + + _ + (:: Monad wrap type)) + + (#;Some [_ #;None]) + (meta;fail (format "Unbound type-var " (%n id))) + + #;None + (meta;fail (format "Unknown type-var " (%n id))) + )) + +(def: (resolve-type var-name) + (-> Ident (Meta Type)) + (do Monad + [raw-type (meta;find-type var-name) + compiler meta;get-compiler] + (case raw-type + (#;Var id) + (find-type-var id (get@ #;type-context compiler)) + + _ + (wrap raw-type)))) + +(def: (find-member-type idx sig-type) + (-> Nat Type (Check Type)) + (case sig-type + (#;Named _ sig-type') + (find-member-type idx sig-type') + + (#;Apply arg func) + (case (type;apply (list arg) func) + #;None + (tc;fail (format "Cannot apply type " (%type func) " to type " (%type arg))) + + (#;Some sig-type') + (find-member-type idx sig-type')) + + (#;Product left right) + (if (n.= +0 idx) + (:: Monad wrap left) + (find-member-type (n.dec idx) right)) + + _ + (if (n.= +0 idx) + (:: Monad wrap sig-type) + (tc;fail (format "Cannot find member type " (%n idx) " for " (%type sig-type)))))) + +(def: (find-member-name member) + (-> Ident (Meta Ident)) + (case member + ["" simple-name] + (meta;either (do Monad + [member (meta;normalize member) + _ (meta;resolve-tag member)] + (wrap member)) + (do Monad + [this-module-name meta;current-module-name + imp-mods (meta;imported-modules this-module-name) + tag-lists (M;map @ meta;tag-lists imp-mods) + #let [tag-lists (|> tag-lists List/join (List/map product;left) List/join) + candidates (list;filter (. (Text/= simple-name) product;right) + tag-lists)]] + (case candidates + #;Nil + (meta;fail (format "Unknown tag: " (%ident member))) + + (#;Cons winner #;Nil) + (wrap winner) + + _ + (meta;fail (format "Too many candidate tags: " (%list %ident candidates)))))) + + _ + (:: Monad wrap member))) + +(def: (resolve-member member) + (-> Ident (Meta [Nat Type])) + (do Monad + [member (find-member-name member) + [idx tag-list sig-type] (meta;resolve-tag member)] + (wrap [idx sig-type]))) + +(def: (prepare-defs this-module-name defs) + (-> Text (List [Text Def]) (List [Ident Type])) + (|> defs + (list;filter (function [[name [def-type def-anns def-value]]] + (meta;struct? def-anns))) + (List/map (function [[name [def-type def-anns def-value]]] + [[this-module-name name] def-type])))) + +(def: local-env + (Meta (List [Ident Type])) + (do Monad + [local-batches meta;locals + #let [total-locals (List/fold (function [[name type] table] + (dict;put~ name type table)) + (: (dict;Dict Text Type) + (dict;new text;Hash)) + (List/join local-batches))]] + (wrap (|> total-locals + dict;entries + (List/map (function [[name type]] [["" name] type])))))) + +(def: local-structs + (Meta (List [Ident Type])) + (do Monad + [this-module-name meta;current-module-name + defs (meta;defs this-module-name)] + (wrap (prepare-defs this-module-name defs)))) + +(def: import-structs + (Meta (List [Ident Type])) + (do Monad + [this-module-name meta;current-module-name + imp-mods (meta;imported-modules this-module-name) + export-batches (M;map @ (function [imp-mod] + (do @ + [exports (meta;exports imp-mod)] + (wrap (prepare-defs imp-mod exports)))) + imp-mods)] + (wrap (List/join export-batches)))) + +(def: (apply-function-type func arg) + (-> Type Type (Check Type)) + (case func + (#;Named _ func') + (apply-function-type func' arg) + + (#;UnivQ _) + (do Monad + [[id var] tc;var] + (apply-function-type (maybe;assume (type;apply (list var) func)) + arg)) + + (#;Function input output) + (do Monad + [_ (tc;check input arg)] + (wrap output)) + + _ + (tc;fail (format "Invalid function type: " (%type func))))) + +(def: (concrete-type type) + (-> Type (Check [(List Nat) Type])) + (case type + (#;UnivQ _) + (do Monad + [[id var] tc;var + [ids final-output] (concrete-type (maybe;assume (type;apply (list var) type)))] + (wrap [(#;Cons id ids) + final-output])) + + _ + (:: Monad wrap [(list) type]))) + +(def: (check-apply member-type input-types output-type) + (-> Type (List Type) Type (Check [])) + (do Monad + [member-type' (M;fold Monad + (function [input member] + (apply-function-type member input)) + member-type + input-types)] + (tc;check output-type member-type'))) + +(type: #rec Instance + {#constructor Ident + #dependencies (List Instance)}) + +(def: (test-provision provision context dep alts) + (-> (-> Compiler Type-Context Type (Check Instance)) + Type-Context Type (List [Ident Type]) + (Meta (List Instance))) + (do Monad + [compiler meta;get-compiler] + (case (|> alts + (List/map (function [[alt-name alt-type]] + (case (tc;run context + (do Monad + [[tvars alt-type] (concrete-type alt-type) + #let [[deps alt-type] (type;flatten-function alt-type)] + _ (tc;check dep alt-type) + context' tc;get-context + =deps (M;map @ (provision compiler context') deps)] + (wrap =deps))) + (#;Left error) + (list) + + (#;Right =deps) + (list [alt-name =deps])))) + List/join) + #;Nil + (meta;fail (format "No candidates for provisioning: " (%type dep))) + + found + (wrap found)))) + +(def: (provision compiler context dep) + (-> Compiler Type-Context Type (Check Instance)) + (case (meta;run compiler + ($_ meta;either + (do Monad [alts local-env] (test-provision provision context dep alts)) + (do Monad [alts local-structs] (test-provision provision context dep alts)) + (do Monad [alts import-structs] (test-provision provision context dep alts)))) + (#;Left error) + (tc;fail error) + + (#;Right candidates) + (case candidates + #;Nil + (tc;fail (format "No candidates for provisioning: " (%type dep))) + + (#;Cons winner #;Nil) + (:: Monad wrap winner) + + _ + (tc;fail (format "Too many candidates for provisioning: " (%type dep) " --- " (%list (. %ident product;left) candidates)))) + )) + +(def: (test-alternatives sig-type member-idx input-types output-type alts) + (-> Type Nat (List Type) Type (List [Ident Type]) (Meta (List Instance))) + (do Monad + [compiler meta;get-compiler + context meta;type-context] + (case (|> alts + (List/map (function [[alt-name alt-type]] + (case (tc;run context + (do Monad + [[tvars alt-type] (concrete-type alt-type) + #let [[deps alt-type] (type;flatten-function alt-type)] + _ (tc;check alt-type sig-type) + member-type (find-member-type member-idx alt-type) + _ (check-apply member-type input-types output-type) + context' tc;get-context + =deps (M;map @ (provision compiler context') deps)] + (wrap =deps))) + (#;Left error) + (list) + + (#;Right =deps) + (list [alt-name =deps])))) + List/join) + #;Nil + (meta;fail (format "No alternatives for " (%type (type;function input-types output-type)))) + + found + (wrap found)))) + +(def: (find-alternatives sig-type member-idx input-types output-type) + (-> Type Nat (List Type) Type (Meta (List Instance))) + (let [test (test-alternatives sig-type member-idx input-types output-type)] + ($_ meta;either + (do Monad [alts local-env] (test alts)) + (do Monad [alts local-structs] (test alts)) + (do Monad [alts import-structs] (test alts))))) + +(def: (var? input) + (-> Code Bool) + (case input + [_ (#;Symbol _)] + true + + _ + false)) + +(def: (join-pair [l r]) + (All [a] (-> [a a] (List a))) + (list l r)) + +(def: (instance$ [constructor dependencies]) + (-> Instance Code) + (case dependencies + #;Nil + (code;symbol constructor) + + _ + (` ((~ (code;symbol constructor)) (~@ (List/map instance$ dependencies)))))) + +(syntax: #export (::: [member s;symbol] + [args (p;alt (p;seq (p;some s;symbol) s;end!) + (p;seq (p;some s;any) s;end!))]) + {#;doc (doc "Automatic structure selection (for type-class style polymorphism)." + "This feature layers type-class style polymorphism on top of Lux's signatures and structures." + "When calling a polymorphic function, or using a polymorphic constant," + "this macro will check the types of the arguments, and the expected type for the whole expression" + "and it will search in the local scope, the module's scope and the imports' scope" + "in order to find suitable structures to satisfy those requirements." + "If a single alternative is found, that one will be used automatically." + "If no alternative is found, or if more than one alternative is found (ambiguity)" + "a compile-time error will be raised, to alert the user." + "Examples:" + "Nat equality" + (:: number;Eq = x y) + (::: = x y) + "Can optionally add the prefix of the module where the signature was defined." + (::: eq;= x y) + "(List Nat) equality" + (::: = + (list;n.range +1 +10) + (list;n.range +1 +10)) + "(Functor List) map" + (::: map n.inc (list;n.range +0 +9)) + "Caveat emptor: You need to make sure to import the module of any structure you want to use." + "Otherwise, this macro will not find it.")} + (case args + (#;Left [args _]) + (do @ + [[member-idx sig-type] (resolve-member member) + input-types (M;map @ resolve-type args) + output-type meta;expected-type + chosen-ones (find-alternatives sig-type member-idx input-types output-type)] + (case chosen-ones + #;Nil + (meta;fail (format "No structure option could be found for member: " (%ident member))) + + (#;Cons chosen #;Nil) + (wrap (list (` (:: (~ (instance$ chosen)) + (~ (code;local-symbol (product;right member))) + (~@ (List/map code;symbol args)))))) + + _ + (meta;fail (format "Too many options available: " + (|> chosen-ones + (List/map (. %ident product;left)) + (text;join-with ", ")) + " --- for type: " (%type sig-type))))) + + (#;Right [args _]) + (do @ + [labels (M;seq @ (list;repeat (list;size args) + (meta;gensym ""))) + #let [retry (` (let [(~@ (|> (list;zip2 labels args) (List/map join-pair) List/join))] + (;;::: (~ (code;symbol member)) (~@ labels))))]] + (wrap (list retry))) + )) diff --git a/stdlib/source/lux/type/object.lux b/stdlib/source/lux/type/object.lux new file mode 100644 index 000000000..0eb354242 --- /dev/null +++ b/stdlib/source/lux/type/object.lux @@ -0,0 +1,515 @@ +(;module: + lux + (lux (control ["M" monad #+ do Monad] + ["p" parser "p/" Monad]) + (data [text] + text/format + [product] + [maybe] + [ident #+ "Ident/" Eq] + (coll [list "L/" Functor Fold Monoid] + [set #+ Set])) + [meta #+ Monad "Meta/" Monad] + (meta [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) + (lang [type]))) + +## [Common] +(type: Declaration + [Text (List Text)]) + +(type: Alias Text) + +(def: default-alias Alias "@") + +(def: (var-set vars) + (-> (List Text) (Set Text)) + (set;from-list text;Hash vars)) + +(def: (unique-type-vars parser) + (-> (s;Syntax (List Text)) (s;Syntax (List Text))) + (do p;Monad + [raw parser + _ (p;assert "Cannot repeat the names of type variables/parameters." + (n.= (set;size (var-set raw)) + (list;size raw)))] + (wrap raw))) + +(def: (safe-type-vars exclusions) + (-> (Set Text) (s;Syntax Text)) + (do p;Monad + [raw s;local-symbol + _ (p;assert "Cannot re-use names between method type-variables and interface type-parameters." + (|> raw (set;member? exclusions) not))] + (wrap raw))) + +(def: declarationS + (s;Syntax Declaration) + (p;either (s;form (p;seq s;local-symbol + (unique-type-vars (p;some s;local-symbol)))) + (p;seq s;local-symbol + (p/wrap (list))))) + +(def: aliasS + (s;Syntax Alias) + (|> s;local-symbol + (p;after (s;this (' #as))) + (p;default default-alias))) + +(def: (ancestor-inputs ancestors) + (-> (List Ident) (List Code)) + (if (list;empty? ancestors) + (list) + (|> (list;size ancestors) + n.dec + (list;n.range +0) + (L/map (|>. %n (format "ancestor") code;local-symbol))))) + +## [Methods] +(type: Method + {#type-vars (List Text) + #name Text + #inputs (List Code) + #output Code}) + +(def: (method exclusions) + (-> (Set Text) (s;Syntax Method)) + (s;form ($_ p;seq + (p;either (unique-type-vars (s;tuple (p;some (safe-type-vars exclusions)))) + (p/wrap (list))) + s;local-symbol + (s;tuple (p;some s;any)) + s;any))) + +(def: (declarationM g!self (^open)) + (-> Code Method Code) + (let [g!type-vars (L/map code;local-symbol type-vars) + g!method (code;local-symbol name)] + (` (: (All [(~@ g!type-vars)] + (-> (~@ inputs) (~ g!self) (~ output))) + (~ g!method))))) + +(def: (definition export [interface parameters] g!self-object g!ext g!states (^open)) + (-> (Maybe cs;Export) Declaration Code Code (List Code) Method Code) + (let [g!method (code;local-symbol name) + g!parameters (L/map code;local-symbol parameters) + g!type-vars (L/map code;local-symbol type-vars) + g!_temp (code;symbol ["" "_temp"]) + g!_object (code;symbol ["" "_object"]) + g!_behavior (code;symbol ["" "_behavior"]) + g!_state (code;symbol ["" "_state"]) + g!_extension (code;symbol ["" "_extension"]) + g!_args (L/map (|>. product;left nat-to-int %i (format "_") code;local-symbol) + (list;enumerate inputs)) + g!destructuring (L/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) + (maybe;default g!states (list;tail g!states)))] + (` (def: (~@ (csw;export export)) ((~ g!method) (~@ g!_args) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!states) (~@ g!type-vars)] + (-> (~@ inputs) (~ g!self-object) (~ output))) + (let [(~ g!destructuring) (~ g!_object)] + (:: (~ g!_behavior) (~ g!method) (~@ g!_args) (~ g!_object))))))) + +## [Inheritance] +(type: Reference + [Ident (List Code)]) + +(def: no-parent Ident ["" ""]) + +(def: (no-parent? parent) + (-> Ident Bool) + (Ident/= no-parent parent)) + +(def: (with-interface parent interface) + (-> Ident Ident cs;Annotations cs;Annotations) + (|>. (#;Cons [(ident-for #;;interface-name) + (code;tag interface)]) + (#;Cons [(ident-for #;;interface-parent) + (code;tag parent)]))) + +(def: (with-class interface parent class) + (-> Ident Ident Ident cs;Annotations cs;Annotations) + (|>. (#;Cons [(ident-for #;;class-interface) + (code;tag interface)]) + (#;Cons [(ident-for #;;class-parent) + (code;tag parent)]) + (#;Cons [(ident-for #;;class-name) + (code;tag class)]))) + +(do-template [ ] + [(def: ( name) + (-> Ident (Meta [Ident (List Ident)])) + (do Monad + [name (meta;normalize name) + [_ annotations _] (meta;find-def name)] + (case [(meta;get-tag-ann (ident-for ) annotations) + (meta;get-tag-ann (ident-for ) annotations)] + [(#;Some real-name) (#;Some parent)] + (if (Ident/= no-parent parent) + (wrap [real-name (list)]) + (do @ + [[_ ancestors] ( parent)] + (wrap [real-name (#;Cons parent ancestors)]))) + + _ + (meta;fail (format "Wrong format for " " lineage.")))))] + + [interfaceN #;;interface-name #;;interface-parent "interface"] + [classN #;;class-name #;;class-parent "class"] + ) + +(def: (extract newT) + (-> Type (Meta [Nat (List Type)])) + (loop [depth +0 + currentT newT] + (case currentT + (#;UnivQ _ bodyT) + (recur (n.inc depth) bodyT) + + (#;Function inputT outputT) + (let [[stateT+ objectT] (type;flatten-function currentT)] + (Meta/wrap [depth stateT+])) + + _ + (meta;fail (format "Cannot extract inheritance from type: " (type;to-text newT)))))) + +(def: (specialize mappings typeC) + (-> (List Code) Code Code) + (case (list;size mappings) + +0 + typeC + + size + (|> (n.dec size) + (list;n.range +0) + (L/map (|>. (n.* +2) n.inc code;nat (~) #;Bound (`))) + (list;zip2 (list;reverse mappings)) + (L/fold (function [[mappingC boundC] genericC] + (code;replace boundC mappingC genericC)) + typeC)))) + +(def: referenceS + (s;Syntax Reference) + (p;either (s;form (p;seq s;symbol + (p;some s;any))) + (p;seq s;symbol + (p/wrap (list))))) + +(do-template [ ] + [(def: + (s;Syntax Reference) + (|> referenceS + (p;after (s;this (' )))))] + + [extension #super] + [inheritance #super] + ) + +## [Notation] +## Utils +(def: (nest ancestors bottom) + (-> (List Code) Code Code) + (L/fold (function [[level _] g!bottom] + (let [g!_behavior' (code;local-symbol (format "_behavior" (%n level))) + g!_state' (code;local-symbol (format "_state" (%n level)))] + (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)]))) + bottom + (list;enumerate ancestors))) + +## Names +(do-template [ ] + [(def: ( base) + (-> Text Text) + (|> base (format "@")))] + + [newN "new"] + [getN "get"] + [setN "set"] + [updateN "update"] + ) + +(do-template [ ] + [(def: ( raw) + (-> Text Text) + (let [[module kind] (ident-for )] + (format "{" kind "@" module "}" raw)))] + + [signatureN #;;Signature] + [stateN #;;State] + [structN #;;Struct] + ) + +(def: (getterN export interface g!parameters g!ext g!child ancestors) + (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) + Code) + (let [g!get (code;local-symbol (getN interface)) + g!interface (code;local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!ancestors (ancestor-inputs ancestors) + g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!tear-down (nest g!ancestors + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))] + (` (def: (~@ (csw;export export)) ((~ g!get) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (-> (~ g!object) (~ g!child))) + (let [(~ g!tear-down) (~ g!_object)] + (~ g!_state)))))) + +(def: (setterN export interface g!parameters g!ext g!child ancestors) + (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) + Code) + (let [g!set (code;local-symbol (setN interface)) + g!interface (code;local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!_input (' _input) + g!ancestors (ancestor-inputs ancestors) + g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!tear-down (nest g!ancestors + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) + g!build-up (nest g!ancestors + (` [(~ g!_behavior) (~ g!_input) (~ g!_extension)]))] + (` (def: (~@ (csw;export export)) + ((~ g!set) (~ g!_input) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (-> (~ g!child) (~ g!object) (~ g!object))) + (let [(~ g!tear-down) (~ g!_object)] + (~ g!build-up)))))) + +(def: (updaterN export interface g!parameters g!ext g!child ancestors) + (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) + Code) + (let [g!update (code;local-symbol (updateN interface)) + g!interface (code;local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!_change (' _change) + g!ancestors (ancestor-inputs ancestors) + g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!tear-down (nest g!ancestors + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) + g!build-up (nest g!ancestors + (` [(~ g!_behavior) ((~ g!_change) (~ g!_state)) (~ g!_extension)]))] + (` (def: (~@ (csw;export export)) + ((~ g!update) (~ g!_change) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (-> (-> (~ g!child) (~ g!child)) + (-> (~ g!object) (~ g!object)))) + (let [(~ g!tear-down) (~ g!_object)] + (~ g!build-up)))))) + +## [Macros] +(def: (type-to-code type) + (-> Type (Meta Code)) + (case type + (#;Primitive name params) + (do Monad + [paramsC+ (M;map @ type-to-code params)] + (wrap (` (;primitive (~ (code;symbol ["" name])) + (~@ paramsC+))))) + + #;Void + (Meta/wrap (` (;|))) + + #;Unit + (Meta/wrap (` (;&))) + + (^template [ ] + ( _) + (do Monad + [partsC+ (M;map @ type-to-code ( type))] + (wrap (` ( (~@ partsC+)))))) + ([#;Sum ;| type;flatten-variant] + [#;Product ;& type;flatten-tuple]) + + (#;Function input output) + (do Monad + [#let [[insT+ outT] (type;flatten-function type)] + insC+ (M;map @ type-to-code insT+) + outC (type-to-code outT)] + (wrap (` (;-> (~@ insC+) (~ outC))))) + + (^template [] + ( idx) + (Meta/wrap (` ( (~ (code;nat idx)))))) + ([#;Bound] + [#;Var] + [#;Ex]) + + (#;Apply param fun) + (do Monad + [#let [[funcT argsT+] (type;flatten-application type)] + funcC (type-to-code funcT) + argsC+ (M;map @ type-to-code argsT+)] + (wrap (` ((~ funcC) (~@ argsC+))))) + + (#;Named name unnamedT) + (Meta/wrap (code;symbol name)) + + _ + (meta;fail (format "Cannot convert type to code: " (type;to-text type))))) + +(syntax: #export (interface: [export csr;export] + [(^@ decl [interface parameters]) declarationS] + [?extends (p;maybe extension)] + [alias aliasS] + [annotations (p;default cs;empty-annotations csr;annotations)] + [methods (p;many (method (var-set parameters)))]) + (meta;with-gensyms [g!self-class g!child g!ext] + (do @ + [module meta;current-module-name + [parent ancestors mappings] (: (Meta [Ident (List Ident) (List Code)]) + (case ?extends + #;None + (wrap [no-parent (list) (list)]) + + (#;Some [super mappings]) + (do @ + [[parent ancestors] (interfaceN super)] + (wrap [parent (list& parent ancestors) mappings])))) + #let [g!signature (code;local-symbol (signatureN interface)) + g!interface (code;local-symbol interface) + g!parameters (L/map code;local-symbol parameters) + g!self-ref (if (list;empty? g!parameters) + (list g!interface) + (list)) + g!interface-def (if (no-parent? parent) + (let [g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~ g!child)))] + (` (Ex (~@ g!self-ref) [(~ g!ext) (~ g!child)] + [((~ g!signature) (~@ g!parameters) (~ g!recur)) + (~ g!child) + (~ g!ext)]))) + (let [g!parent (code;symbol parent) + g!ancestors (ancestor-inputs ancestors) + g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))] + (` (Ex (~@ g!self-ref) [(~ g!ext) (~@ g!ancestors) (~ g!child)] + ((~ g!parent) (~@ mappings) + [((~ g!signature) (~@ g!parameters) (~ g!recur)) + (~ g!child) + (~ g!ext)] + (~@ g!ancestors))))))]] + (wrap (list& (` (sig: (~@ (csw;export export)) + ((~ g!signature) (~@ g!parameters) (~ g!self-class)) + (~@ (let [de-alias (code;replace (code;local-symbol alias) g!self-class)] + (L/map (|>. (update@ #inputs (L/map de-alias)) + (update@ #output de-alias) + (declarationM g!self-class)) + methods))))) + + (` (type: (~@ (csw;export export)) ((~ g!interface) (~@ g!parameters)) + (~ (|> annotations + (with-interface parent [module interface]) + csw;annotations)) + (~ g!interface-def))) + + (getterN export interface g!parameters g!ext g!child ancestors) + (setterN export interface g!parameters g!ext g!child ancestors) + (updaterN export interface g!parameters g!ext g!child ancestors) + + (let [g!ancestors (ancestor-inputs ancestors) + g!states (L/compose g!ancestors (list g!child)) + g!self-object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + de-alias (code;replace (code;symbol ["" alias]) g!self-object)] + (L/map (|>. (update@ #inputs (L/map de-alias)) + (update@ #output de-alias) + (definition export decl g!self-object g!ext g!states)) + methods)))) + ))) + +(syntax: #export (class: [export csr;export] + [[instance parameters] declarationS] + [annotations (p;default cs;empty-annotations csr;annotations)] + [[interface interface-mappings] referenceS] + [super (p;maybe inheritance)] + state-type + [impls (p;many s;any)]) + (meta;with-gensyms [g!init g!extension] + (do @ + [module meta;current-module-name + [interface _] (interfaceN interface) + [parent ancestors parent-mappings] (: (Meta [Ident (List Ident) (List Code)]) + (case super + (#;Some [super-class super-mappings]) + (do @ + [[parent ancestors] (classN super-class)] + (wrap [parent ancestors super-mappings])) + + #;None + (wrap [no-parent (list) (list)]))) + g!inheritance (: (Meta (List Code)) + (if (no-parent? parent) + (wrap (list)) + (do @ + [newT (meta;find-def-type (product;both id newN parent)) + [depth rawT+] (extract newT) + codeT+ (M;map @ type-to-code rawT+)] + (wrap (L/map (specialize parent-mappings) codeT+))))) + #let [g!parameters (L/map code;local-symbol parameters) + + g!state (code;local-symbol (stateN instance)) + g!struct (code;local-symbol (structN instance)) + g!class (code;local-symbol instance) + + g!signature (code;symbol (product;both id signatureN interface)) + g!interface (code;symbol interface) + + g!parent-structs (if (no-parent? parent) + (list) + (L/map (|>. (product;both id structN) code;symbol) (list& parent ancestors)))] + g!parent-inits (M;map @ (function [_] (meta;gensym "parent-init")) + g!parent-structs) + #let [g!full-init (L/fold (function [[parent-struct parent-state] child] + (` [(~ parent-struct) (~ parent-state) (~ child)])) + (` [(~ g!struct) (~ g!init) []]) + (list;zip2 g!parent-structs g!parent-inits)) + g!new (code;local-symbol (newN instance)) + g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension))) + g!rec (if (list;empty? g!parameters) + (list (' #rec)) + (list))]] + (wrap (list (` (type: (~@ (csw;export export)) + ((~ g!state) (~@ g!parameters)) + (~ state-type))) + + (` (type: (~@ (csw;export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters)) + (~ (|> annotations + (with-class interface parent [module instance]) + csw;annotations)) + (Ex [(~ g!extension)] + (~ (if (no-parent? parent) + (` ((~ g!interface) (~@ interface-mappings) + (~ g!extension) + ((~ g!state) (~@ g!parameters)))) + (let [g!parent (code;symbol parent)] + (` ((~ g!parent) (~@ parent-mappings) + [((~ g!signature) (~@ interface-mappings) (~ g!recur)) + ((~ g!state) (~@ g!parameters)) + (~ g!extension)])))))))) + + (` (struct: (~@ (csw;export export)) (~ g!struct) + (All [(~@ g!parameters) (~ g!extension)] + ((~ g!signature) (~@ interface-mappings) + ((~ g!interface) (~@ interface-mappings) + (~ g!extension) + (~@ g!inheritance) + ((~ g!state) (~@ g!parameters))))) + (~@ impls))) + + (` (def: (~@ (csw;export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init)) + (All [(~@ g!parameters)] + (-> (~@ g!inheritance) + ((~ g!state) (~@ g!parameters)) + ((~ g!class) (~@ g!parameters)))) + (~ g!full-init))) + )) + ))) diff --git a/stdlib/source/lux/type/opaque.lux b/stdlib/source/lux/type/opaque.lux new file mode 100644 index 000000000..acd73d6a4 --- /dev/null +++ b/stdlib/source/lux/type/opaque.lux @@ -0,0 +1,164 @@ +(;module: + lux + (lux (control [applicative] + [monad #+ do Monad] + ["p" parser]) + (data [text "text/" Eq Monoid] + ["E" error] + (coll [list "list/" Functor Monoid])) + [meta] + (meta [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 Code (' {#;macro? true})) + +(def: representation-name + (-> Text Text) + (|>. ($_ text/compose "{" kind "@" module "}") + (let [[module kind] (ident-for #;;Representation)]))) + +(def: (install-casts' this-module-name name type-vars) + (-> Text Text (List Text) (Meta Unit)) + (do meta;Monad + [this-module (meta;find-module this-module-name) + #let [type-varsC (list/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))))) + + _ + (meta;fail ($_ text/compose "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))))) + + _ + (meta;fail ($_ text/compose "Wrong syntax for " up-cast))))]))))]] + (function [compiler] + (#E;Success [(update@ #;modules (put this-module-name this-module) compiler) + []])))) + +(def: (un-install-casts' this-module-name) + (-> Text (Meta Unit)) + (do meta;Monad + [this-module (meta;find-module this-module-name) + #let [this-module (|> this-module + (update@ #;defs (remove down-cast)) + (update@ #;defs (remove up-cast)))]] + (function [compiler] + (#E;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 meta;current-module-name + ?down-cast (meta;find-macro [this-module-name down-cast]) + ?up-cast (meta;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))) + + _ + (meta;fail ($_ text/compose + "Cannot temporarily define casting functions (" + down-cast " & " up-cast + ") because definitions like that already exist."))))) + +(syntax: #hidden (un-install-casts) + (do meta;Monad + [this-module-name meta;current-module-name + ?down-cast (meta;find-macro [this-module-name down-cast]) + ?up-cast (meta;find-macro [this-module-name up-cast])] + (case [?down-cast ?up-cast] + [(#;Some _) (#;Some _)] + (do @ + [_ (un-install-casts' this-module-name)] + (wrap (list))) + + _ + (meta;fail ($_ text/compose + "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 (list/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)) + (primitive (~ hidden-name) [(~@ type-varsC)]))) + (` (type: (~@ (csw;export export)) (~ representation-declaration) + (~ representation-type))) + (` (install-casts (~ (code;local-symbol name)) [(~@ type-varsC)])) + (list/compose primitives + (list (` (un-install-casts)))))))) diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux new file mode 100644 index 000000000..de00fb82d --- /dev/null +++ b/stdlib/source/lux/type/unit.lux @@ -0,0 +1,183 @@ +(;module: + lux + (lux (control [monad #+ do Monad] + ["p" parser "p/" Monad] + [eq #+ Eq] + [order #+ Order] + [enum #+ Enum]) + (data text/format + (number ["r" ratio])) + [meta] + (meta [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) + +(type: #export (Qty unit) + [Int unit]) + +(sig: #export (Scale s) + (: (All [u] (-> (Qty u) (Qty (s u)))) + scale) + (: (All [u] (-> (Qty (s u)) (Qty u))) + de-scale) + (: r;Ratio + ratio)) + +(type: #export Pure + (Qty [])) + +(type: #export (Per d n) + (-> d n)) + +(type: #export (Inverse u) + (|> Pure (Per u))) + +(type: #export (Product p s) + (|> s (Per (Inverse p)))) + +(def: #export (in carrier magnitude) + (All [unit] (-> unit Int (Qty unit))) + [magnitude carrier]) + +(def: #export (pure magnitude) + (-> Int Pure) + (in [] magnitude)) + +(def: #export (out quantity) + (All [unit] (-> (Qty unit) Int)) + (let [[magnitude carrier] quantity] + magnitude)) + +(def: (carrier quantity) + (All [unit] (-> (Qty unit) unit)) + (let [[magnitude carrier] quantity] + carrier)) + +(do-template [ ] + [(def: + (-> Text Text) + (|>. (format "{" kind "@" module "}") + (let [[module kind] (ident-for )])))] + + [unit-name #;;Unit] + [scale-name #;;Scale] + ) + +(syntax: #export (unit: [export csr;export] + [name s;local-symbol] + [annotations (p;default cs;empty-annotations csr;annotations)]) + (wrap (list (` (type: (~@ (csw;export export)) (~ (code;local-symbol name)) + (~ (csw;annotations annotations)) + (primitive (~ (code;local-symbol (unit-name name)))))) + (` (def: (~@ (csw;export export)) (~ (code;local-symbol (format "@" name))) + (~ (code;local-symbol name)) + (:!! []))) + ))) + +(def: ratio^ + (s;Syntax r;Ratio) + (s;tuple (do p;Monad + [numerator s;int + _ (p;assert (format "Numerator must be positive: " (%i numerator)) + (i.> 0 numerator)) + denominator s;int + _ (p;assert (format "Denominator must be positive: " (%i denominator)) + (i.> 0 denominator))] + (wrap [(int-to-nat numerator) (int-to-nat denominator)])))) + +(syntax: #export (scale: [export csr;export] + [name s;local-symbol] + [(^slots [#r;numerator #r;denominator]) ratio^] + [annotations (p;default cs;empty-annotations csr;annotations)]) + (let [g!scale (code;local-symbol name)] + (wrap (list (` (type: (~@ (csw;export export)) ((~ g!scale) (~' u)) + (~ (csw;annotations annotations)) + (primitive (~ (code;local-symbol (scale-name name))) [(~' u)]))) + (` (struct: (~@ (csw;export export)) (~ (code;local-symbol (format "@" name))) + (;;Scale (~ g!scale)) + (def: (~' scale) + (|>. ;;out + (i.* (~ (code;int (nat-to-int numerator)))) + (i./ (~ (code;int (nat-to-int denominator)))) + (;;in (:! ((~ g!scale) ($ +0)) [])))) + (def: (~' de-scale) + (|>. ;;out + (i.* (~ (code;int (nat-to-int denominator)))) + (i./ (~ (code;int (nat-to-int numerator)))) + (;;in (:! ($ +0) [])))) + (def: (~' ratio) + [(~ (code;nat numerator)) (~ (code;nat denominator))]))) + )))) + +(do-template [ ] + [(def: #export ( param subject) + (All [unit] (-> (Qty unit) (Qty unit) (Qty unit))) + (|> (out subject) ( (out param)) (in (carrier subject))))] + + [++ i.+] + [-- i.-] + ) + +(def: #export (// param subject) + (All [p s] (-> (Qty p) (Qty s) (|> (Qty s) (Per (Qty p))))) + (function [input] + (|> (out subject) + (i.* (out input)) + (i./ (out param)) + (in (carrier subject))))) + +(def: #export (** param subject) + (All [p s] (-> (Qty p) (Qty s) (Product (Qty p) (Qty s)))) + (function [input] + (|> (out subject) + (i.* (out (input param))) + (in (carrier subject))))) + +(def: #export (re-scale from to quantity) + (All [si so u] (-> (Scale si) (Scale so) (Qty (si u)) (Qty (so u)))) + (let [[numerator denominator] (|> (:: to ratio) (r;q./ (:: from ratio)))] + (|> quantity out + (i.* (nat-to-int numerator)) + (i./ (nat-to-int denominator)) + (in (:! (($ +1) ($ +2)) []))))) + +(scale: #export Kilo [1 1_000]) +(scale: #export Mega [1 1_000_000]) +(scale: #export Giga [1 1_000_000_000]) + +(scale: #export Milli [ 1_000 1]) +(scale: #export Micro [ 1_000_000 1]) +(scale: #export Nano [1_000_000_000 1]) + +(def: #export (as scale unit magnitude) + (All [s u] (-> (Scale s) u Int (Qty (s u)))) + (let [[_ carrier] (|> 0 (in unit) (:: scale scale))] + [magnitude carrier])) + +(unit: #export Gram) +(unit: #export Meter) +(unit: #export Litre) +(unit: #export Second) + +(struct: #export Eq (All [unit] (Eq (Qty unit))) + (def: (= reference sample) + (i.= (out reference) (out sample)))) + +(struct: #export Order (All [unit] (Order (Qty unit))) + (def: eq Eq) + + (do-template [ ] + [(def: ( reference sample) + ( (out reference) (out sample)))] + + [< i.<] + [<= i.<=] + [> i.>] + [>= i.>=])) + +(struct: #export Enum (All [unit] (Enum (Qty unit))) + (def: order Order) + (def: (succ qty) (|> (out qty) i.inc (in (carrier qty)))) + (def: (pred qty) (|> (out qty) i.dec (in (carrier qty))))) diff --git a/stdlib/source/lux/world/net/tcp.jvm.lux b/stdlib/source/lux/world/net/tcp.jvm.lux index 81aec7dc2..4b111fcf7 100644 --- a/stdlib/source/lux/world/net/tcp.jvm.lux +++ b/stdlib/source/lux/world/net/tcp.jvm.lux @@ -4,8 +4,8 @@ (concurrency ["P" promise] ["T" task] [frp]) - (data ["E" error]) - (meta (type opaque)) + (data ["e" error]) + (type opaque) (world [blob #+ Blob]) [io] [host]) @@ -44,7 +44,7 @@ (def: #export (read data offset length self) (let [in (get@ #in (@repr self))] (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [bytes-read (InputStream.read [data (nat-to-int offset) (nat-to-int length)] in)] (wrap (int-to-nat bytes-read)))))) @@ -52,7 +52,7 @@ (def: #export (write data offset length self) (let [out (get@ #out (@repr self))] (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [_ (OutputStream.write [data (nat-to-int offset) (nat-to-int length)] out)] (Flushable.flush [] out))))) @@ -60,14 +60,14 @@ (def: #export (close self) (let [(^open) (@repr self)] (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [_ (AutoCloseable.close [] in) _ (AutoCloseable.close [] out)] (AutoCloseable.close [] socket))))) (def: (tcp-client socket) - (-> Socket (io;IO (E;Error TCP))) - (do (E;ErrorT io;Monad) + (-> Socket (io;IO (e;Error TCP))) + (do (e;ErrorT io;Monad) [input (Socket.getInputStream [] socket) output (Socket.getOutputStream [] socket)] (wrap (@opaque {#socket socket @@ -77,7 +77,7 @@ (def: #export (client address port) (-> ..;Address ..;Port (T;Task TCP)) (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [socket (Socket.new [address (nat-to-int port)])] (tcp-client socket)))) @@ -102,21 +102,21 @@ (def: #export (server port) (-> ..;Port (T;Task (frp;Channel TCP))) (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [server (ServerSocket.new [(nat-to-int port)]) #let [output (frp;channel TCP) _ (: (P;Promise Bool) (P;future (loop [tail output] (do io;Monad - [?client (do (E;ErrorT io;Monad) + [?client (do (e;ErrorT io;Monad) [socket (ServerSocket.accept [] server)] (tcp-client socket))] (case ?client - (#E;Error error) + (#e;Error error) (frp;close tail) - (#E;Success client) + (#e;Success client) (do @ [?tail' (frp;write client tail)] (case ?tail' diff --git a/stdlib/source/lux/world/net/udp.jvm.lux b/stdlib/source/lux/world/net/udp.jvm.lux index 4bbc28729..a3124bdf2 100644 --- a/stdlib/source/lux/world/net/udp.jvm.lux +++ b/stdlib/source/lux/world/net/udp.jvm.lux @@ -5,10 +5,10 @@ (concurrency ["P" promise] ["T" task] [frp]) - (data ["E" error] + (data ["e" error] [maybe] (coll [array])) - (meta (type opaque)) + (type opaque) (world [blob #+ Blob]) [io] [host]) @@ -45,10 +45,10 @@ (exception: #export Multiple-Candidate-Addresses) (def: (resolve address) - (-> ..;Address (io;IO (E;Error InetAddress))) - (do (E;ErrorT io;Monad) + (-> ..;Address (io;IO (e;Error InetAddress))) + (do (e;ErrorT io;Monad) [addresses (InetAddress.getAllByName [address])] - (: (io;IO (E;Error InetAddress)) + (: (io;IO (e;Error InetAddress)) (case (array;size addresses) +0 (io;io (ex;throw Cannot-Resolve-Address address)) +1 (wrap (maybe;assume (array;read +0 addresses))) @@ -62,7 +62,7 @@ (let [(^open) (@repr self) packet (DatagramPacket.new|receive [data (nat-to-int offset) (nat-to-int length)])] (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [_ (DatagramSocket.receive [packet] socket) #let [bytes-read (int-to-nat (DatagramPacket.getLength [] packet))]] (wrap [bytes-read @@ -72,7 +72,7 @@ (def: #export (write address port data offset length self) (-> ..;Address ..;Port Blob Nat Nat UDP (T;Task Unit)) (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [address (resolve address) #let [(^open) (@repr self)]] (DatagramSocket.send (DatagramPacket.new|send [data (nat-to-int offset) (nat-to-int length) address (nat-to-int port)]) @@ -87,14 +87,14 @@ (def: #export (client _) (-> Unit (T;Task UDP)) (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [socket (DatagramSocket.new|client [])] (wrap (@opaque (#socket socket)))))) (def: #export (server port) (-> ..;Port (T;Task UDP)) (P;future - (do (E;ErrorT io;Monad) + (do (e;ErrorT io;Monad) [socket (DatagramSocket.new|server [(nat-to-int port)])] (wrap (@opaque (#socket socket)))))) ) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 91e6bede3..ab18e047f 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -6,9 +6,9 @@ [eq #+ Eq] pipe ["p" parser]) - (data [text "Text/" Monoid] + (data [text] text/format - ["E" error] + ["e" error] [bool] [maybe] [number "i/" Number] @@ -21,8 +21,8 @@ [syntax #+ syntax:] [poly #+ derived:] [poly/eq] - [poly/json] - (type [unit])) + [poly/json]) + (type [unit]) ["r" math/random] (time ["ti" instant] ["tda" date] @@ -170,8 +170,8 @@ (^open "@/") Codec]] (test "Can encode/decode arbitrary types." (|> sample @/encode @/decode - (case> (#E;Success result) + (case> (#e;Success result) (@/= sample result) - (#E;Error error) + (#e;Error error) false)))))) diff --git a/stdlib/test/test/lux/meta/type/implicit.lux b/stdlib/test/test/lux/meta/type/implicit.lux deleted file mode 100644 index 6d2344120..000000000 --- a/stdlib/test/test/lux/meta/type/implicit.lux +++ /dev/null @@ -1,38 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do Monad] - functor - [eq]) - (data [number] - [bool "bool/" Eq] - maybe - (coll [list])) - ["r" math/random] - (meta type/implicit)) - lux/test) - -(context: "Automatic structure selection" - (<| (times +100) - (do @ - [x r;nat - y r;nat] - ($_ seq - (test "Can automatically select first-order structures." - (let [(^open "list/") (list;Eq number;Eq)] - (and (bool/= (:: number;Eq = x y) - (::: = x y)) - (list/= (list;n.range +1 +10) - (::: map n.inc (list;n.range +0 +9))) - ))) - - (test "Can automatically select second-order structures." - (::: = - (list;n.range +1 +10) - (list;n.range +1 +10))) - - (test "Can automatically select third-order structures." - (let [lln (::: map (list;n.range +1) - (list;n.range +1 +10))] - (::: = lln lln))) - )))) diff --git a/stdlib/test/test/lux/meta/type/object.lux b/stdlib/test/test/lux/meta/type/object.lux deleted file mode 100644 index c6b7d0f80..000000000 --- a/stdlib/test/test/lux/meta/type/object.lux +++ /dev/null @@ -1,83 +0,0 @@ -(;module: - lux - (lux (data (coll [list])) - (meta (type object)))) - -## No parameters -(interface: Counter - (inc [] @) - (read [] Nat)) - -(class: NatC Counter - Nat - - (def: inc - (update@Counter n.inc)) - - (def: read - get@Counter)) - -(interface: Resettable-Counter - #super Counter - (reset [] @)) - -(class: NatRC Resettable-Counter - #super NatC - Unit - - (def: reset - (set@Counter +0))) - -## With parameters -(interface: (Collection a) - (add [a] @) - (size [] Nat)) - -(class: (ListC a) (Collection a) - (List a) - - (def: (add elem) - (update@Collection (|>. (#;Cons elem)))) - - (def: size - (|>. get@Collection list;size))) - -(interface: (Iterable a) - #super (Collection a) - (enumerate [] (List a))) - -(class: (ListI a) (Iterable a) - #super (ListC a) - Unit - - (def: enumerate - get@Collection)) - -## Polymorphism -(def: (poly0 counter) - (-> Counter Nat) - (read counter)) - -(def: poly0-0 Nat (poly0 (new@NatC +0))) -(def: poly0-1 Nat (poly0 (new@NatRC +0 []))) - -(def: (poly1 counter) - (-> Resettable-Counter Nat) - (n.+ (read counter) - (read (reset counter)))) - -(def: poly1-0 Nat (poly1 (new@NatRC +0 []))) - -(def: (poly2 counter) - (-> NatC Nat) - (read counter)) - -(def: poly2-0 Nat (poly2 (new@NatC +0))) -(def: poly2-1 Nat (poly2 (new@NatRC +0 []))) - -(def: (poly3 counter) - (-> NatRC Nat) - (n.+ (read counter) - (read (reset counter)))) - -(def: poly3-0 Nat (poly3 (new@NatRC +0 []))) diff --git a/stdlib/test/test/lux/type/implicit.lux b/stdlib/test/test/lux/type/implicit.lux new file mode 100644 index 000000000..138a16b2e --- /dev/null +++ b/stdlib/test/test/lux/type/implicit.lux @@ -0,0 +1,38 @@ +(;module: + lux + (lux [io] + (control [monad #+ do Monad] + functor + [eq]) + (data [number] + [bool "bool/" Eq] + maybe + (coll [list])) + ["r" math/random] + (type implicit)) + lux/test) + +(context: "Automatic structure selection" + (<| (times +100) + (do @ + [x r;nat + y r;nat] + ($_ seq + (test "Can automatically select first-order structures." + (let [(^open "list/") (list;Eq number;Eq)] + (and (bool/= (:: number;Eq = x y) + (::: = x y)) + (list/= (list;n.range +1 +10) + (::: map n.inc (list;n.range +0 +9))) + ))) + + (test "Can automatically select second-order structures." + (::: = + (list;n.range +1 +10) + (list;n.range +1 +10))) + + (test "Can automatically select third-order structures." + (let [lln (::: map (list;n.range +1) + (list;n.range +1 +10))] + (::: = lln lln))) + )))) diff --git a/stdlib/test/test/lux/type/object.lux b/stdlib/test/test/lux/type/object.lux new file mode 100644 index 000000000..c85ff5770 --- /dev/null +++ b/stdlib/test/test/lux/type/object.lux @@ -0,0 +1,83 @@ +(;module: + lux + (lux (data (coll [list])) + (type object))) + +## No parameters +(interface: Counter + (inc [] @) + (read [] Nat)) + +(class: NatC Counter + Nat + + (def: inc + (update@Counter n.inc)) + + (def: read + get@Counter)) + +(interface: Resettable-Counter + #super Counter + (reset [] @)) + +(class: NatRC Resettable-Counter + #super NatC + Unit + + (def: reset + (set@Counter +0))) + +## With parameters +(interface: (Collection a) + (add [a] @) + (size [] Nat)) + +(class: (ListC a) (Collection a) + (List a) + + (def: (add elem) + (update@Collection (|>. (#;Cons elem)))) + + (def: size + (|>. get@Collection list;size))) + +(interface: (Iterable a) + #super (Collection a) + (enumerate [] (List a))) + +(class: (ListI a) (Iterable a) + #super (ListC a) + Unit + + (def: enumerate + get@Collection)) + +## Polymorphism +(def: (poly0 counter) + (-> Counter Nat) + (read counter)) + +(def: poly0-0 Nat (poly0 (new@NatC +0))) +(def: poly0-1 Nat (poly0 (new@NatRC +0 []))) + +(def: (poly1 counter) + (-> Resettable-Counter Nat) + (n.+ (read counter) + (read (reset counter)))) + +(def: poly1-0 Nat (poly1 (new@NatRC +0 []))) + +(def: (poly2 counter) + (-> NatC Nat) + (read counter)) + +(def: poly2-0 Nat (poly2 (new@NatC +0))) +(def: poly2-1 Nat (poly2 (new@NatRC +0 []))) + +(def: (poly3 counter) + (-> NatRC Nat) + (n.+ (read counter) + (read (reset counter)))) + +(def: poly3-0 Nat (poly3 (new@NatRC +0 []))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 3e1d6b5f3..34f6ef8b0 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -65,9 +65,9 @@ (meta ["_;" code] ["_;" syntax] (poly ["poly_;" eq] - ["poly_;" functor]) - (type ["_;" implicit] - ["_;" object])) + ["poly_;" functor])) + (type ["_;" implicit] + ["_;" object]) (lang ["lang_;" syntax] ["_;" type] (type ["_;" check])) @@ -89,7 +89,7 @@ (coll (tree ["tree_;" parser]))) (math [random]) [meta] - (meta (type [unit])) + (type [unit]) [world/env]) ) -- cgit v1.2.3