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/math/simple.lux | 134 +++++++++++++-------------------------
 1 file changed, 47 insertions(+), 87 deletions(-)

(limited to 'stdlib/source/lux/math/simple.lux')

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<Lux> 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<Lux>
+    [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 [<name> <rec> <nat-op> <int-op> <real-op> <frac-op>]
   [(syntax: #export (<name> {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 (` <nat-op>))
@@ -54,7 +87,7 @@
 
        (+2 x)
        (do @
-         [=x (compiler;find-type x)
+         [=x (resolve-type x)
           op (cond (check;checks? Nat =x)
                    (wrap (` <nat-op>))
 
@@ -100,85 +133,12 @@
   [* ;;* n.* i.* r.* f.*]
   [/ ;;/ n./ i./ r./ f./]
   [% ;;% n.% i.% r.% f.%]
-  )
-
-(do-template [<name> <rec> <nat-op> <int-op> <real-op>]
-  [(syntax: #export (<name> {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 (` <nat-op>))
-
-                   (and (check;checks? Int =x)
-                        (check;checks? Int =y))
-                   (wrap (` <int-op>))
-
-                   (and (check;checks? Real =x)
-                        (check;checks? Real =y))
-                   (wrap (` <real-op>))
-
-                   (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)]
-                          (<rec> (~ g!x) (~ g!y)))))))
-
-       (+2 x)
-       (do @
-         [=x (compiler;find-type x)
-          op (cond (check;checks? Nat =x)
-                   (wrap (` <nat-op>))
-
-                   (check;checks? Int =x)
-                   (wrap (` <int-op>))
-
-                   (check;checks? Real =x)
-                   (wrap (` <real-op>))
-
-                   (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)]
-                          (<rec> (~ g!x)))))))
-
-       (+4 [])
-       (do @
-         [=e compiler;expected-type
-          op (cond (check;checks? (-> Nat Nat Nat) =e)
-                   (wrap (` <nat-op>))
-
-                   (check;checks? (-> Int Int Int) =e)
-                   (wrap (` <int-op>))
-
-                   (check;checks? (-> Real Real Real) =e)
-                   (wrap (` <real-op>))
-
-                   (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 [<name> <rec> <nat-op> <int-op>]
@@ -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 (` <nat-op>))
@@ -214,7 +174,7 @@
 
        (+2 x)
        (do @
-         [=x (compiler;find-type x)
+         [=x (resolve-type x)
           op (cond (check;checks? Nat =x)
                    (wrap (` <nat-op>))
 
@@ -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 (` <nat-op>))
 
@@ -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 (` <nat-op>))
 
-- 
cgit v1.2.3