diff options
author | Eduardo Julian | 2022-06-14 10:17:32 -0400 |
---|---|---|
committer | Eduardo Julian | 2022-06-14 10:17:32 -0400 |
commit | 9a835bde8908e4ebd1c8972211acadc5895d720a (patch) | |
tree | c4bd81cfff7357a3895389a1544eaa66230203ec | |
parent | c4d938ebb2f5245b4c3faa22c4f217e7e818589f (diff) |
De-sigil-ification: suffix : [Part 8]
-rw-r--r-- | lux-cl/source/program.lux | 2 | ||||
-rw-r--r-- | lux-js/source/program.lux | 2 | ||||
-rw-r--r-- | lux-lua/source/program.lux | 2 | ||||
-rw-r--r-- | lux-mode/lux-mode.el | 12 | ||||
-rw-r--r-- | lux-php/source/program.lux | 2 | ||||
-rw-r--r-- | lux-python/source/program.lux | 2 | ||||
-rw-r--r-- | lux-scheme/source/program.lux | 2 | ||||
-rw-r--r-- | stdlib/source/documentation/lux/ffi.jvm.lux | 6 | ||||
-rw-r--r-- | stdlib/source/documentation/lux/ffi.old.lux | 6 | ||||
-rw-r--r-- | stdlib/source/documentation/lux/type/poly.lux | 2 | ||||
-rw-r--r-- | stdlib/source/library/lux/ffi.jvm.lux | 2 | ||||
-rw-r--r-- | stdlib/source/library/lux/ffi.old.lux | 2 | ||||
-rw-r--r-- | stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux | 2 | ||||
-rw-r--r-- | stdlib/source/library/lux/type/poly.lux | 111 | ||||
-rw-r--r-- | stdlib/source/polytypic/lux/abstract/equivalence.lux | 247 | ||||
-rw-r--r-- | stdlib/source/polytypic/lux/abstract/functor.lux | 173 | ||||
-rw-r--r-- | stdlib/source/polytypic/lux/data/format/json.lux | 446 | ||||
-rw-r--r-- | stdlib/source/test/lux/ffi.jvm.lux | 14 | ||||
-rw-r--r-- | stdlib/source/test/lux/ffi.old.lux | 4 |
19 files changed, 518 insertions, 521 deletions
diff --git a/lux-cl/source/program.lux b/lux-cl/source/program.lux index 4b82594fc..d61caab05 100644 --- a/lux-cl/source/program.lux +++ b/lux-cl/source/program.lux @@ -145,7 +145,7 @@ (ffi.import org/armedbear/lisp/Closure "[1]::[0]") -(ffi.interface: LuxADT +(ffi.interface LuxADT (getValue [] java/lang/Object)) (ffi.import program/LuxADT diff --git a/lux-js/source/program.lux b/lux-js/source/program.lux index b8ba06d2c..52f5d49ef 100644 --- a/lux-js/source/program.lux +++ b/lux-js/source/program.lux @@ -141,7 +141,7 @@ "[1]::[0]") (with_template [<name>] - [(ffi.interface: <name> + [(ffi.interface <name> (getValue [] java/lang/Object)) (import <name> diff --git a/lux-lua/source/program.lux b/lux-lua/source/program.lux index dc909805f..7a2f2712e 100644 --- a/lux-lua/source/program.lux +++ b/lux-lua/source/program.lux @@ -172,7 +172,7 @@ "Class" (ffi.of_string (java/lang/Object::toString (java/lang/Object::getClass object))) "Object" (ffi.of_string (java/lang/Object::toString object)))) - (ffi.interface: LuxValue + (ffi.interface LuxValue (getValue [] java/lang/Object)) (ffi.import LuxValue diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el index 7d9f18203..8b79a6cf5 100644 --- a/lux-mode/lux-mode.el +++ b/lux-mode/lux-mode.el @@ -376,7 +376,7 @@ Called by `imenu--generic-function'." (type//checking (altRE "is" "as" "let" "as_expected" "type_of" "sharing" "by_example" "hole")) (type//primitive (altRE "primitive:" "abstraction" "representation" "transmutation")) (type//unit (altRE "unit:" "scale:")) - (type//poly (altRE "poly:")) + (type//poly (altRE "polytypic")) (type//dynamic (altRE "dynamic" "static")) (type//capability (altRE "capability:")) ;; Data @@ -389,7 +389,7 @@ Called by `imenu--generic-function'." (code//super-quotation (altRE "``" "~~")) (code//template (altRE "with_template" "template")) ;; Miscellaneous - (jvm-host (altRE "import" "export" "class:" "interface:" "object" "do_to" "synchronized" "class_for")) + (jvm-host (altRE "import" "export" "class:" "interface" "object" "do_to" "synchronized" "class_for")) (alternative-format (altRE "char" "bin" "oct" "hex")) (documentation (altRE "comment" "documentation:")) (function-application (altRE "|>" "<|" "left" "right" "all")) @@ -579,18 +579,20 @@ This function also returns nil meaning don't specify the indentation." (define-lux-indent ("function" 'defun) + ("macro" 'defun) ("syntax" 'defun) ("template" 'defun) - ("message" 'defun) + ("polytypic" 'defun) ("analysis" 'defun) ("synthesis" 'defun) ("generation" 'defun) ("directive" 'defun) - (import 'defun) - (export 'defun) + ("interface" 'defun) + ("import" 'defun) + ("export" 'defun) (let 'defun) (case 'defun) diff --git a/lux-php/source/program.lux b/lux-php/source/program.lux index 24f215fb5..1e117c033 100644 --- a/lux-php/source/program.lux +++ b/lux-php/source/program.lux @@ -167,7 +167,7 @@ (call [php/runtime/env/Environment [php/runtime/Memory]] "try" php/runtime/Memory)) (with_template [<name>] - [(ffi.interface: <name> + [(ffi.interface <name> (getValue [] java/lang/Object)) (`` (ffi.import (~~ (template.symbol ["program/" <name>])) diff --git a/lux-python/source/program.lux b/lux-python/source/program.lux index 2704b0e80..ecb78d6f4 100644 --- a/lux-python/source/program.lux +++ b/lux-python/source/program.lux @@ -199,7 +199,7 @@ _ (exception.except ..unknown_kind_of_object [(as java/lang/Object host_object)]))) - (ffi.interface: LuxValue + (ffi.interface LuxValue (value [] java/lang/Object)) (import LuxValue diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux index b70e6f17c..c0145adf7 100644 --- a/lux-scheme/source/program.lux +++ b/lux-scheme/source/program.lux @@ -160,7 +160,7 @@ false)) (with_template [<name>] - [(ffi.interface: <name> + [(ffi.interface <name> (getValue [] java/lang/Object)) (`` (ffi.import (~~ (template.symbol ["program/" <name>])) diff --git a/stdlib/source/documentation/lux/ffi.jvm.lux b/stdlib/source/documentation/lux/ffi.jvm.lux index 254f5d7a1..72a5e15cd 100644 --- a/stdlib/source/documentation/lux/ffi.jvm.lux +++ b/stdlib/source/documentation/lux/ffi.jvm.lux @@ -110,9 +110,9 @@ "(::new! []) for calling the class's constructor." "(::resolve! container [value]) for calling the 'resolve' method."]) -(documentation: /.interface: +(documentation: /.interface "Allows defining JVM interfaces." - [(interface: TestInterface + [(interface TestInterface ([] foo [boolean String] void "throws" [Exception]))]) (documentation: /.object @@ -306,7 +306,7 @@ ..short_to_char ..class: - ..interface: + ..interface ..object ..null ..null? diff --git a/stdlib/source/documentation/lux/ffi.old.lux b/stdlib/source/documentation/lux/ffi.old.lux index 36282f92d..a93ecbe95 100644 --- a/stdlib/source/documentation/lux/ffi.old.lux +++ b/stdlib/source/documentation/lux/ffi.old.lux @@ -74,9 +74,9 @@ "(::new! []) for calling the class's constructor." "(::resolve! container [value]) for calling the 'resolve' method."]) -(documentation: /.interface: +(documentation: /.interface "Allows defining JVM interfaces." - [(interface: TestInterface + [(interface TestInterface ([] foo [boolean String] void "throws" [Exception]))]) (documentation: /.object @@ -240,7 +240,7 @@ ..char_to_int ..char_to_long ..class: - ..interface: + ..interface ..object ..null ..null? diff --git a/stdlib/source/documentation/lux/type/poly.lux b/stdlib/source/documentation/lux/type/poly.lux index e08c1d058..92183f398 100644 --- a/stdlib/source/documentation/lux/type/poly.lux +++ b/stdlib/source/documentation/lux/type/poly.lux @@ -26,5 +26,5 @@ ($.module /._ "" [..code - ($.default /.poly:)] + ($.default /.polytypic)] [])) diff --git a/stdlib/source/library/lux/ffi.jvm.lux b/stdlib/source/library/lux/ffi.jvm.lux index 4753e6f14..32b5410ee 100644 --- a/stdlib/source/library/lux/ffi.jvm.lux +++ b/stdlib/source/library/lux/ffi.jvm.lux @@ -1230,7 +1230,7 @@ [(~+ (list#each field_decl$ fields))] [(~+ methods)]))))))) -(def: .public interface: +(def: .public interface (syntax (_ [.let [! <>.monad] [full_class_name class_vars] (at ! each parser.declaration ..declaration^) supers (<>.else (list) diff --git a/stdlib/source/library/lux/ffi.old.lux b/stdlib/source/library/lux/ffi.old.lux index db6bfb42e..1933ba032 100644 --- a/stdlib/source/library/lux/ffi.old.lux +++ b/stdlib/source/library/lux/ffi.old.lux @@ -1232,7 +1232,7 @@ (with_brackets (spaced (list#each (method_def$ replacer super) methods))))))]] (in (list (` ((~ (code.text def_code))))))))) -(def: .public interface: +(def: .public interface (syntax (_ [class_decl ..class_decl^ .let [class_vars (product.right class_decl)] supers (<>.else (list) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux index 8f5c9db8a..aa9829172 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux @@ -53,7 +53,7 @@ list.together))] ((~' in) ((~ g!extension) [(~+ g!input+)]))) - (~' _) + (~ g!_) (///.except ///extension.incorrect_arity [(~ g!name) 1 (list.size (~ g!inputs))]))))))))))) (arity: 0 nullary ..Nullary) diff --git a/stdlib/source/library/lux/type/poly.lux b/stdlib/source/library/lux/type/poly.lux index fa27e032b..aeb27188b 100644 --- a/stdlib/source/library/lux/type/poly.lux +++ b/stdlib/source/library/lux/type/poly.lux @@ -24,75 +24,66 @@ [number ["n" nat]]]]]) -(def: polyP - (Parser [Code Text Code]) - (let [private (all <>.and - <code>.local - <code>.any)] - (<>.either (<>.and <code>.any private) - (<>.and (<>#in (` .private)) private)))) - -(def: .public poly: - (syntax (_ [[export_policy name body] ..polyP]) +(def: .public polytypic + (syntax (_ [name <code>.local + body <code>.any]) (with_symbols [g!_ g!type g!output] (let [g!name (code.symbol ["" name])] - (in (.list (` (def: (~ export_policy) (~ g!name) - ((~! syntax) ((~ g!name) [(~ g!type) (~! <code>.any)]) - ((~! do) (~! meta.monad) - [(~ g!type) ((~! meta.eval) .Type (~ g!type))] - (case (is (.Either .Text .Code) - ((~! <type>.result) ((~! <>.rec) - (function ((~ g!_) (~ g!name)) - (~ body))) - (.as .Type (~ g!type)))) - {.#Left (~ g!output)} - ((~! meta.failure) (~ g!output)) + (in (.list (` ((~! syntax) ((~ g!_) [(~ g!type) (~! <code>.any)]) + ((~! do) (~! meta.monad) + [(~ g!type) ((~! meta.eval) .Type (~ g!type))] + (case (is (.Either .Text .Code) + ((~! <type>.result) ((~! <>.rec) + (function ((~ g!_) (~ g!name)) + (~ body))) + (.as .Type (~ g!type)))) + {.#Right (~ g!output)} + ((~' in) (.list (~ g!output))) - {.#Right (~ g!output)} - ((~' in) (.list (~ g!output)))))))))))))) + {.#Left (~ g!output)} + ((~! meta.failure) (~ g!output)))))))))))) (def: .public (code env type) (-> Env Type Code) - (`` (case type - {.#Primitive name params} - (` {.#Primitive (~ (code.text name)) - (.list (~+ (list#each (code env) params)))}) + (case type + {.#Primitive name params} + (` {.#Primitive (~ (code.text name)) + (.list (~+ (list#each (code env) params)))}) - (^.with_template [<tag>] - [{<tag> idx} - (` {<tag> (~ (code.nat idx))})]) - ([.#Var] [.#Ex]) + (^.with_template [<tag>] + [{<tag> idx} + (` {<tag> (~ (code.nat idx))})]) + ([.#Var] [.#Ex]) - {.#Parameter idx} - (let [idx (<type>.argument env idx)] - (if (n.= 0 idx) - (|> (dictionary.value idx env) maybe.trusted product.left (code env)) - (` (.$ (~ (code.nat (-- idx))))))) + {.#Parameter idx} + (let [idx (<type>.argument env idx)] + (if (n.= 0 idx) + (|> (dictionary.value idx env) maybe.trusted product.left (code env)) + (` (.$ (~ (code.nat (-- idx))))))) - {.#Apply {.#Primitive "" {.#End}} - {.#Parameter idx}} - (case (<type>.argument env idx) - 0 (|> env (dictionary.value 0) maybe.trusted product.left (code env)) - idx (undefined)) - - (^.with_template [<tag>] - [{<tag> left right} - (` {<tag> (~ (code env left)) - (~ (code env right))})]) - ([.#Function] [.#Apply]) + {.#Apply {.#Primitive "" {.#End}} + {.#Parameter idx}} + (case (<type>.argument env idx) + 0 (|> env (dictionary.value 0) maybe.trusted product.left (code env)) + idx (undefined)) + + (^.with_template [<tag>] + [{<tag> left right} + (` {<tag> (~ (code env left)) + (~ (code env right))})]) + ([.#Function] [.#Apply]) - (^.with_template [<macro> <tag> <flattener>] - [{<tag> left right} - (` (<macro> (~+ (list#each (code env) (<flattener> type)))))]) - ([.Union .#Sum type.flat_variant] - [.Tuple .#Product type.flat_tuple]) + (^.with_template [<macro> <tag> <flattener>] + [{<tag> left right} + (` (<macro> (~+ (list#each (code env) (<flattener> type)))))]) + ([.Union .#Sum type.flat_variant] + [.Tuple .#Product type.flat_tuple]) - {.#Named name sub_type} - (code.symbol name) + {.#Named name sub_type} + (code.symbol name) - (^.with_template [<tag>] - [{<tag> scope body} - (` {<tag> (.list (~+ (list#each (code env) scope))) - (~ (code env body))})]) - ([.#UnivQ] [.#ExQ]) - ))) + (^.with_template [<tag>] + [{<tag> scope body} + (` {<tag> (.list (~+ (list#each (code env) scope))) + (~ (code env body))})]) + ([.#UnivQ] [.#ExQ]))) diff --git a/stdlib/source/polytypic/lux/abstract/equivalence.lux b/stdlib/source/polytypic/lux/abstract/equivalence.lux index 119142267..03d3dd3de 100644 --- a/stdlib/source/polytypic/lux/abstract/equivalence.lux +++ b/stdlib/source/polytypic/lux/abstract/equivalence.lux @@ -35,133 +35,134 @@ ["[0]" day] ["[0]" month]] ["[0]" type (.only) - ["[0]" poly (.only poly:)] + ["[0]" poly (.only polytypic)] ["[0]" unit]]]] [\\library ["[0]" /]]) -(poly: .public equivalence - (`` (do [! <>.monad] - [.let [g!_ (code.local "_____________")] - *env* <type>.env - inputT <type>.next - .let [@Equivalence (is (-> Type Code) - (function (_ type) - (` ((~! /.Equivalence) (~ (poly.code *env* type))))))]] - (all <>.either - ... Basic types - (~~ (with_template [<matcher> <eq>] - [(do ! - [_ <matcher>] - (in (` (is (~ (@Equivalence inputT)) - <eq>))))] +(def: .public equivalence + (polytypic equivalence + (`` (do [! <>.monad] + [.let [g!_ (code.local "_____________")] + *env* <type>.env + inputT <type>.next + .let [@Equivalence (is (-> Type Code) + (function (_ type) + (` ((~! /.Equivalence) (~ (poly.code *env* type))))))]] + (all <>.either + ... Basic types + (~~ (with_template [<matcher> <eq>] + [(do ! + [_ <matcher>] + (in (` (is (~ (@Equivalence inputT)) + <eq>))))] - [(<type>.exactly Any) (function ((~ g!_) (~ g!_) (~ g!_)) #1)] - [(<type>.sub Bit) (~! bit.equivalence)] - [(<type>.sub Nat) (~! nat.equivalence)] - [(<type>.sub Int) (~! int.equivalence)] - [(<type>.sub Rev) (~! rev.equivalence)] - [(<type>.sub Frac) (~! frac.equivalence)] - [(<type>.sub Text) (~! text.equivalence)])) - ... Composite types - (~~ (with_template [<name> <eq>] - [(do ! - [[_ argC] (<type>.applied (<>.and (<type>.exactly <name>) - equivalence))] - (in (` (is (~ (@Equivalence inputT)) - (<eq> (~ argC))))))] + [(<type>.exactly Any) (function ((~ g!_) (~ g!_) (~ g!_)) #1)] + [(<type>.sub Bit) (~! bit.equivalence)] + [(<type>.sub Nat) (~! nat.equivalence)] + [(<type>.sub Int) (~! int.equivalence)] + [(<type>.sub Rev) (~! rev.equivalence)] + [(<type>.sub Frac) (~! frac.equivalence)] + [(<type>.sub Text) (~! text.equivalence)])) + ... Composite types + (~~ (with_template [<name> <eq>] + [(do ! + [[_ argC] (<type>.applied (<>.and (<type>.exactly <name>) + equivalence))] + (in (` (is (~ (@Equivalence inputT)) + (<eq> (~ argC))))))] - [.Maybe (~! maybe.equivalence)] - [.List (~! list.equivalence)] - [sequence.Sequence (~! sequence.equivalence)] - [array.Array (~! array.equivalence)] - [queue.Queue (~! queue.equivalence)] - [set.Set (~! set.equivalence)] - [tree.Tree (~! tree.equivalence)] - )) - (do ! - [[_ _ valC] (<type>.applied (all <>.and - (<type>.exactly dictionary.Dictionary) - <type>.any - equivalence))] - (in (` (is (~ (@Equivalence inputT)) - ((~! dictionary.equivalence) (~ valC)))))) - ... Models - (~~ (with_template [<type> <eq>] - [(do ! - [_ (<type>.exactly <type>)] - (in (` (is (~ (@Equivalence inputT)) - <eq>))))] + [.Maybe (~! maybe.equivalence)] + [.List (~! list.equivalence)] + [sequence.Sequence (~! sequence.equivalence)] + [array.Array (~! array.equivalence)] + [queue.Queue (~! queue.equivalence)] + [set.Set (~! set.equivalence)] + [tree.Tree (~! tree.equivalence)] + )) + (do ! + [[_ _ valC] (<type>.applied (all <>.and + (<type>.exactly dictionary.Dictionary) + <type>.any + equivalence))] + (in (` (is (~ (@Equivalence inputT)) + ((~! dictionary.equivalence) (~ valC)))))) + ... Models + (~~ (with_template [<type> <eq>] + [(do ! + [_ (<type>.exactly <type>)] + (in (` (is (~ (@Equivalence inputT)) + <eq>))))] - [duration.Duration duration.equivalence] - [instant.Instant instant.equivalence] - [date.Date date.equivalence] - [day.Day day.equivalence] - [month.Month month.equivalence] - )) - (do ! - [_ (<type>.applied (<>.and (<type>.exactly unit.Qty) - <type>.any))] - (in (` (is (~ (@Equivalence inputT)) - unit.equivalence)))) - ... Variants - (do ! - [members (<type>.variant (<>.many equivalence)) - .let [last (-- (list.size members)) - g!_ (code.local "_____________") - g!left (code.local "_____________left") - g!right (code.local "_____________right")]] - (in (` (is (~ (@Equivalence inputT)) - (function ((~ g!_) (~ g!left) (~ g!right)) - (case [(~ g!left) (~ g!right)] - (~+ (list#conjoint (list#each (function (_ [tag g!eq]) - (if (nat.= last tag) - (list (` [{(~ (code.nat (-- tag))) #1 (~ g!left)} - {(~ (code.nat (-- tag))) #1 (~ g!right)}]) - (` ((~ g!eq) (~ g!left) (~ g!right)))) - (list (` [{(~ (code.nat tag)) #0 (~ g!left)} - {(~ (code.nat tag)) #0 (~ g!right)}]) - (` ((~ g!eq) (~ g!left) (~ g!right)))))) - (list.enumeration members)))) - (~ g!_) - #0)))))) - ... Tuples - (do ! - [g!eqs (<type>.tuple (<>.many equivalence)) - .let [g!_ (code.local "_____________") - indices (list.indices (list.size g!eqs)) - g!lefts (list#each (|>> nat#encoded (text#composite "left") code.local) indices) - g!rights (list#each (|>> nat#encoded (text#composite "right") code.local) indices)]] - (in (` (is (~ (@Equivalence inputT)) - (function ((~ g!_) [(~+ g!lefts)] [(~+ g!rights)]) - (and (~+ (|> (list.zipped_3 g!eqs g!lefts g!rights) - (list#each (function (_ [g!eq g!left g!right]) - (` ((~ g!eq) (~ g!left) (~ g!right))))))))))))) - ... Type recursion - (do ! - [[g!self bodyC] (<type>.recursive equivalence) - .let [g!_ (code.local "_____________")]] - (in (` (is (~ (@Equivalence inputT)) - ((~! /.rec) (.function ((~ g!_) (~ g!self)) - (~ bodyC))))))) - <type>.recursive_self - ... Type applications - (do ! - [[funcC argsC] (<type>.applied (<>.and equivalence (<>.many equivalence)))] - (in (` ((~ funcC) (~+ argsC))))) - ... Parameters - <type>.parameter - ... Polymorphism - (do ! - [[funcC varsC bodyC] (<type>.polymorphic equivalence)] - (in (` (is (All ((~ g!_) (~+ varsC)) - (-> (~+ (list#each (|>> (~) ((~! /.Equivalence)) (`)) varsC)) - ((~! /.Equivalence) ((~ (poly.code *env* inputT)) (~+ varsC))))) - (function ((~ funcC) (~+ varsC)) - (~ bodyC)))))) - <type>.recursive_call - ... If all else fails... - (|> <type>.any - (at ! each (|>> %.type (format "Cannot create Equivalence for: ") <>.failure)) - (at ! conjoint)) - )))) + [duration.Duration duration.equivalence] + [instant.Instant instant.equivalence] + [date.Date date.equivalence] + [day.Day day.equivalence] + [month.Month month.equivalence] + )) + (do ! + [_ (<type>.applied (<>.and (<type>.exactly unit.Qty) + <type>.any))] + (in (` (is (~ (@Equivalence inputT)) + unit.equivalence)))) + ... Variants + (do ! + [members (<type>.variant (<>.many equivalence)) + .let [last (-- (list.size members)) + g!_ (code.local "_____________") + g!left (code.local "_____________left") + g!right (code.local "_____________right")]] + (in (` (is (~ (@Equivalence inputT)) + (function ((~ g!_) (~ g!left) (~ g!right)) + (case [(~ g!left) (~ g!right)] + (~+ (list#conjoint (list#each (function (_ [tag g!eq]) + (if (nat.= last tag) + (list (` [{(~ (code.nat (-- tag))) #1 (~ g!left)} + {(~ (code.nat (-- tag))) #1 (~ g!right)}]) + (` ((~ g!eq) (~ g!left) (~ g!right)))) + (list (` [{(~ (code.nat tag)) #0 (~ g!left)} + {(~ (code.nat tag)) #0 (~ g!right)}]) + (` ((~ g!eq) (~ g!left) (~ g!right)))))) + (list.enumeration members)))) + (~ g!_) + #0)))))) + ... Tuples + (do ! + [g!eqs (<type>.tuple (<>.many equivalence)) + .let [g!_ (code.local "_____________") + indices (list.indices (list.size g!eqs)) + g!lefts (list#each (|>> nat#encoded (text#composite "left") code.local) indices) + g!rights (list#each (|>> nat#encoded (text#composite "right") code.local) indices)]] + (in (` (is (~ (@Equivalence inputT)) + (function ((~ g!_) [(~+ g!lefts)] [(~+ g!rights)]) + (and (~+ (|> (list.zipped_3 g!eqs g!lefts g!rights) + (list#each (function (_ [g!eq g!left g!right]) + (` ((~ g!eq) (~ g!left) (~ g!right))))))))))))) + ... Type recursion + (do ! + [[g!self bodyC] (<type>.recursive equivalence) + .let [g!_ (code.local "_____________")]] + (in (` (is (~ (@Equivalence inputT)) + ((~! /.rec) (.function ((~ g!_) (~ g!self)) + (~ bodyC))))))) + <type>.recursive_self + ... Type applications + (do ! + [[funcC argsC] (<type>.applied (<>.and equivalence (<>.many equivalence)))] + (in (` ((~ funcC) (~+ argsC))))) + ... Parameters + <type>.parameter + ... Polymorphism + (do ! + [[funcC varsC bodyC] (<type>.polymorphic equivalence)] + (in (` (is (All ((~ g!_) (~+ varsC)) + (-> (~+ (list#each (|>> (~) ((~! /.Equivalence)) (`)) varsC)) + ((~! /.Equivalence) ((~ (poly.code *env* inputT)) (~+ varsC))))) + (function ((~ funcC) (~+ varsC)) + (~ bodyC)))))) + <type>.recursive_call + ... If all else fails... + (|> <type>.any + (at ! each (|>> %.type (format "Cannot create Equivalence for: ") <>.failure)) + (at ! conjoint)) + ))))) diff --git a/stdlib/source/polytypic/lux/abstract/functor.lux b/stdlib/source/polytypic/lux/abstract/functor.lux index 3ad598a91..fc7cae722 100644 --- a/stdlib/source/polytypic/lux/abstract/functor.lux +++ b/stdlib/source/polytypic/lux/abstract/functor.lux @@ -19,92 +19,93 @@ [number ["n" nat]]] ["[0]" type (.only) - ["[0]" poly (.only poly:)]]]] + ["[0]" poly (.only polytypic)]]]] [\\library ["[0]" /]]) -(poly: .public functor - (do [! p.monad] - [.let [g!_ (code.local "____________") - type_funcC (code.local "____________type_funcC") - funcC (code.local "____________funcC") - inputC (code.local "____________inputC")] - *env* <type>.env - inputT <type>.next - [polyC varsC non_functorT] (<type>.local (list inputT) - (<type>.polymorphic <type>.any)) - .let [num_vars (list.size varsC)] - .let [@Functor (is (-> Type Code) - (function (_ unwrappedT) - (if (n.= 1 num_vars) - (` ((~! /.Functor) (~ (poly.code *env* unwrappedT)))) - (let [paramsC (|> num_vars -- list.indices (list#each (|>> %.nat code.local)))] - (` (All ((~ g!_) (~+ paramsC)) - ((~! /.Functor) ((~ (poly.code *env* unwrappedT)) (~+ paramsC))))))))) - Arg<?> (is (-> Code (<type>.Parser Code)) - (function (Arg<?> valueC) - (all p.either - ... Type-var - (do p.monad - [.let [varI (|> num_vars (n.* 2) --)] - _ (<type>.this_parameter varI)] - (in (` ((~ funcC) (~ valueC))))) - ... Variants - (do ! - [_ (in []) - membersC (<type>.variant (p.many (Arg<?> valueC))) - .let [last (-- (list.size membersC))]] - (in (` (case (~ valueC) - (~+ (list#conjoint (list#each (function (_ [tag memberC]) - (if (n.= last tag) - (list (` {(~ (code.nat (-- tag))) #1 (~ valueC)}) - (` {(~ (code.nat (-- tag))) #1 (~ memberC)})) - (list (` {(~ (code.nat tag)) #0 (~ valueC)}) - (` {(~ (code.nat tag)) #0 (~ memberC)})))) - (list.enumeration membersC)))))))) - ... Tuples - (do p.monad - [pairsCC (is (<type>.Parser (List [Code Code])) - (<type>.tuple (loop (again [idx 0 - pairsCC (is (List [Code Code]) - (list))]) - (p.either (let [slotC (|> idx %.nat (format "____________slot") code.local)] - (do ! - [_ (in []) - memberC (Arg<?> slotC)] - (again (++ idx) - (list#composite pairsCC (list [slotC memberC]))))) - (in pairsCC)))))] - (in (` (case (~ valueC) - [(~+ (list#each product.left pairsCC))] - [(~+ (list#each product.right pairsCC))])))) - ... Functions - (do ! - [_ (in []) - .let [g! (code.local "____________") - outL (code.local "____________outL")] - [inT+ outC] (<type>.function (p.many <type>.any) - (Arg<?> outL)) - .let [inC+ (|> (list.size inT+) - list.indices - (list#each (|>> %.nat (format "____________inC") code.local)))]] - (in (` (function ((~ g!) (~+ inC+)) - (let [(~ outL) ((~ valueC) (~+ inC+))] - (~ outC)))))) - ... Recursion - (do p.monad - [_ <type>.recursive_call] - (in (` ((~' each) (~ funcC) (~ valueC))))) - ... Parameters - (do p.monad - [_ <type>.any] - (in valueC)) - )))] - [_ _ outputC] (is (<type>.Parser [Code (List Code) Code]) - (p.either (<type>.polymorphic - (Arg<?> inputC)) - (p.failure (format "Cannot create Functor for: " (%.type inputT)))))] - (in (` (is (~ (@Functor inputT)) - (implementation - (def: ((~' each) (~ funcC) (~ inputC)) - (~ outputC)))))))) +(def: .public functor + (polytypic functor + (do [! p.monad] + [.let [g!_ (code.local "____________") + type_funcC (code.local "____________type_funcC") + funcC (code.local "____________funcC") + inputC (code.local "____________inputC")] + *env* <type>.env + inputT <type>.next + [polyC varsC non_functorT] (<type>.local (list inputT) + (<type>.polymorphic <type>.any)) + .let [num_vars (list.size varsC)] + .let [@Functor (is (-> Type Code) + (function (_ unwrappedT) + (if (n.= 1 num_vars) + (` ((~! /.Functor) (~ (poly.code *env* unwrappedT)))) + (let [paramsC (|> num_vars -- list.indices (list#each (|>> %.nat code.local)))] + (` (All ((~ g!_) (~+ paramsC)) + ((~! /.Functor) ((~ (poly.code *env* unwrappedT)) (~+ paramsC))))))))) + Arg<?> (is (-> Code (<type>.Parser Code)) + (function (Arg<?> valueC) + (all p.either + ... Type-var + (do p.monad + [.let [varI (|> num_vars (n.* 2) --)] + _ (<type>.this_parameter varI)] + (in (` ((~ funcC) (~ valueC))))) + ... Variants + (do ! + [_ (in []) + membersC (<type>.variant (p.many (Arg<?> valueC))) + .let [last (-- (list.size membersC))]] + (in (` (case (~ valueC) + (~+ (list#conjoint (list#each (function (_ [tag memberC]) + (if (n.= last tag) + (list (` {(~ (code.nat (-- tag))) #1 (~ valueC)}) + (` {(~ (code.nat (-- tag))) #1 (~ memberC)})) + (list (` {(~ (code.nat tag)) #0 (~ valueC)}) + (` {(~ (code.nat tag)) #0 (~ memberC)})))) + (list.enumeration membersC)))))))) + ... Tuples + (do p.monad + [pairsCC (is (<type>.Parser (List [Code Code])) + (<type>.tuple (loop (again [idx 0 + pairsCC (is (List [Code Code]) + (list))]) + (p.either (let [slotC (|> idx %.nat (format "____________slot") code.local)] + (do ! + [_ (in []) + memberC (Arg<?> slotC)] + (again (++ idx) + (list#composite pairsCC (list [slotC memberC]))))) + (in pairsCC)))))] + (in (` (case (~ valueC) + [(~+ (list#each product.left pairsCC))] + [(~+ (list#each product.right pairsCC))])))) + ... Functions + (do ! + [_ (in []) + .let [g! (code.local "____________") + outL (code.local "____________outL")] + [inT+ outC] (<type>.function (p.many <type>.any) + (Arg<?> outL)) + .let [inC+ (|> (list.size inT+) + list.indices + (list#each (|>> %.nat (format "____________inC") code.local)))]] + (in (` (function ((~ g!) (~+ inC+)) + (let [(~ outL) ((~ valueC) (~+ inC+))] + (~ outC)))))) + ... Recursion + (do p.monad + [_ <type>.recursive_call] + (in (` ((~' each) (~ funcC) (~ valueC))))) + ... Parameters + (do p.monad + [_ <type>.any] + (in valueC)) + )))] + [_ _ outputC] (is (<type>.Parser [Code (List Code) Code]) + (p.either (<type>.polymorphic + (Arg<?> inputC)) + (p.failure (format "Cannot create Functor for: " (%.type inputT)))))] + (in (` (is (~ (@Functor inputT)) + (implementation + (def: ((~' each) (~ funcC) (~ inputC)) + (~ outputC))))))))) diff --git a/stdlib/source/polytypic/lux/data/format/json.lux b/stdlib/source/polytypic/lux/data/format/json.lux index 801a16e19..b86f256a2 100644 --- a/stdlib/source/polytypic/lux/data/format/json.lux +++ b/stdlib/source/polytypic/lux/data/format/json.lux @@ -35,7 +35,7 @@ ["[0]" month]] ["[0]" type (.only) ["[0]" unit] - ["[0]" poly (.only poly:)]]]] + ["[0]" poly (.only polytypic)]]]] [\\library ["[0]" / (.only JSON)]]) @@ -96,233 +96,235 @@ (|>> (at ..int_codec decoded) (at try.functor each (debug.private unit.in')))))) -(poly: encoded - (with_expansions - [<basic> (with_template [<matcher> <encoder>] - [(do ! - [.let [g!_ (code.local "_______")] - _ <matcher>] - (in (` (is (~ (@JSON#encoded inputT)) - <encoder>))))] +(def: encoded + (polytypic encoded + (with_expansions + [<basic> (with_template [<matcher> <encoder>] + [(do ! + [.let [g!_ (code.local "_______")] + _ <matcher>] + (in (` (is (~ (@JSON#encoded inputT)) + <encoder>))))] - [(<type>.exactly Any) (function ((~ g!_) (~ (code.symbol ["" "0"]))) {/.#Null})] - [(<type>.sub Bit) (|>> {/.#Boolean})] - [(<type>.sub Nat) (at (~! ..nat_codec) (~' encoded))] - [(<type>.sub Int) (at (~! ..int_codec) (~' encoded))] - [(<type>.sub Frac) (|>> {/.#Number})] - [(<type>.sub Text) (|>> {/.#String})]) - <time> (with_template [<type> <codec>] - [(do ! - [_ (<type>.exactly <type>)] - (in (` (is (~ (@JSON#encoded inputT)) - (|>> (at (~! <codec>) (~' encoded)) {/.#String})))))] + [(<type>.exactly Any) (function ((~ g!_) (~ (code.symbol ["" "0"]))) {/.#Null})] + [(<type>.sub Bit) (|>> {/.#Boolean})] + [(<type>.sub Nat) (at (~! ..nat_codec) (~' encoded))] + [(<type>.sub Int) (at (~! ..int_codec) (~' encoded))] + [(<type>.sub Frac) (|>> {/.#Number})] + [(<type>.sub Text) (|>> {/.#String})]) + <time> (with_template [<type> <codec>] + [(do ! + [_ (<type>.exactly <type>)] + (in (` (is (~ (@JSON#encoded inputT)) + (|>> (at (~! <codec>) (~' encoded)) {/.#String})))))] - ... [duration.Duration duration.codec] - ... [instant.Instant instant.codec] - [date.Date date.codec] - [day.Day day.codec] - [month.Month month.codec])] - (do [! <>.monad] - [*env* <type>.env - .let [g!_ (code.local "_______") - @JSON#encoded (is (-> Type Code) - (function (_ type) - (` (-> (~ (poly.code *env* type)) /.JSON))))] - inputT <type>.next] - (all <>.either - <basic> - <time> - (do ! - [unitT (<type>.applied (<>.after (<type>.exactly unit.Qty) - <type>.any))] - (in (` (is (~ (@JSON#encoded inputT)) - (at (~! qty_codec) (~' encoded)))))) - (do ! - [.let [g!_ (code.local "_______") - g!key (code.local "_______key") - g!val (code.local "_______val")] - [_ _ =val=] (<type>.applied (all <>.and - (<type>.exactly dictionary.Dictionary) - (<type>.exactly .Text) + ... [duration.Duration duration.codec] + ... [instant.Instant instant.codec] + [date.Date date.codec] + [day.Day day.codec] + [month.Month month.codec])] + (do [! <>.monad] + [*env* <type>.env + .let [g!_ (code.local "_______") + @JSON#encoded (is (-> Type Code) + (function (_ type) + (` (-> (~ (poly.code *env* type)) /.JSON))))] + inputT <type>.next] + (all <>.either + <basic> + <time> + (do ! + [unitT (<type>.applied (<>.after (<type>.exactly unit.Qty) + <type>.any))] + (in (` (is (~ (@JSON#encoded inputT)) + (at (~! qty_codec) (~' encoded)))))) + (do ! + [.let [g!_ (code.local "_______") + g!key (code.local "_______key") + g!val (code.local "_______val")] + [_ _ =val=] (<type>.applied (all <>.and + (<type>.exactly dictionary.Dictionary) + (<type>.exactly .Text) + encoded))] + (in (` (is (~ (@JSON#encoded inputT)) + (|>> ((~! dictionary.entries)) + ((~! list#each) (function ((~ g!_) [(~ g!key) (~ g!val)]) + [(~ g!key) ((~ =val=) (~ g!val))])) + ((~! dictionary.of_list) (~! text.hash)) + {/.#Object}))))) + (do ! + [[_ =sub=] (<type>.applied (all <>.and + (<type>.exactly .Maybe) encoded))] - (in (` (is (~ (@JSON#encoded inputT)) - (|>> ((~! dictionary.entries)) - ((~! list#each) (function ((~ g!_) [(~ g!key) (~ g!val)]) - [(~ g!key) ((~ =val=) (~ g!val))])) - ((~! dictionary.of_list) (~! text.hash)) - {/.#Object}))))) - (do ! - [[_ =sub=] (<type>.applied (all <>.and - (<type>.exactly .Maybe) - encoded))] - (in (` (is (~ (@JSON#encoded inputT)) - ((~! ..nullable) (~ =sub=)))))) - (do ! - [[_ =sub=] (<type>.applied (all <>.and - (<type>.exactly .List) - encoded))] - (in (` (is (~ (@JSON#encoded inputT)) - (|>> ((~! list#each) (~ =sub=)) ((~! sequence.of_list)) {/.#Array}))))) - (do ! - [.let [g!_ (code.local "_______") - g!input (code.local "_______input")] - members (<type>.variant (<>.many encoded)) - .let [last (-- (list.size members))]] - (in (` (is (~ (@JSON#encoded inputT)) - (function ((~ g!_) (~ g!input)) - (case (~ g!input) - (~+ (list#conjoint (list#each (function (_ [tag g!encoded]) - (if (n.= last tag) - (.list (` {(~ (code.nat (-- tag))) #1 (~ g!input)}) - (` ((~! /.json) [(~ (code.frac (..tag (-- tag)))) - #1 - ((~ g!encoded) (~ g!input))]))) - (.list (` {(~ (code.nat tag)) #0 (~ g!input)}) - (` ((~! /.json) [(~ (code.frac (..tag tag))) - #0 - ((~ g!encoded) (~ g!input))]))))) - (list.enumeration members)))))))))) - (do ! - [g!encoders (<type>.tuple (<>.many encoded)) - .let [g!_ (code.local "_______") - g!members (|> (list.size g!encoders) - list.indices - (list#each (|>> n#encoded code.local)))]] - (in (` (is (~ (@JSON#encoded inputT)) - (function ((~ g!_) [(~+ g!members)]) - ((~! /.json) [(~+ (list#each (function (_ [g!member g!encoded]) - (` ((~ g!encoded) (~ g!member)))) - (list.zipped_2 g!members g!encoders)))])))))) - ... Type recursion - (do ! - [[selfC non_recC] (<type>.recursive encoded) - .let [g! (code.local "____________")]] - (in (` (is (~ (@JSON#encoded inputT)) - ((~! ..rec_encoded) (.function ((~ g!) (~ selfC)) - (~ non_recC))))))) - <type>.recursive_self - ... Type applications - (do ! - [partsC (<type>.applied (<>.many encoded))] - (in (` ((~+ partsC))))) - ... Polymorphism - (do ! - [[funcC varsC bodyC] (<type>.polymorphic encoded)] - (in (` (is (All ((~ g!_) (~+ varsC)) - (-> (~+ (list#each (function (_ varC) (` (-> (~ varC) /.JSON))) - varsC)) - (-> ((~ (poly.code *env* inputT)) (~+ varsC)) - /.JSON))) - (function ((~ funcC) (~+ varsC)) - (~ bodyC)))))) - <type>.parameter - <type>.recursive_call - ... If all else fails... - (<>.failure (format "Cannot create JSON encoder for: " (type.format inputT))) - )))) + (in (` (is (~ (@JSON#encoded inputT)) + ((~! ..nullable) (~ =sub=)))))) + (do ! + [[_ =sub=] (<type>.applied (all <>.and + (<type>.exactly .List) + encoded))] + (in (` (is (~ (@JSON#encoded inputT)) + (|>> ((~! list#each) (~ =sub=)) ((~! sequence.of_list)) {/.#Array}))))) + (do ! + [.let [g!_ (code.local "_______") + g!input (code.local "_______input")] + members (<type>.variant (<>.many encoded)) + .let [last (-- (list.size members))]] + (in (` (is (~ (@JSON#encoded inputT)) + (function ((~ g!_) (~ g!input)) + (case (~ g!input) + (~+ (list#conjoint (list#each (function (_ [tag g!encoded]) + (if (n.= last tag) + (.list (` {(~ (code.nat (-- tag))) #1 (~ g!input)}) + (` ((~! /.json) [(~ (code.frac (..tag (-- tag)))) + #1 + ((~ g!encoded) (~ g!input))]))) + (.list (` {(~ (code.nat tag)) #0 (~ g!input)}) + (` ((~! /.json) [(~ (code.frac (..tag tag))) + #0 + ((~ g!encoded) (~ g!input))]))))) + (list.enumeration members)))))))))) + (do ! + [g!encoders (<type>.tuple (<>.many encoded)) + .let [g!_ (code.local "_______") + g!members (|> (list.size g!encoders) + list.indices + (list#each (|>> n#encoded code.local)))]] + (in (` (is (~ (@JSON#encoded inputT)) + (function ((~ g!_) [(~+ g!members)]) + ((~! /.json) [(~+ (list#each (function (_ [g!member g!encoded]) + (` ((~ g!encoded) (~ g!member)))) + (list.zipped_2 g!members g!encoders)))])))))) + ... Type recursion + (do ! + [[selfC non_recC] (<type>.recursive encoded) + .let [g! (code.local "____________")]] + (in (` (is (~ (@JSON#encoded inputT)) + ((~! ..rec_encoded) (.function ((~ g!) (~ selfC)) + (~ non_recC))))))) + <type>.recursive_self + ... Type applications + (do ! + [partsC (<type>.applied (<>.many encoded))] + (in (` ((~+ partsC))))) + ... Polymorphism + (do ! + [[funcC varsC bodyC] (<type>.polymorphic encoded)] + (in (` (is (All ((~ g!_) (~+ varsC)) + (-> (~+ (list#each (function (_ varC) (` (-> (~ varC) /.JSON))) + varsC)) + (-> ((~ (poly.code *env* inputT)) (~+ varsC)) + /.JSON))) + (function ((~ funcC) (~+ varsC)) + (~ bodyC)))))) + <type>.parameter + <type>.recursive_call + ... If all else fails... + (<>.failure (format "Cannot create JSON encoder for: " (type.format inputT))) + ))))) -(poly: decoded - (with_expansions - [<basic> (with_template [<matcher> <decoder>] - [(do ! - [_ <matcher>] - (in (` (is (~ (@JSON#decoded inputT)) - (~! <decoder>)))))] +(def: decoded + (polytypic decoded + (with_expansions + [<basic> (with_template [<matcher> <decoder>] + [(do ! + [_ <matcher>] + (in (` (is (~ (@JSON#decoded inputT)) + (~! <decoder>)))))] - [(<type>.exactly Any) </>.null] - [(<type>.sub Bit) </>.boolean] - [(<type>.sub Nat) (<>.codec ..nat_codec </>.any)] - [(<type>.sub Int) (<>.codec ..int_codec </>.any)] - [(<type>.sub Frac) </>.number] - [(<type>.sub Text) </>.string]) - <time> (with_template [<type> <codec>] - [(do ! - [_ (<type>.exactly <type>)] - (in (` (is (~ (@JSON#decoded inputT)) - ((~! <>.codec) (~! <codec>) (~! </>.string))))))] + [(<type>.exactly Any) </>.null] + [(<type>.sub Bit) </>.boolean] + [(<type>.sub Nat) (<>.codec ..nat_codec </>.any)] + [(<type>.sub Int) (<>.codec ..int_codec </>.any)] + [(<type>.sub Frac) </>.number] + [(<type>.sub Text) </>.string]) + <time> (with_template [<type> <codec>] + [(do ! + [_ (<type>.exactly <type>)] + (in (` (is (~ (@JSON#decoded inputT)) + ((~! <>.codec) (~! <codec>) (~! </>.string))))))] - ... [duration.Duration duration.codec] - ... [instant.Instant instant.codec] - [date.Date date.codec] - [day.Day day.codec] - [month.Month month.codec])] - (do [! <>.monad] - [*env* <type>.env - .let [g!_ (code.local "_______") - @JSON#decoded (is (-> Type Code) - (function (_ type) - (` (</>.Parser (~ (poly.code *env* type))))))] - inputT <type>.next] - (all <>.either - <basic> - <time> - (do ! - [unitT (<type>.applied (<>.after (<type>.exactly unit.Qty) - <type>.any))] - (in (` (is (~ (@JSON#decoded inputT)) - ((~! <>.codec) (~! qty_codec) (~! </>.any)))))) - (do ! - [[_ _ valC] (<type>.applied (all <>.and - (<type>.exactly dictionary.Dictionary) - (<type>.exactly .Text) - decoded))] - (in (` (is (~ (@JSON#decoded inputT)) - ((~! </>.dictionary) (~ valC)))))) - (do ! - [[_ subC] (<type>.applied (<>.and (<type>.exactly .Maybe) - decoded))] - (in (` (is (~ (@JSON#decoded inputT)) - ((~! </>.nullable) (~ subC)))))) - (do ! - [[_ subC] (<type>.applied (<>.and (<type>.exactly .List) - decoded))] - (in (` (is (~ (@JSON#decoded inputT)) - ((~! </>.array) ((~! <>.some) (~ subC))))))) - (do ! - [members (<type>.variant (<>.many decoded)) - .let [last (-- (list.size members))]] - (in (` (is (~ (@JSON#decoded inputT)) - (all ((~! <>.or)) - (~+ (list#each (function (_ [tag memberC]) - (if (n.= last tag) - (` (|> (~ memberC) - ((~! <>.after) ((~! </>.this_boolean) (~ (code.bit #1)))) - ((~! <>.after) ((~! </>.this_number) (~ (code.frac (..tag (-- tag)))))) - ((~! </>.array)))) - (` (|> (~ memberC) - ((~! <>.after) ((~! </>.this_boolean) (~ (code.bit #0)))) - ((~! <>.after) ((~! </>.this_number) (~ (code.frac (..tag tag))))) - ((~! </>.array)))))) - (list.enumeration members)))))))) - (do ! - [g!decoders (<type>.tuple (<>.many decoded))] - (in (` (is (~ (@JSON#decoded inputT)) - ((~! </>.array) (all ((~! <>.and)) (~+ g!decoders))))))) - ... Type recursion - (do ! - [[selfC bodyC] (<type>.recursive decoded) - .let [g! (code.local "____________")]] - (in (` (is (~ (@JSON#decoded inputT)) - ((~! <>.rec) (.function ((~ g!) (~ selfC)) - (~ bodyC))))))) - <type>.recursive_self - ... Type applications - (do ! - [[funcC argsC] (<type>.applied (<>.and decoded (<>.many decoded)))] - (in (` ((~ funcC) (~+ argsC))))) - ... Polymorphism - (do ! - [[funcC varsC bodyC] (<type>.polymorphic decoded)] - (in (` (is (All ((~ g!_) (~+ varsC)) - (-> (~+ (list#each (|>> (~) </>.Parser (`)) varsC)) - (</>.Parser ((~ (poly.code *env* inputT)) (~+ varsC))))) - (function ((~ funcC) (~+ varsC)) - (~ bodyC)))))) - <type>.parameter - <type>.recursive_call - ... If all else fails... - (<>.failure (format "Cannot create JSON decoder for: " (type.format inputT))) - )))) + ... [duration.Duration duration.codec] + ... [instant.Instant instant.codec] + [date.Date date.codec] + [day.Day day.codec] + [month.Month month.codec])] + (do [! <>.monad] + [*env* <type>.env + .let [g!_ (code.local "_______") + @JSON#decoded (is (-> Type Code) + (function (_ type) + (` (</>.Parser (~ (poly.code *env* type))))))] + inputT <type>.next] + (all <>.either + <basic> + <time> + (do ! + [unitT (<type>.applied (<>.after (<type>.exactly unit.Qty) + <type>.any))] + (in (` (is (~ (@JSON#decoded inputT)) + ((~! <>.codec) (~! qty_codec) (~! </>.any)))))) + (do ! + [[_ _ valC] (<type>.applied (all <>.and + (<type>.exactly dictionary.Dictionary) + (<type>.exactly .Text) + decoded))] + (in (` (is (~ (@JSON#decoded inputT)) + ((~! </>.dictionary) (~ valC)))))) + (do ! + [[_ subC] (<type>.applied (<>.and (<type>.exactly .Maybe) + decoded))] + (in (` (is (~ (@JSON#decoded inputT)) + ((~! </>.nullable) (~ subC)))))) + (do ! + [[_ subC] (<type>.applied (<>.and (<type>.exactly .List) + decoded))] + (in (` (is (~ (@JSON#decoded inputT)) + ((~! </>.array) ((~! <>.some) (~ subC))))))) + (do ! + [members (<type>.variant (<>.many decoded)) + .let [last (-- (list.size members))]] + (in (` (is (~ (@JSON#decoded inputT)) + (all ((~! <>.or)) + (~+ (list#each (function (_ [tag memberC]) + (if (n.= last tag) + (` (|> (~ memberC) + ((~! <>.after) ((~! </>.this_boolean) (~ (code.bit #1)))) + ((~! <>.after) ((~! </>.this_number) (~ (code.frac (..tag (-- tag)))))) + ((~! </>.array)))) + (` (|> (~ memberC) + ((~! <>.after) ((~! </>.this_boolean) (~ (code.bit #0)))) + ((~! <>.after) ((~! </>.this_number) (~ (code.frac (..tag tag))))) + ((~! </>.array)))))) + (list.enumeration members)))))))) + (do ! + [g!decoders (<type>.tuple (<>.many decoded))] + (in (` (is (~ (@JSON#decoded inputT)) + ((~! </>.array) (all ((~! <>.and)) (~+ g!decoders))))))) + ... Type recursion + (do ! + [[selfC bodyC] (<type>.recursive decoded) + .let [g! (code.local "____________")]] + (in (` (is (~ (@JSON#decoded inputT)) + ((~! <>.rec) (.function ((~ g!) (~ selfC)) + (~ bodyC))))))) + <type>.recursive_self + ... Type applications + (do ! + [[funcC argsC] (<type>.applied (<>.and decoded (<>.many decoded)))] + (in (` ((~ funcC) (~+ argsC))))) + ... Polymorphism + (do ! + [[funcC varsC bodyC] (<type>.polymorphic decoded)] + (in (` (is (All ((~ g!_) (~+ varsC)) + (-> (~+ (list#each (|>> (~) </>.Parser (`)) varsC)) + (</>.Parser ((~ (poly.code *env* inputT)) (~+ varsC))))) + (function ((~ funcC) (~+ varsC)) + (~ bodyC)))))) + <type>.parameter + <type>.recursive_call + ... If all else fails... + (<>.failure (format "Cannot create JSON decoder for: " (type.format inputT))) + ))))) (def: .public codec (syntax (_ [inputT <code>.any]) diff --git a/stdlib/source/test/lux/ffi.jvm.lux b/stdlib/source/test/lux/ffi.jvm.lux index e2f50a5e6..146fb5683 100644 --- a/stdlib/source/test/lux/ffi.jvm.lux +++ b/stdlib/source/test/lux/ffi.jvm.lux @@ -198,7 +198,7 @@ /.null? not))) (~~ (with_template [<object> <primitive> <jvm#value> <jvm#=> - <lux#value> <as> <of> <lux#=>] + <lux#value> <as> <of> <lux#=>] [(_.coverage [<object> <primitive>] (|> <jvm#value> (is <object>) @@ -262,35 +262,35 @@ (type#= /.Character (/.type char))))) )))) -(/.interface: test/TestInterface0 +(/.interface test/TestInterface0 ([] actual0 [] java/lang/Long)) (/.import test/TestInterface0 "[1]::[0]" (actual0 [] java/lang/Long)) -(/.interface: test/TestInterface1 +(/.interface test/TestInterface1 ([] actual1 [java/lang/Boolean] java/lang/Long "throws" [java/lang/Throwable])) (/.import test/TestInterface1 "[1]::[0]" (actual1 [java/lang/Boolean] "try" java/lang/Long)) -(/.interface: test/TestInterface2 +(/.interface test/TestInterface2 ([a] actual2 [a] a)) (/.import test/TestInterface2 "[1]::[0]" ([a] actual2 [a] a)) -(/.interface: (test/TestInterface3 a) +(/.interface (test/TestInterface3 a) ([] actual3 [] a)) (/.import (test/TestInterface3 a) "[1]::[0]" (actual3 [] a)) -(/.interface: test/TestInterface4 +(/.interface test/TestInterface4 ([] actual4 [long long] long)) (/.import test/TestInterface4 @@ -369,7 +369,7 @@ (/.of_long actual_right)))))] (i.= expected (/.of_long (test/TestInterface4::actual4 left right object/4))))]] - (_.coverage [/.interface: /.object] + (_.coverage [/.interface /.object] (and example/0! example/1! example/2! diff --git a/stdlib/source/test/lux/ffi.old.lux b/stdlib/source/test/lux/ffi.old.lux index 542c03d34..b00020c6c 100644 --- a/stdlib/source/test/lux/ffi.old.lux +++ b/stdlib/source/test/lux/ffi.old.lux @@ -60,7 +60,7 @@ (upC [] void) (downC [] void)) -(/.interface: TestInterface +(/.interface TestInterface ([] current [] java/lang/Long "throws" [java/lang/Exception]) ([] up [] test/lux/ffi/TestInterface "throws" [java/lang/Exception]) ([] down [] test/lux/ffi/TestInterface "throws" [java/lang/Exception])) @@ -219,7 +219,7 @@ (test/lux/ffi/TestClass::downC)) test/lux/ffi/TestClass::currentC (i.= (i.+ increase counter)))) - (_.coverage [/.interface: /.object] + (_.coverage [/.interface /.object] (|> (..test_object increase counter) test/lux/ffi/TestInterface::up test/lux/ffi/TestInterface::up |