From be0245eed09d242a1fa81a64ce9c3084e8251252 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 12 Dec 2016 01:57:55 -0400 Subject: - Added tests for lux/math/ratio and lux/math/simple. - Some minor refactorings. - Ratios now work with nats instead of ints. --- stdlib/source/lux/compiler.lux | 7 +- stdlib/source/lux/concurrency/actor.lux | 4 +- stdlib/source/lux/data/error.lux | 4 + stdlib/source/lux/data/error/exception.lux | 2 +- stdlib/source/lux/data/format/json.lux | 2 +- stdlib/source/lux/lexer.lux | 2 +- stdlib/source/lux/macro/syntax.lux | 2 +- stdlib/source/lux/math/random.lux | 2 +- stdlib/source/lux/math/ratio.lux | 103 +++++++++++++--------- stdlib/source/lux/math/simple.lux | 134 ++++++++++------------------- stdlib/source/lux/test.lux | 2 +- stdlib/source/lux/type/check.lux | 2 +- 12 files changed, 128 insertions(+), 138 deletions(-) (limited to 'stdlib/source') diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux index d1f71a6c3..fd438b1a3 100644 --- a/stdlib/source/lux/compiler.lux +++ b/stdlib/source/lux/compiler.lux @@ -15,7 +15,7 @@ [product] [ident "Ident/" Codec] maybe - error))) + [error #- fail]))) ## (type: (Lux a) ## (-> Compiler (Error [Compiler a]))) @@ -557,3 +557,8 @@ _ (wrap def-name)))) + +(def: #export get-compiler + (Lux Compiler) + (lambda [compiler] + (#;Right [compiler compiler]))) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index b195a8d6c..a10691b66 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -8,7 +8,7 @@ (lux (control monad) (codata [io #- run] function) - (data error + (data [error #- fail] text/format (struct [list "List/" Monoid Monad]) [product] @@ -126,7 +126,7 @@ (wrap (#;Right new-server)))) )))) #end (lambda [_ server] (exec (io;run (poison server)) - (:: Monad wrap [])))})))] + (:: Monad wrap [])))})))] (update@ #obituary (: (-> (promise;Promise [(Maybe Text) (Actor ($ +0) ($ +1)) (List ($ +1))]) (promise;Promise [(Maybe Text) ($ +0) (List ($ +1))])) (lambda [process] diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/error.lux index ce2f529b9..235eee147 100644 --- a/stdlib/source/lux/data/error.lux +++ b/stdlib/source/lux/data/error.lux @@ -64,3 +64,7 @@ (def: #export (lift-error Monad) (All [M a] (-> (Monad M) (-> (M a) (M (Error a))))) (liftM Monad (:: Monad wrap))) + +(def: #export (fail message) + (All [a] (-> Text (Error a))) + (#;Left message)) diff --git a/stdlib/source/lux/data/error/exception.lux b/stdlib/source/lux/data/error/exception.lux index c3e9143e2..e476357ca 100644 --- a/stdlib/source/lux/data/error/exception.lux +++ b/stdlib/source/lux/data/error/exception.lux @@ -6,7 +6,7 @@ (;module: lux (lux (control monad) - (data error + (data [error #- fail] [text]) [compiler] (macro [ast] diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 675aabfde..aa469beb5 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -16,7 +16,7 @@ [number #* "Real/" Codec] maybe [char "Char/" Eq Codec] - error + [error #- fail] [sum] [product] (struct [list "" Fold "List/" Monad] diff --git a/stdlib/source/lux/lexer.lux b/stdlib/source/lux/lexer.lux index ee364d819..6d54f2614 100644 --- a/stdlib/source/lux/lexer.lux +++ b/stdlib/source/lux/lexer.lux @@ -15,7 +15,7 @@ [product] [char "Char/" Ord] maybe - error + [error #- fail] (struct [list "" Functor])) host)) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index bd8c755d3..e2689aeb5 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -17,7 +17,7 @@ [ident] (struct [list #* "" Functor Fold "List/" Monoid]) [product] - error)) + [error #- fail])) (.. [ast])) ## [Utils] diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 9fe4f4fd6..0a76f3365 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -129,7 +129,7 @@ right ] (wrap ( left right))))] - [ratio r;Ratio r;ratio int] + [ratio r;Ratio r;ratio nat] [complex c;Complex c;complex real] ) diff --git a/stdlib/source/lux/math/ratio.lux b/stdlib/source/lux/math/ratio.lux index c2c9e7183..1baa9a206 100644 --- a/stdlib/source/lux/math/ratio.lux +++ b/stdlib/source/lux/math/ratio.lux @@ -11,89 +11,95 @@ number codec monad) - (data [number "i:" Number Codec] + (data [number "n/" Number Codec] [text "Text/" Monoid] - error) + error + [product]) [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]))) (type: #export Ratio - {#numerator Int - #denominator Int}) + {#numerator Nat + #denominator Nat}) (def: #hidden (normalize (^slots [#numerator #denominator])) (-> Ratio Ratio) - (let [common (nat-to-int (math;gcd (int-to-nat (i:abs numerator)) - (int-to-nat (i:abs denominator)))) - numerator (i./ common numerator) - denominator (i./ common denominator)] - {#numerator (if (and (i.< 0 numerator) - (i.< 0 denominator)) - (i:abs numerator) - numerator) - #denominator (i:abs denominator)})) + (let [common (math;gcd numerator denominator)] + {#numerator (n./ common numerator) + #denominator (n./ common denominator)})) (def: #export (q.* param input) (-> Ratio Ratio Ratio) - (normalize [(i.* (get@ #numerator param) + (normalize [(n.* (get@ #numerator param) (get@ #numerator input)) - (i.* (get@ #denominator param) + (n.* (get@ #denominator param) (get@ #denominator input))])) (def: #export (q./ param input) (-> Ratio Ratio Ratio) - (normalize [(i.* (get@ #denominator param) + (normalize [(n.* (get@ #denominator param) (get@ #numerator input)) - (i.* (get@ #numerator param) + (n.* (get@ #numerator param) (get@ #denominator input))])) (def: #export (q.+ param input) (-> Ratio Ratio Ratio) - (normalize [(i.+ (i.* (get@ #denominator input) + (normalize [(n.+ (n.* (get@ #denominator input) (get@ #numerator param)) - (i.* (get@ #denominator param) + (n.* (get@ #denominator param) (get@ #numerator input))) - (i.* (get@ #denominator param) + (n.* (get@ #denominator param) (get@ #denominator input))])) (def: #export (q.- param input) (-> Ratio Ratio Ratio) - (normalize [(i.- (i.* (get@ #denominator input) + (normalize [(n.- (n.* (get@ #denominator input) (get@ #numerator param)) - (i.* (get@ #denominator param) + (n.* (get@ #denominator param) (get@ #numerator input))) - (i.* (get@ #denominator param) + (n.* (get@ #denominator param) (get@ #denominator input))])) (def: #export (q.% param input) (-> Ratio Ratio Ratio) - (let [quot (i./ (i.* (get@ #denominator input) + (let [quot (n./ (n.* (get@ #denominator input) (get@ #numerator param)) - (i.* (get@ #denominator param) + (n.* (get@ #denominator param) (get@ #numerator input)))] - (q.- (update@ #numerator (i.* quot) param) + (q.- (update@ #numerator (n.* quot) param) input))) (def: #export (q.= param input) (-> Ratio Ratio Bool) - (and (i.= (get@ #numerator param) + (and (n.= (get@ #numerator param) (get@ #numerator input)) - (i.= (get@ #denominator param) + (n.= (get@ #denominator param) (get@ #denominator input)))) (do-template [ ] [(def: #export ( param input) (-> Ratio Ratio Bool) - (and ( (i.* (get@ #denominator input) + (and ( (n.* (get@ #denominator input) (get@ #numerator param)) - (i.* (get@ #denominator param) + (n.* (get@ #denominator param) (get@ #numerator input)))))] - [q.< i.<] - [q.<= i.<=] - [q.> i.>] - [q.>= i.>=] + [q.< n.<] + [q.<= n.<=] + [q.> n.>] + [q.>= n.>=] + ) + +(do-template [ ] + [(def: #export ( left right) + (-> Ratio Ratio Ratio) + (if ( left right) + right + left))] + + [q.min q.<] + [q.max q.>] ) (struct: #export _ (Eq Ratio) @@ -113,24 +119,39 @@ (def: * q.*) (def: / q./) (def: % q.%) - (def: negate (|>. (update@ #numerator i:negate) normalize)) - (def: abs (|>. (update@ #numerator i:abs) (update@ #denominator i:abs))) + (def: (negate (^slots [#numerator #denominator])) + {#numerator denominator + #denominator numerator}) + (def: abs id) (def: (signum x) - {#numerator (i:signum (get@ #numerator x)) - #denominator 1})) + {#numerator +1 + #denominator +1})) (def: separator Text ":") +(def: part-encode + (-> Nat Text) + (|>. n/encode (text;split +1) (default (undefined)) product;right)) + +(def: (part-decode part) + (-> Text (Error Nat)) + (case (text;split-with "+" part) + (#;Some [_ part]) + (n/decode part) + + _ + (fail "Invalid format for ratio part."))) + (struct: #export _ (Codec Text Ratio) (def: (encode (^slots [#numerator #denominator])) - ($_ Text/append (i:encode numerator) separator (i:encode denominator))) + ($_ Text/append (part-encode numerator) separator (part-encode denominator))) (def: (decode input) (case (text;split-with separator input) (#;Some [num denom]) (do Monad - [numerator (i:decode num) - denominator (i:decode denom)] + [numerator (part-decode num) + denominator (part-decode denom)] (wrap (normalize {#numerator numerator #denominator denominator}))) diff --git a/stdlib/source/lux/math/simple.lux b/stdlib/source/lux/math/simple.lux index f6adbc162..9b6e70fbc 100644 --- a/stdlib/source/lux/math/simple.lux +++ b/stdlib/source/lux/math/simple.lux @@ -6,13 +6,46 @@ (;module: lux (lux (control monad) - (data text/format) + (data text/format + [product] + (struct [list])) [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]) [type] (type [check]))) +(def: (find-type-var id env) + (-> Nat (Bindings Nat (Maybe Type)) (Lux Type)) + (case (list;find (|>. product;left (n.= id)) + (get@ #;mappings env)) + (#;Some [_ (#;Some type)]) + (case type + (#;VarT id') + (find-type-var id' env) + + _ + (:: compiler;Monad wrap type)) + + (#;Some [_ #;None]) + (compiler;fail (format "Unbound type-var " (%n id))) + + #;None + (compiler;fail (format "Unknown type-var " (%n id))) + )) + +(def: (resolve-type var-name) + (-> Ident (Lux Type)) + (do compiler;Monad + [raw-type (compiler;find-type var-name) + compiler compiler;get-compiler] + (case raw-type + (#;VarT id) + (find-type-var id (get@ #;type-vars compiler)) + + _ + (wrap raw-type)))) + (do-template [ ] [(syntax: #export ( {args ($_ s;alt (s;seq s;symbol s;symbol) @@ -23,8 +56,8 @@ (case args (+0 [x y]) (do @ - [=x (compiler;find-type x) - =y (compiler;find-type y) + [=x (resolve-type x) + =y (resolve-type y) op (cond (and (check;checks? Nat =x) (check;checks? Nat =y)) (wrap (` )) @@ -54,7 +87,7 @@ (+2 x) (do @ - [=x (compiler;find-type x) + [=x (resolve-type x) op (cond (check;checks? Nat =x) (wrap (` )) @@ -100,85 +133,12 @@ [* ;;* n.* i.* r.* f.*] [/ ;;/ n./ i./ r./ f./] [% ;;% n.% i.% r.% f.%] - ) - -(do-template [ ] - [(syntax: #export ( {args ($_ s;alt - (s;seq s;symbol s;symbol) - (s;seq s;any s;any) - s;symbol - s;any - s;end)}) - (case args - (+0 [x y]) - (do @ - [=x (compiler;find-type x) - =y (compiler;find-type y) - op (cond (and (check;checks? Nat =x) - (check;checks? Nat =y)) - (wrap (` )) - - (and (check;checks? Int =x) - (check;checks? Int =y)) - (wrap (` )) - - (and (check;checks? Real =x) - (check;checks? Real =y)) - (wrap (` )) - - (compiler;fail (format "No operation for types: " (%type =x) " and " (%type =y))))] - (wrap (list (` ((~ op) (~ (ast;symbol x)) (~ (ast;symbol y))))))) - - (+1 [x y]) - (do @ - [g!x (compiler;gensym "g!x") - g!y (compiler;gensym "g!y")] - (wrap (list (` (let [(~ g!x) (~ x) - (~ g!y) (~ y)] - ( (~ g!x) (~ g!y))))))) - - (+2 x) - (do @ - [=x (compiler;find-type x) - op (cond (check;checks? Nat =x) - (wrap (` )) - - (check;checks? Int =x) - (wrap (` )) - - (check;checks? Real =x) - (wrap (` )) - - (compiler;fail (format "No operation for type: " (%type =x))))] - (wrap (list (` ((~ op) (~ (ast;symbol x))))))) - - (+3 x) - (do @ - [g!x (compiler;gensym "g!x")] - (wrap (list (` (let [(~ g!x) (~ x)] - ( (~ g!x))))))) - - (+4 []) - (do @ - [=e compiler;expected-type - op (cond (check;checks? (-> Nat Nat Nat) =e) - (wrap (` )) - - (check;checks? (-> Int Int Int) =e) - (wrap (` )) - - (check;checks? (-> Real Real Real) =e) - (wrap (` )) - - (compiler;fail (format "No operation for type: " (%type =e))))] - (wrap (list op))) - ))] - [= ;;= n.= i.= r.=] - [< ;;< n.< i.< r.<] - [<= ;;<= n.<= i.<= r.<=] - [> ;;> n.> i.> r.>] - [>= ;;>= n.>= i.>= r.>=] + [= ;;= n.= i.= r.= f.=] + [< ;;< n.< i.< r.< f.<] + [<= ;;<= n.<= i.<= r.<= f.<=] + [> ;;> n.> i.> r.> f.>] + [>= ;;>= n.>= i.>= r.>= f.>=] ) (do-template [ ] @@ -191,8 +151,8 @@ (case args (+0 [x y]) (do @ - [=x (compiler;find-type x) - =y (compiler;find-type y) + [=x (resolve-type x) + =y (resolve-type y) op (cond (and (check;checks? Nat =x) (check;checks? Nat =y)) (wrap (` )) @@ -214,7 +174,7 @@ (+2 x) (do @ - [=x (compiler;find-type x) + [=x (resolve-type x) op (cond (check;checks? Nat =x) (wrap (` )) @@ -255,7 +215,7 @@ (case args (+0 x) (do @ - [=x (compiler;find-type x) + [=x (resolve-type x) op (cond (check;checks? Nat =x) (wrap (` )) @@ -296,7 +256,7 @@ (case args (+0 x) (do @ - [=x (compiler;find-type x) + [=x (resolve-type x) op (cond (check;checks? Nat =x) (wrap (` )) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 161019d91..0d3deb7b9 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -16,7 +16,7 @@ [product] [text] text/format - [error #* "Error/" Monad]) + [error #- fail "Error/" Monad]) (codata [io #- run]) (math ["R" random]) [host #- try])) diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux index 16bfc9e2c..88f165cb3 100644 --- a/stdlib/source/lux/type/check.lux +++ b/stdlib/source/lux/type/check.lux @@ -15,7 +15,7 @@ [product] (struct [list] [dict]) - error) + [error #- fail]) [type "Type/" Eq] )) -- cgit v1.2.3