diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/error/exception.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/json.lux | 70 | ||||
| -rw-r--r-- | stdlib/source/lux/data/struct/vector.lux | 15 | ||||
| -rw-r--r-- | stdlib/source/lux/lexer.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 44 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/syntax/common.lux | 27 | ||||
| -rw-r--r-- | stdlib/source/lux/math/random.lux | 10 | ||||
| -rw-r--r-- | stdlib/source/lux/type.lux | 97 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/error/exception.lux | 50 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/format/json.lux | 402 | ||||
| -rw-r--r-- | stdlib/test/test/lux/data/struct/vector.lux | 19 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 4 |
12 files changed, 308 insertions, 434 deletions
diff --git a/stdlib/source/lux/data/error/exception.lux b/stdlib/source/lux/data/error/exception.lux index be9a09327..c3e9143e2 100644 --- a/stdlib/source/lux/data/error/exception.lux +++ b/stdlib/source/lux/data/error/exception.lux @@ -35,7 +35,7 @@ (#;Right (then error)) (#;Left error)))) -(def: #export (else to-do try) +(def: #export (otherwise to-do try) (All [a] (-> (-> Text a) (Error a) a)) (case try diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index c51e4b04c..d48b5b97a 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -67,8 +67,8 @@ wrapper (lambda [x] (` (;;json (~ x))))] (case token (^template [<ast-tag> <ctor> <json-tag>] - [_ (<ast-tag> value)] - (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value)))))))) + [_ (<ast-tag> value)] + (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value)))))))) ([#;BoolS ast;bool #Boolean] [#;IntS (|>. int-to-real ast;real) #Number] [#;RealS ast;real #Number] @@ -109,7 +109,7 @@ (def: (show-array show-json elems) (-> (-> JSON Text) (-> Array Text)) (format "[" - (|> elems (Vector/map show-json) vector;vector-to-list (text;join-with ",")) + (|> elems (Vector/map show-json) vector;to-list (text;join-with ",")) "]")) (def: (show-object show-json object) @@ -125,8 +125,8 @@ (-> JSON Text) (case json (^template [<tag> <show>] - (<tag> value) - (<show> value)) + (<tag> value) + (<show> value)) ([#Null show-null] [#Boolean show-boolean] [#Number show-number] @@ -316,7 +316,7 @@ _ (lexer;this-char <close>)] (wrap (<prep> elems))))] - [array~ Array #"[" #"]" (json~ []) vector;list-to-vector] + [array~ Array #"[" #"]" (json~ []) vector;from-list] [object~ Object #"{" #"}" (kv~ json~) (dict;from-list text;Hash<Text>)] ) @@ -485,7 +485,7 @@ (case json (#Array values) (do Monad<Error> - [elems (mapM @ parser (vector;vector-to-list values))] + [elems (mapM @ parser (vector;to-list values))] (wrap elems)) _ @@ -631,8 +631,8 @@ true (^template [<tag> <struct>] - [(<tag> x') (<tag> y')] - (:: <struct> = x' y')) + [(<tag> x') (<tag> y')] + (:: <struct> = x' y')) ([#Boolean bool;Eq<Bool>] [#Number number;Eq<Real>] [#String text;Eq<Text>]) @@ -719,18 +719,18 @@ (All [a b] (-> (-> a b) (List a) (List b))) List/map) -(poly: #export (|Codec@JSON//encode| *env* :x:) +(poly: #export (Codec<JSON,?>//encode *env* :x:) (let [->Codec//encode (: (-> AST AST) (lambda [.type.] (` (-> (~ .type.) JSON))))] (let% [<basic> (do-template [<type> <matcher> <encoder>] [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))] [Unit poly;unit (lambda [(~ (ast;symbol ["" "0"]))] #Null)] - [Bool poly;bool ;;boolean] - [Int poly;int (|>. int-to-real ;;number)] - [Real poly;real ;;number] - [Char poly;char (|>. char;->Text ;;string)] - [Text poly;text ;;string])] + [Bool poly;bool ;;gen-boolean] + [Int poly;int (|>. ;int-to-real ;;gen-number)] + [Real poly;real ;;gen-number] + [Char poly;char (|>. char;as-text ;;gen-string)] + [Text poly;text ;;gen-string])] ($_ compiler;either <basic> (with-gensyms [g!type-fun g!case g!input g!key g!val] @@ -745,7 +745,7 @@ _ (compiler;fail "")) #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] - .val. (|Codec@JSON//encode| new-*env* :val:) + .val. (Codec<JSON,?>//encode new-*env* :val:) #let [:x:+ (case g!vars #;Nil (->Codec//encode (type;type-to-ast :x:)) @@ -767,14 +767,14 @@ )) (do @ [:sub: (poly;maybe :x:) - .sub. (|Codec@JSON//encode| *env* :sub:)] + .sub. (Codec<JSON,?>//encode *env* :sub:)] (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:))) - (;;nullable (~ .sub.)))))) + (;;gen-nullable (~ .sub.)))))) (do @ [:sub: (poly;list :x:) - .sub. (|Codec@JSON//encode| *env* :sub:)] + .sub. (Codec<JSON,?>//encode *env* :sub:)] (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:))) - (|>. (_map_ (~ .sub.)) vector;list-to-vector ;;array))))) + (|>. (_map_ (~ .sub.)) vector;from-list ;;gen-array))))) (with-gensyms [g!type-fun g!case g!input] (do @ [[g!vars cases] (poly;variant :x:) @@ -783,7 +783,7 @@ (lambda [[name :case:]] (do @ [#let [tag (ast;tag name)] - encoder (|Codec@JSON//encode| new-*env* :case:)] + encoder (Codec<JSON,?>//encode new-*env* :case:)] (wrap (list (` ((~ tag) (~ g!case))) (` (;;json [(~ (ast;text (product;right name))) ((~ encoder) (~ g!case))])))))) @@ -808,7 +808,7 @@ synthesis (mapM @ (lambda [[name :slot:]] (do @ - [encoder (|Codec@JSON//encode| new-*env* :slot:)] + [encoder (Codec<JSON,?>//encode new-*env* :slot:)] (wrap [(` (~ (ast;text (product;right name)))) (` ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))]))) slots) @@ -824,7 +824,7 @@ (lambda [(~@ g!vars) (~ g!input)] (;;json (~ (ast;record synthesis)))) ))))) - (with-gensyms [g!type-fun g!case g!input] + (with-gensyms [g!type-fun g!case] (do @ [[g!vars members] (poly;tuple :x:) #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)] @@ -832,7 +832,7 @@ (lambda [:member:] (do @ [g!member (compiler;gensym "g!member") - encoder (|Codec@JSON//encode| new-*env* :member:)] + encoder (Codec<JSON,?>//encode new-*env* :member:)] (wrap [g!member encoder]))) members) #let [:x:+ (case g!vars @@ -845,18 +845,16 @@ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))] #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]] (wrap (` (: (~ :x:+) - (lambda [(~@ g!vars) (~ g!input)] - (case (~ g!input) - (~ .tuple.) - (;;array (list (~@ (List/map (lambda [[g!member g!encoder]] - (` ((~ g!encoder) (~ g!member)))) - pattern-matching)))))) + (lambda [(~@ g!vars) (~ .tuple.)] + (;;json [(~@ (List/map (lambda [[g!member g!encoder]] + (` ((~ g!encoder) (~ g!member)))) + pattern-matching))])) ))) )) (do @ [[:func: :args:] (poly;apply :x:) - .func. (|Codec@JSON//encode| *env* :func:) - .args. (mapM @ (|Codec@JSON//encode| *env*) :args:)] + .func. (Codec<JSON,?>//encode *env* :func:) + .args. (mapM @ (Codec<JSON,?>//encode *env*) :args:)] (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:))) ((~ .func.) (~@ .args.)))))) (poly;bound *env* :x:) @@ -869,7 +867,7 @@ (let% [<basic> (do-template [<type> <matcher> <decoder>] [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))] - [Unit poly;unit ;;null] + [Unit poly;unit ;;unit] [Bool poly;bool ;;bool] [Int poly;int ;;int] [Real poly;real ;;real] @@ -931,8 +929,8 @@ [#let [tag (ast;tag name)] decoder (Codec<JSON,?>//decode new-*env* :case:)] (wrap (list (` (do Monad<Parser> - [(~ g!_) (;;at 0 (;;text! (~ (ast;text (product;right name))))) - (~ g!_) (;;at 1 (~ decoder))] + [(~ g!_) (;;at +0 (;;text! (~ (ast;text (product;right name))))) + (~ g!_) (;;at +1 (~ decoder))] ((~ (' wrap)) ((~ tag) (~ g!_))))))))) cases) #let [:x:+ (case g!vars @@ -1026,6 +1024,6 @@ (syntax: #export (Codec<JSON,?> :x:) (wrap (list (` (: (Codec JSON (~ :x:)) (struct - (def: (~ (' encode)) (|Codec@JSON//encode| (~ :x:))) + (def: (~ (' encode)) (Codec<JSON,?>//encode (~ :x:))) (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:))) )))))) diff --git a/stdlib/source/lux/data/struct/vector.lux b/stdlib/source/lux/data/struct/vector.lux index 4b8fb4bf3..9c04bc173 100644 --- a/stdlib/source/lux/data/struct/vector.lux +++ b/stdlib/source/lux/data/struct/vector.lux @@ -365,12 +365,11 @@ (struct: #export (Eq<Vector> Eq<a>) (All [a] (-> (Eq a) (Eq (Vector a)))) (def: (= v1 v2) (and (=+ (get@ #size v1) (get@ #size v2)) - (:: (Eq<Node> Eq<a>) = - (#Base (get@ #tail v1)) - (#Base (get@ #tail v2))) - (:: (Eq<Node> Eq<a>) = - (#Hierarchy (get@ #root v1)) - (#Hierarchy (get@ #root v2)))))) + (let [(^open "Node/") (Eq<Node> Eq<a>)] + (and (Node/= (#Base (get@ #tail v1)) + (#Base (get@ #tail v2))) + (Node/= (#Hierarchy (get@ #root v1)) + (#Hierarchy (get@ #root v2)))))))) (struct: _ (Fold Node) (def: (fold f init xs) @@ -436,9 +435,9 @@ (struct: #export _ (Monad Vector) (def: applicative Applicative<Vector>) - (def: (join ffa) + (def: join (let [(^open) Functor<Vector> (^open) Fold<Vector> (^open) Monoid<Vector>] - (fold append unit ffa))) + (fold append unit))) ) diff --git a/stdlib/source/lux/lexer.lux b/stdlib/source/lux/lexer.lux index 654259d8d..77ce0ce93 100644 --- a/stdlib/source/lux/lexer.lux +++ b/stdlib/source/lux/lexer.lux @@ -4,7 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;module: - [lux #- not] + [lux #- not default] (lux (control functor applicative monad diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index ac7043f26..914575cc0 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -9,7 +9,7 @@ [eq]) (data [text] text/format - (struct [list "List/" Monad<List>] + (struct [list "List/" Fold<List> Monad<List>] [dict #+ Dict]) [number] [product] @@ -140,7 +140,7 @@ _ (:: compiler;Monad<Lux> wrap [(;list) :type:]))))) -(do-template [<combinator> <sub-comb>] +(do-template [<combinator> <sub-comb> <build>] [(def: #export <combinator> (Matcher [(List AST) (List [Ident Type])]) (lambda [:type:] @@ -148,11 +148,17 @@ [[tags :type:] (tagged :type:) _ (compiler;assert (>+ +0 (list;size tags)) "Records and variants must have tags.") [vars :type:] (polymorphic :type:) - members (<sub-comb> :type:)] - (wrap [vars (list;zip2 tags members)]))))] - - [variant sum+] - [record prod+] + members (<sub-comb> :type:) + #let [num-tags (list;size tags) + [init-tags last-tag] (list;split (dec+ num-tags) tags) + [init-types last-types] (list;split (dec+ num-tags) members)]] + (wrap [vars (list;concat (;list (list;zip2 init-tags init-types) + (;list [(default (undefined) + (list;head last-tag)) + (<build> last-types)])))]))))] + + [variant sum+ type;variant] + [record prod+ type;tuple] ) (def: #export tuple @@ -301,35 +307,21 @@ (def: (common-poly-name? poly-func) (-> Text Bool) - (and (text;starts-with? "|" poly-func) - (text;ends-with? "|" poly-func))) + (text;contains? "?" poly-func)) (def: (derivation-name poly args) (-> Text (List Text) (Maybe Text)) (if (common-poly-name? poly) - (case (text;sub +1 (dec+ (text;size poly)) poly) - (#;Some clean-poly) - (case (list;reverse args) - #;Nil - #;None - - (#;Cons type #;Nil) - (#;Some (format type "/" clean-poly)) - - (#;Cons type args) - (#;Some (format type "/" clean-poly "@" (|> args list;reverse (text;join-with ","))))) - - #;None - #;None) + (#;Some (List/fold (text;replace-once "?") poly args)) #;None)) (syntax: #export (derived: {_ex-lev common;export-level} {?name (s;opt s;local-symbol)} - {[poly-func poly-args] (s;either (s;form (s;seq s;symbol (s;many s;symbol))) - (s;seq s;symbol (:: @ wrap (;list))))} + {[poly-func poly-args] (s;form (s;seq s;symbol (s;many s;symbol)))} {?custom-impl (s;opt s;any)}) (do @ - [name (case ?name + [poly-args (mapM @ compiler;normalize poly-args) + name (case ?name (#;Some name) (wrap name) diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux index 743768fe6..6cec7f713 100644 --- a/stdlib/source/lux/macro/syntax/common.lux +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -7,7 +7,9 @@ lux (lux (control monad) (data (struct [list]) - text/format) + text/format + [ident "Ident/" Eq<Ident>] + [product]) [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]))) @@ -104,18 +106,17 @@ (def: (find-def-args meta-data) (-> (List [Ident AST]) (List Text)) (default (list) - (list;find (lambda [[tag value]] - (case tag - (^=> ["lux" "func-args"] - {(s;run (list value) list-meta^) - (#;Right [_ args])} - {(s;run args (s;some text-meta^)) - (#;Right [_ args])}) - (#;Some args) - - _ - #;None)) - meta-data))) + (case (list;find (|>. product;left (Ident/= ["lux" "func-args"])) meta-data) + (^=> (#;Some [_ value]) + {(s;run (list value) list-meta^) + (#;Right [_ args])} + {(s;run args (s;some text-meta^)) + (#;Right [_ args])}) + (#;Some args) + + _ + #;None) + )) (def: #export (def compiler) (-> Compiler (Syntax Def-Syntax)) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index aee5674ad..41481a284 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -174,6 +174,16 @@ (wrap sample) (filter pred gen)))) +(def: #export (maybe value-gen) + (All [a] (-> (Random a) (Random (Maybe a)))) + (do Monad<Random> + [some? bool] + (if some? + (do @ + [value value-gen] + (wrap (#;Some value))) + (wrap #;None)))) + (do-template [<name> <type> <zero> <plus>] [(def: #export (<name> size value-gen) (All [a] (-> Nat (Random a) (Random (<type> a)))) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index 4a84582c4..fbd269daa 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -22,24 +22,24 @@ (#;HostT name (List/map (beta-reduce env) params)) (^template [<tag>] - (<tag> left right) - (<tag> (beta-reduce env left) (beta-reduce env right))) + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) ([#;SumT] [#;ProdT]) (^template [<tag>] - (<tag> left right) - (<tag> (beta-reduce env left) (beta-reduce env right))) + (<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))) ([#;LambdaT] [#;AppT]) (^template [<tag>] - (<tag> old-env def) - (case old-env - #;Nil - (<tag> env def) + (<tag> old-env def) + (case old-env + #;Nil + (<tag> env def) - _ - type)) + _ + type)) ([#;UnivQ] [#;ExQ]) @@ -65,17 +65,17 @@ (list;zip2 xparams yparams))) (^template [<tag>] - [<tag> <tag>] - true) + [<tag> <tag>] + true) ([#;VoidT] [#;UnitT]) (^template [<tag>] - [(<tag> xid) (<tag> yid)] - (=+ yid xid)) + [(<tag> xid) (<tag> yid)] + (=+ yid xid)) ([#;VarT] [#;ExT] [#;BoundT]) (^or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] - [(#;AppT xleft xright) (#;AppT yleft yright)]) + [(#;AppT xleft xright) (#;AppT yleft yright)]) (and (= xleft yleft) (= xright yright)) @@ -85,12 +85,12 @@ (= xtype ytype)) (^template [<tag>] - [(<tag> xL xR) (<tag> yL yR)] - (and (= xL yL) (= xR yR))) + [(<tag> xL xR) (<tag> yL yR)] + (and (= xL yL) (= xR yR))) ([#;SumT] [#;ProdT]) (^or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] - [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) + [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) (and (=+ (list;size yenv) (list;size xenv)) (= xbody ybody) (List/fold (lambda [[x y] prev] (and prev (= x y))) @@ -140,8 +140,8 @@ (-> Type Type (Maybe Type)) (case type-fun (^template [<tag>] - (<tag> env body) - (#;Some (beta-reduce (list& type-fun param env) body))) + (<tag> env body) + (#;Some (beta-reduce (list& type-fun param env) body))) ([#;UnivQ] [#;ExQ]) (#;AppT F A) @@ -163,24 +163,24 @@ (list (~@ (List/map type-to-ast params))))) (^template [<tag>] - <tag> - (` <tag>)) + <tag> + (` <tag>)) ([#;VoidT] [#;UnitT]) (^template [<tag>] - (<tag> idx) - (` (<tag> (~ (ast;nat idx))))) + (<tag> idx) + (` (<tag> (~ (ast;nat idx))))) ([#;VarT] [#;ExT] [#;BoundT]) (^template [<tag>] - (<tag> left right) - (` (<tag> (~ (type-to-ast left)) - (~ (type-to-ast right))))) + (<tag> left right) + (` (<tag> (~ (type-to-ast left)) + (~ (type-to-ast right))))) ([#;LambdaT] [#;AppT]) (^template [<tag> <macro> <flattener>] - (<tag> left right) - (` (<macro> (~@ (List/map type-to-ast (<flattener> type)))))) + (<tag> left right) + (` (<macro> (~@ (List/map type-to-ast (<flattener> type)))))) ([#;SumT | flatten-sum] [#;ProdT & flatten-prod]) @@ -188,9 +188,9 @@ (ast;symbol name) (^template [<tag>] - (<tag> env body) - (` (<tag> (list (~@ (List/map type-to-ast env))) - (~ (type-to-ast body))))) + (<tag> env body) + (` (<tag> (list (~@ (List/map type-to-ast env))) + (~ (type-to-ast body))))) ([#;UnivQ] [#;ExQ]) )) @@ -212,14 +212,14 @@ "Unit" (^template [<tag> <open> <close> <flatten>] - (<tag> _) - ($_ Text/append <open> - (|> (<flatten> type) - (List/map type-to-text) - list;reverse - (list;interpose " ") - (List/fold Text/append "")) - <close>)) + (<tag> _) + ($_ Text/append <open> + (|> (<flatten> type) + (List/map type-to-text) + list;reverse + (list;interpose " ") + (List/fold Text/append "")) + <close>)) ([#;SumT "(| " ")" flatten-sum] [#;ProdT "[" "]" flatten-prod]) @@ -273,3 +273,20 @@ _ type)) + +(do-template [<name> <base> <ctor>] + [(def: #export (<name> types) + (-> (List Type) Type) + (case types + #;Nil + <base> + + (#;Cons type #;Nil) + type + + (#;Cons type types') + (<ctor> type (<name> types'))))] + + [variant Void #;SumT] + [tuple Unit #;ProdT] + ) diff --git a/stdlib/test/test/lux/data/error/exception.lux b/stdlib/test/test/lux/data/error/exception.lux new file mode 100644 index 000000000..16d09a626 --- /dev/null +++ b/stdlib/test/test/lux/data/error/exception.lux @@ -0,0 +1,50 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (codata [io]) + (control monad) + (data (error ["&" exception #+ exception:]) + [text] + [number]) + (codata function) + (math ["R" random]) + pipe) + lux/test) + +(exception: Some-Exception) + +(exception: Another-Exception) + +(exception: Unknown-Exception) + +(test: "Exceptions" + [should-throw? R;bool + which? R;bool + should-catch? R;bool + default-val R;nat + some-val R;nat + another-val R;nat + otherwise-val R;nat + #let [this-ex (if should-catch? + (if which? + Some-Exception + Another-Exception) + Unknown-Exception) + this-val (if should-throw? + (if should-catch? + (if which? + some-val + another-val) + otherwise-val) + default-val)]] + (assert "Catch and otherwhise handlers can properly handle the flow of exception-handling." + (=+ this-val (|> (if should-throw? + (&;return default-val) + (&;throw this-ex "Uh-oh...")) + (&;catch Some-Exception (lambda [ex] some-val)) + (&;catch Another-Exception (lambda [ex] another-val)) + (&;otherwise (lambda [ex] otherwise-val)))))) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 78b0b1a76..d7c622bd5 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -6,309 +6,121 @@ (;module: lux (lux (codata [io]) - (control monad) + (control monad + codec + eq) (data [text "Text/" Monoid<Text>] text/format error - (format [json #* "JSON/" Eq<JSON> Codec<Text,JSON>]) + [bool] + [char] + [maybe] + [number] + (format ["&" json]) (struct [vector #+ vector] - [dict])) + [dict] + [list])) [compiler #+ with-gensyms] + [macro] (macro [ast] [syntax #+ syntax:] [poly #+ derived:]) - [pipe] + (math ["R" random]) + pipe test) ) -## [Utils] -(syntax: (reads-to-itself expr) - (with-gensyms [g!json g!parsed g!message] - (wrap (list (` (: (Test Unit) - (let [(~ g!json) (~ expr)] - (case (|> (~ g!json) JSON/encode JSON/decode) - (#;Left (~ g!message)) - (fail (~ g!message)) - - (#;Right (~ g!parsed)) - (if (JSON/= (~ g!json) (~ g!parsed)) - (~ (' (:: Monad<Test> wrap []))) - (fail (format "Expression does not parse to itself: " (~ (ast;text (ast;ast-to-text expr))) - "\n\nWhich is: " (|> (~ g!json) JSON/encode) - "\n\nInstead, it parsed to: " (JSON/encode (~ g!parsed)))) - )))) - ))))) - -## [Tests] -## (derived: (Codec<JSON,?> ;Bool)) -## (derived: (Codec<JSON,?> ;Int)) -## (derived: (Codec<JSON,?> ;Real)) -## (derived: (Codec<JSON,?> ;Char)) -## (derived: (Codec<JSON,?> ;Text)) - -## (type: Int-List (List Int)) -## (derived: (Codec<JSON,?> ;;Int-List)) - -## (type: Int-Maybe (Maybe Int)) -## (derived: (Codec<JSON,?> ;;Int-Maybe)) - -## (type: Triple [Bool Int Text]) -## (derived: (Codec<JSON,?> ;;Triple)) - -## (type: User -## {#alive? Bool -## #age Int -## #name Text}) -## (derived: (Codec<JSON,?> ;;User)) - -## (type: Options -## (#One Bool) -## (#Two Int) -## (#Three Text)) -## (derived: (Codec<JSON,?> ;;Options)) - -## (test: "Auto-generated codecs" -## (let% [<tests> (do-template [<input> <output> <codec>] -## [(match <output> -## (|> <input> -## (:: <codec> encode) -## JSON/encode)) -## (match+ <input> -## (should-pass (|> (JSON/decode <output>) -## (pipe;%> Error/Monad -## [(:: <codec> decode)]))))] - -## [true "true" Codec<JSON,Bool>] -## [123 "123.0" Codec<JSON,Int>] -## [123.45 "123.45" Codec<JSON,Real>] -## [#"a" "\"a\"" Codec<JSON,Char>] -## ["yolo" "\"yolo\"" Codec<JSON,Text>] - -## [(#;Cons 1 (#;Cons 2 (#;Cons 3 #;Nil))) "[1.0,2.0,3.0]" Codec<JSON,Int-List>] -## [#;Nil "[]" Codec<JSON,Int-List>] -## [(#;Some 1) "1.0" Codec<JSON,Int-Maybe>] -## [#;None "null" Codec<JSON,Int-Maybe>] -## [[false 456 "lol"] "[false,456.0,\"lol\"]" Codec<JSON,Triple>] -## [{#alive? true #age 25 #name "Eduardo Julian"} -## "{\"alive?\":true,\"age\":25.0,\"name\":\"Eduardo Julian\"}" -## Codec<JSON,User>] -## [(#One true) "[\"One\",true]" Codec<JSON,Options>] -## [(#Two 123) "[\"Two\",123.0]" Codec<JSON,Options>] -## [(#Three "yolo") "[\"Three\",\"yolo\"]" Codec<JSON,Options>] -## )] -## (test-all <tests> -## ))) - -(test: "Basics" - (test-all (match #json;Null - null) - - (match (#json;Boolean true) - (gen-boolean true)) - - (match (#json;Boolean false) - (gen-boolean false)) - - (match (#json;Number 123.45) - (gen-number 123.45)) - - (match (#json;String "YOLO") - (gen-string "YOLO")) - - ## (match (^ (#json;Array (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO")))) - ## (json [(gen-boolean true) (gen-number 123.45) (gen-string "YOLO")])) - - ## (match (^ (#json;Object (list ["yolo" (#json;Boolean true)] - ## ["lol" (#json;Number 123.45)]))) - ## (json {"yolo" (gen-boolean true) - ## "lol" (gen-number 123.45)})) - - (match (#;Some (#json;Boolean true)) - (get "yolo" (json {"yolo" true - "lol" 123.45}))) - - (match (#;Left _) - (get "yolo" (json {}))) - - ## (match (^ (#;Some (#json;Object (list ["lol" (#json;Number 123.45)] - ## ["yolo" (#json;Boolean true)])))) - ## (|> (json {"yolo" (gen-boolean true)}) - ## (set "lol" (gen-number 123.45)))) - - (match (#;Right true) - (get-boolean "value" (json {"value" true}))) - - (match (#;Right 123.45) - (get-number "value" (json {"value" 123.45}))) - - (match (#;Right "YOLO") - (get-string "value" (json {"value" "YOLO"}))) - - ## (match (^ (#;Right (list (#json;Boolean true) (#json;Number 123.45) (#json;String "YOLO")))) - ## (get-array "value" (json {"value" (json [(gen-boolean true) - ## (gen-number 123.45) - ## (gen-string "YOLO")])}))) - - ## (match (^ (#;Right (list ["yolo" (#json;Boolean true)] - ## ["lol" (#json;Number 123.45)]))) - ## (get-object "value" (json {"value" (json {"yolo" (gen-boolean true) - ## "lol" (gen-number 123.45)})}))) - - (match (#;Left _) - (get-array "value" (json {}))) - - (match (#;Left _) - (get-array "value" (gen-boolean true))) - )) - -(test: "Encoding" - (test-all (match "null" - (JSON/encode (json #null))) - - (match "123.0" - (JSON/encode (json 123))) - - (match "123.46" - (JSON/encode (json 123.46))) - - (match "true" - (JSON/encode (json true))) - - (match "false" - (JSON/encode (json false))) - - (match "\"YOLO\"" - (JSON/encode (json "YOLO"))) - - (match "[null,123.46,true,\"YOLO\",[\"nyan\",\"cat\"]]" - (JSON/encode (json [#null 123.46 true "YOLO" ["nyan" "cat"]]))) - - (match "{\"foo\":\"bar\",\"baz\":null,\"quux\":[\"nyan\",{\"cat\":\"meme\"}]}" - (JSON/encode (json {"foo" "bar" - "baz" #null - "quux" ["nyan" {"cat" "meme"}]}))) - )) - -(test: "Decoding" - (test-all (reads-to-itself (json #null)) - (reads-to-itself (json 123)) - (reads-to-itself (json 123.46)) - (reads-to-itself (json true)) - (reads-to-itself (json false)) - (reads-to-itself (json "\tY\"OLO\n")) - (reads-to-itself (json [#null 123.46 true "YOLO" ["nyan" "cat"]])) - (reads-to-itself (json {"foo" "bar" - "baz" #null - "quux" ["nyan" {"cat" "meme"}]})) - )) - -(test: "Parser" - (test-all (should-pass (run unit - (json #null))) - (should-fail (run unit - (json 123))) - - (match+ 123.45 - (should-pass (run real - (json 123.45)))) - (should-fail (run real - (json #null))) - - (match+ 123 - (should-pass (run int - (json 123)))) - (should-fail (run int - (json #null))) - - (match+ true - (should-pass (run bool - (json true)))) - (should-fail (run bool - (json 123))) - - (match+ "YOLO" - (should-pass (run text - (json "YOLO")))) - (should-fail (run text - (json 123))) - - (match+ (^ (list "YOLO" "LOL" "MEME")) - (should-pass (run (array text) - (json ["YOLO" "LOL" "MEME"])))) - (should-fail (run (array text) - (json 123))) - - (match+ "LOL" - (should-pass (run (at +1 text) - (json ["YOLO" "LOL" "MEME"])))) - (should-fail (run (array text) - (json 123))) - - (match+ "MEME" - (should-pass (run (field "baz" text) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - (should-fail (run (field "baz" text) - (json 123))) - - (match+ (#json;Number 123.0) - (should-pass (run any - (json 123)))) - - (match+ ["YOLO" "MEME"] - (should-pass (run (seq (field "foo" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - (should-fail (run (seq (field "foo" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL"}))) - - (match+ (#;Left "YOLO") - (should-pass (run (alt (field "foo" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - (match+ (#;Right "MEME") - (should-pass (run (alt (field "fool" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - (should-fail (run (alt (field "fool" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL"}))) - - (match+ "YOLO" - (should-pass (run (either (field "foo" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - (match+ "MEME" - (should-pass (run (either (field "fool" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - (should-fail (run (either (field "fool" text) - (field "baz" text)) - (json {"foo" "YOLO" - "bar" "LOL"}))) - - (match+ (#;Some "YOLO") - (should-pass (run (opt (field "foo" text)) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - (match+ #;None - (should-pass (run (opt (field "fool" text)) - (json {"foo" "YOLO" - "bar" "LOL" - "baz" "MEME"})))) - )) +(def: gen-json + (R;Random &;JSON) + (R;rec (lambda [gen-json] + (do R;Monad<Random> + [size (:: @ map (%+ +2) R;nat)] + ($_ R;alt + (:: @ wrap []) + R;bool + R;real + (R;text size) + (R;vector size gen-json) + (R;dict text;Hash<Text> size (R;text size) gen-json) + ))))) + +(test: "JSON" + [sample gen-json + #let [(^open "&/") &;Eq<JSON> + (^open "&/") &;Codec<Text,JSON>]] + ($_ seq + (assert "Every JSON is equal to itself." + (&/= sample sample)) + + (assert "Can encode/decode JSON." + (|> sample &/encode &/decode + (case> (#;Right result) + (&/= sample result) + + (#;Left _) + false))) + )) + +(type: Variant + (#Case0 Bool) + (#Case1 Int) + (#Case2 Real)) + +(type: Record + {#unit Unit + #bool Bool + #int Int + #real Real + #char Char + #text Text + #maybe (Maybe Int) + #list (List Int) + #variant Variant + #tuple [Int Real Char]}) + +(def: gen-record + (R;Random Record) + (do R;Monad<Random> + [size (:: @ map (%+ +2) R;nat)] + ($_ R;seq + (:: @ wrap []) + R;bool + R;int + R;real + R;char + (R;text size) + (R;maybe R;int) + (R;list size R;int) + ($_ R;alt R;bool R;int R;real) + ($_ R;seq R;int R;real R;char) + ))) + +(derived: (&;Codec<JSON,?> Record)) + +(struct: _ (Eq Record) + (def: (= recL recR) + (and (:: bool;Eq<Bool> = (get@ #bool recL) (get@ #bool recR)) + (;= (get@ #int recL) (get@ #int recR)) + (=. (get@ #real recL) (get@ #real recR)) + (:: char;Eq<Char> = (get@ #char recL) (get@ #char recR)) + (:: text;Eq<Text> = (get@ #text recL) (get@ #text recR)) + (:: (maybe;Eq<Maybe> number;Eq<Int>) = (get@ #maybe recL) (get@ #maybe recR)) + (:: (list;Eq<List> number;Eq<Int>) = (get@ #list recL) (get@ #list recR)) + (let [[tL0 tL1 tL2] (get@ #tuple recL) + [tR0 tR1 tR2] (get@ #tuple recR)] + (and (;= tL0 tR0) + (=. tL1 tR1) + (:: char;Eq<Char> = tL2 tR2))) + ))) + +(test: "Polytypism" + [sample gen-record + #let [(^open "&/") Eq<Record> + (^open "&/") Codec<JSON,Record>]] + (assert "Can encode/decode arbitrary types." + (|> sample &/encode &/decode + (case> (#;Right result) + (&/= sample result) + + (#;Left _) + false)))) diff --git a/stdlib/test/test/lux/data/struct/vector.lux b/stdlib/test/test/lux/data/struct/vector.lux index 2ccfa2fc1..c3f3a706e 100644 --- a/stdlib/test/test/lux/data/struct/vector.lux +++ b/stdlib/test/test/lux/data/struct/vector.lux @@ -35,10 +35,8 @@ (=+ size (&;size sample)))) (assert "Can add and remove elements to vectors." - (and (=+ (inc+ size) - (&;size (&;add non-member sample))) - (=+ (dec+ size) - (&;size (&;pop sample))))) + (and (=+ (inc+ size) (&;size (&;add non-member sample))) + (=+ (dec+ size) (&;size (&;pop sample))))) (assert "Can put and get elements into vectors." (|> sample @@ -49,16 +47,12 @@ (assert "Can update elements of vectors." (|> sample - (&;put idx non-member) - (&;update idx inc+) - (&;at idx) - (default (undefined)) + (&;put idx non-member) (&;update idx inc+) + (&;at idx) (default (undefined)) (=+ (inc+ non-member)))) (assert "Can safely transform to/from lists." - (|> sample - &;to-list &;from-list - (&/= sample))) + (|> sample &;to-list &;from-list (&/= sample))) (assert "Can identify members of a vector." (and (not (&;member? number;Eq<Nat> sample non-member)) @@ -76,8 +70,7 @@ (assert "Applicative allows you to create singleton vectors, and apply vectors of functions to vectors of values." (and (&/= (&;vector non-member) (&/wrap non-member)) - (&/= (&/map inc+ sample) - (&/apply (&/wrap inc+) sample)))) + (&/= (&/map inc+ sample) (&/apply (&/wrap inc+) sample)))) (assert "Vector concatenation is a monad." (&/= (&/append sample other-sample) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 7b760c0f1..94148e1d7 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -23,7 +23,8 @@ [product] [sum] [text] - [text/format] + (error [exception]) + (format [json]) (struct [array] [dict] [list] @@ -34,6 +35,7 @@ [vector] [zipper] ) + (text [format]) ) ## (codata ["_;" io] ## [env] |