aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/format/json/codec.lux78
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux13
-rw-r--r--stdlib/source/lux/type/check.lux98
3 files changed, 124 insertions, 65 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 12:17:08 +0000