From 3f1baf2747993fec57b3d441c0e9264184f4e4e7 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 10 Aug 2017 20:19:18 -0400
Subject: - Small refactorings and fixes.

---
 stdlib/source/lux/data/format/json/codec.lux | 78 ++++++++++++++++++----
 stdlib/source/lux/macro/poly/eq.lux          | 13 ++--
 stdlib/source/lux/type/check.lux             | 98 ++++++++++++++--------------
 3 files changed, 124 insertions(+), 65 deletions(-)

(limited to 'stdlib')

diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
index 073d3636b..8a50757bf 100644
--- a/stdlib/source/lux/data/format/json/codec.lux
+++ b/stdlib/source/lux/data/format/json/codec.lux
@@ -9,6 +9,7 @@
                 codec
                 ["p" parser "p/" Monad<Parser>])
        (data [bool]
+             [bit]
              [text "text/" Eq<Text> Monoid<Text>]
              (text ["l" lexer])
              [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>]
@@ -19,6 +20,9 @@
              (coll [list "L/" Fold<List> Monad<List>]
                    [vector #+ Vector vector "Vector/" Monad<Vector>]
                    ["d" dict]))
+       (time ["i" instant]
+             ["du" duration]
+             ["da" date])
        [macro #+ Monad<Lux> with-gensyms]
        (macro ["s" syntax #+ syntax:]
               [code]
@@ -131,16 +135,16 @@
 (def: string~
   (l;Lexer ..;String)
   (<| (l;enclosed ["\"" "\""])
-      (loop [_ []]
-        (do p;Monad<Parser>
-          [chars (l;some (l;none-of "\\\""))
-           stop l;peek]
-          (if (text/= "\\" stop)
-            (do @
-              [escaped escaped~
-               next-chars (recur [])]
-              (wrap ($_ text/append chars escaped next-chars)))
-            (wrap chars))))))
+      (loop [_ []])
+      (do p;Monad<Parser>
+        [chars (l;some (l;none-of "\\\""))
+         stop l;peek])
+      (if (text/= "\\" stop)
+        (do @
+          [escaped escaped~
+           next-chars (recur [])]
+          (wrap ($_ text/append chars escaped next-chars)))
+        (wrap chars))))
 
 (def: (kv~ json~)
   (-> (-> Unit (l;Lexer JSON)) (l;Lexer [..;String JSON]))
@@ -191,6 +195,28 @@
   (function [input]
     (non-rec (rec-encode non-rec) input)))
 
+(def: low-mask Nat (|> +1 (bit;shift-left +32) n.dec))
+(def: high-mask Nat (|> low-mask (bit;shift-left +32)))
+
+(struct: #hidden _ (Codec JSON Nat)
+  (def: (encode input)
+    (let [high (|> input (bit;and high-mask) (bit;unsigned-shift-right +32))
+          low (bit;and low-mask input)]
+      (..;array (vector (|> high nat-to-int int-to-real #..;Number)
+                        (|> low nat-to-int int-to-real #..;Number)))))
+  (def: (decode input)
+    (<| (../reader;run input)
+        (do p;Monad<Parser>
+          [high ../reader;number
+           low ../reader;number])
+        (wrap (n.+ (|> high real-to-int int-to-nat (bit;shift-left +32))
+                   (|> low real-to-int int-to-nat))))))
+
+(struct: #hidden _ (Codec JSON Int)
+  (def: encode (|>. int-to-nat (:: Codec<JSON,Nat> encode)))
+  (def: decode
+    (|>. (:: Codec<JSON,Nat> decode) (:: R;Functor<Result> map nat-to-int))))
+
 (poly: #hidden Codec<JSON,?>//encode
   (with-expansions
     [<basic> (do-template [<type> <matcher> <encoder>]
@@ -201,8 +227,21 @@
 
                [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
                [Bool poly;bool ..;boolean]
+               [Nat  poly;nat  (:: ;;Codec<JSON,Nat> (~' encode))]
+               [Int  poly;int  (:: ;;Codec<JSON,Int> (~' encode))]
                [Real poly;real ..;number]
-               [Text poly;text ..;string])]
+               [Text poly;text ..;string])
+     <time> (do-template [<type> <codec>]
+              [(do @
+                 [_ (poly;named (ident-for <type>))]
+                 (wrap (` (: (~ (@JSON//encode inputT))
+                             (|>. (:: <codec> (~' encode)) ..;string)))))]
+
+              [du;Duration du;Codec<Text,Duration>]
+              [i;Instant   i;Codec<Text,Instant>]
+              [da;Date     da;Codec<Text,Date>]
+              [da;Day      da;Codec<Text,Day>]
+              [da;Month    da;Codec<Text,Month>])]
     (do @
       [*env* poly;env
        #let [@JSON//encode (: (-> Type Code)
@@ -211,6 +250,7 @@
        inputT poly;peek]
       ($_ p;either
           <basic>
+          <time>
           (do @
             [#let [g!key (code;local-symbol "\u0000key")
                    g!val (code;local-symbol "\u0000val")]
@@ -294,8 +334,21 @@
 
                [Unit poly;unit ../reader;null]
                [Bool poly;bool ../reader;boolean]
+               [Nat  poly;nat  (p;codec ;;Codec<JSON,Nat> ../reader;any)]
+               [Int  poly;int  (p;codec ;;Codec<JSON,Int> ../reader;any)]
                [Real poly;real ../reader;number]
-               [Text poly;text ../reader;string])]
+               [Text poly;text ../reader;string])
+     <time> (do-template [<type> <codec>]
+              [(do @
+                 [_ (poly;named (ident-for <type>))]
+                 (wrap (` (: (~ (@JSON//decode inputT))
+                             (p;codec <codec> ../reader;string)))))]
+
+              [du;Duration du;Codec<Text,Duration>]
+              [i;Instant   i;Codec<Text,Instant>]
+              [da;Date     da;Codec<Text,Date>]
+              [da;Day      da;Codec<Text,Day>]
+              [da;Month    da;Codec<Text,Month>])]
     (do @
       [*env* poly;env
        #let [@JSON//decode (: (-> Type Code)
@@ -304,6 +357,7 @@
        inputT poly;peek]
       ($_ p;either
           <basic>
+          <time>
           (do @
             [[_ _ valC] (poly;apply ($_ p;seq
                                         (poly;named (ident-for d;Dict))
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
index 3b00591a8..b4d1a5231 100644
--- a/stdlib/source/lux/macro/poly/eq.lux
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -38,7 +38,7 @@
                   (wrap (` (: (~ (@Eq inputT))
                               <eq>))))]
 
-               [poly;unit (function [(~' test) (~' input)] true)]
+               [poly;unit (function [(~ g!_) (~ g!_)] true)]
                [poly;bool bool;Eq<Bool>]
                [poly;nat  number;Eq<Nat>]
                [poly;int  number;Eq<Int>]
@@ -52,8 +52,10 @@
                              <eq>))))]
 
               [du;Duration du;Eq<Duration>]
+              [i;Instant   i;Eq<Instant>]
               [da;Date     da;Eq<Date>]
-              [i;Instant   i;Eq<Instant>])
+              [da;Day      da;Eq<Day>]
+              [da;Month    da;Eq<Month>])
      <composites> (do-template [<name> <eq>]
                     [(do @
                        [[_ argC] (poly;apply (p;seq (poly;named (ident-for <name>))
@@ -71,7 +73,8 @@
                     [rose;Tree     rose;Eq<Tree>]
                     )]
     (do @
-      [*env* poly;env
+      [#let [g!_ (code;local-symbol "\u0000_")]
+       *env* poly;env
        inputT poly;peek
        #let [@Eq (: (-> Type Code)
                     (function [type]
@@ -107,7 +110,9 @@
                                                  (list (` [((~ (code;nat tag)) (~ g!left))
                                                            ((~ (code;nat tag)) (~ g!right))])
                                                        (` ((~ g!eq) (~ g!left) (~ g!right)))))
-                                               (list;enumerate members))))))))))
+                                               (list;enumerate members))))
+                            (~ g!_)
+                            false))))))
           ## Tuples
           (do @
             [g!eqs (poly;tuple (p;many Eq<?>))
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
index fa73186af..0e77e6633 100644
--- a/stdlib/source/lux/type/check.lux
+++ b/stdlib/source/lux/type/check.lux
@@ -14,7 +14,7 @@
        [type "Type/" Eq<Type>]
        ))
 
-(type: #export Fixed (List [[Type Type] Bool]))
+(type: #export Assumptions (List [[Type Type] Bool]))
 
 (type: #export (Check a)
   (-> Type-Context (R;Result [Type-Context a])))
@@ -342,17 +342,17 @@
       (#R;Error _)
       (right context))))
 
-(def: (fx-get [e a] fixed)
-  (-> [Type Type] Fixed (Maybe Bool))
+(def: (assumed? [e a] assumptions)
+  (-> [Type Type] Assumptions (Maybe Bool))
   (:: Monad<Maybe> map product;right
       (list;find (function [[[fe fa] status]]
                    (and (Type/= e fe)
                         (Type/= a fa)))
-                 fixed)))
+                 assumptions)))
 
-(def: (fx-put ea status fixed)
-  (-> [Type Type] Bool Fixed Fixed)
-  (#;Cons [ea status] fixed))
+(def: (assume! ea status assumptions)
+  (-> [Type Type] Bool Assumptions Assumptions)
+  (#;Cons [ea status] assumptions))
 
 (def: (on-var id type then else)
   (All [a]
@@ -365,15 +365,15 @@
             [bound (read-var id)]
             (else bound))))
 
-(def: #export (check' expected actual fixed)
+(def: #export (check' expected actual assumptions)
   {#;doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
-  (-> Type Type Fixed (Check Fixed))
+  (-> Type Type Assumptions (Check Assumptions))
   (if (is expected actual)
-    (Check/wrap fixed)
+    (Check/wrap assumptions)
     (case [expected actual]
       [(#;Var e-id) (#;Var a-id)]
       (if (n.= e-id a-id)
-        (Check/wrap fixed)
+        (Check/wrap assumptions)
         (do Monad<Check>
           [ebound (attempt (read-var e-id))
            abound (attempt (read-var a-id))]
@@ -381,138 +381,138 @@
             [#;None #;None]
             (do @
               [_ (write-var e-id actual)]
-              (wrap fixed))
+              (wrap assumptions))
             
             [(#;Some etype) #;None]
-            (check' etype actual fixed)
+            (check' etype actual assumptions)
 
             [#;None (#;Some atype)]
-            (check' expected atype fixed)
+            (check' expected atype assumptions)
 
             [(#;Some etype) (#;Some atype)]
-            (check' etype atype fixed))))
+            (check' etype atype assumptions))))
       
       [(#;Var id) _]
-      (on-var id actual (Check/wrap fixed)
+      (on-var id actual (Check/wrap assumptions)
               (function [bound]
-                (check' bound actual fixed)))
+                (check' bound actual assumptions)))
       
       [_ (#;Var id)]
-      (on-var id expected (Check/wrap fixed)
+      (on-var id expected (Check/wrap assumptions)
               (function [bound]
-                (check' expected bound fixed)))
+                (check' expected bound assumptions)))
 
       [(#;Apply eA (#;Ex eid)) (#;Apply aA (#;Ex aid))]
       (if (n.= eid aid)
-        (check' eA aA fixed)
+        (check' eA aA assumptions)
         (fail-check expected actual))
 
       [(#;Apply A1 (#;Var id)) (#;Apply A2 F2)]
       (either (do Monad<Check>
                 [F1 (read-var id)]
-                (check' (#;Apply A1 F1) actual fixed))
+                (check' (#;Apply A1 F1) actual assumptions))
               (do Monad<Check>
-                [fixed (check' (#;Var id) F2 fixed)
+                [assumptions (check' (#;Var id) F2 assumptions)
                  e' (apply-type! F2 A1)
                  a' (apply-type! F2 A2)]
-                (check' e' a' fixed)))
+                (check' e' a' assumptions)))
       
       [(#;Apply A1 F1) (#;Apply A2 (#;Var id))]
       (either (do Monad<Check>
                 [F2 (read-var id)]
-                (check' expected (#;Apply A2 F2) fixed))
+                (check' expected (#;Apply A2 F2) assumptions))
               (do Monad<Check>
-                [fixed (check' F1 (#;Var id) fixed)
+                [assumptions (check' F1 (#;Var id) assumptions)
                  e' (apply-type! F1 A1)
                  a' (apply-type! F1 A2)]
-                (check' e' a' fixed)))
+                (check' e' a' assumptions)))
 
       [(#;Apply A F) _]
       (let [fx-pair [expected actual]]
-        (case (fx-get fx-pair fixed)
+        (case (assumed? fx-pair assumptions)
           (#;Some ?)
           (if ?
-            (Check/wrap fixed)
+            (Check/wrap assumptions)
             (fail-check expected actual))
 
           #;None
           (do Monad<Check>
             [expected' (apply-type! F A)]
-            (check' expected' actual (fx-put fx-pair true fixed)))))
+            (check' expected' actual (assume! fx-pair true assumptions)))))
 
       [_ (#;Apply A F)]
       (do Monad<Check>
         [actual' (apply-type! F A)]
-        (check' expected actual' fixed))
+        (check' expected actual' assumptions))
 
       [(#;UnivQ _) _]
       (do Monad<Check>
         [[ex-id ex] existential
          expected' (apply-type! expected ex)]
-        (check' expected' actual fixed))
+        (check' expected' actual assumptions))
 
       [_ (#;UnivQ _)]
       (with-var
         (function [[var-id var]]
           (do Monad<Check>
             [actual' (apply-type! actual var)
-             fixed (check' expected actual' fixed)
+             assumptions (check' expected actual' assumptions)
              _ (clean var-id expected)]
-            (Check/wrap fixed))))
+            (Check/wrap assumptions))))
 
       [(#;ExQ e!env e!def) _]
       (with-var
         (function [[var-id var]]
           (do Monad<Check>
             [expected' (apply-type! expected var)
-             fixed (check' expected' actual fixed)
+             assumptions (check' expected' actual assumptions)
              _ (clean var-id actual)]
-            (Check/wrap fixed))))
+            (Check/wrap assumptions))))
 
       [_ (#;ExQ a!env a!def)]
       (do Monad<Check>
         [[ex-id ex] existential
          actual' (apply-type! actual ex)]
-        (check' expected actual' fixed))
+        (check' expected actual' assumptions))
 
       [(#;Host e-name e-params) (#;Host a-name a-params)]
       (if (and (Text/= e-name a-name)
                (n.= (list;size e-params)
                     (list;size a-params)))
         (do Monad<Check>
-          [fixed (M;fold Monad<Check>
-                         (function [[e a] fixed] (check' e a fixed))
-                         fixed
+          [assumptions (M;fold Monad<Check>
+                         (function [[e a] assumptions] (check' e a assumptions))
+                         assumptions
                          (list;zip2 e-params a-params))]
-          (Check/wrap fixed))
+          (Check/wrap assumptions))
         (fail-check expected actual))
 
       (^template [<unit> <append>]
         [<unit> <unit>]
-        (Check/wrap fixed)
+        (Check/wrap assumptions)
         
         [(<append> eL eR) (<append> aL aR)]
         (do Monad<Check>
-          [fixed (check' eL aL fixed)]
-          (check' eR aR fixed)))
+          [assumptions (check' eL aL assumptions)]
+          (check' eR aR assumptions)))
       ([#;Void #;Sum]
        [#;Unit #;Product])
       
       [(#;Function eI eO) (#;Function aI aO)]
       (do Monad<Check>
-        [fixed (check' aI eI fixed)]
-        (check' eO aO fixed))
+        [assumptions (check' aI eI assumptions)]
+        (check' eO aO assumptions))
 
       [(#;Ex e!id) (#;Ex a!id)]
       (if (n.= e!id a!id)
-        (Check/wrap fixed)
+        (Check/wrap assumptions)
         (fail-check expected actual))
 
       [(#;Named _ ?etype) _]
-      (check' ?etype actual fixed)
+      (check' ?etype actual assumptions)
 
       [_ (#;Named _ ?atype)]
-      (check' expected ?atype fixed)
+      (check' expected ?atype assumptions)
 
       _
       (fail-check expected actual))))
@@ -521,7 +521,7 @@
   {#;doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
   (-> Type Type (Check Unit))
   (do Monad<Check>
-    [fixed (check' expected actual (list))]
+    [assumptions (check' expected actual (list))]
     (wrap [])))
 
 (def: #export (checks? expected actual)
-- 
cgit v1.2.3