diff options
author | Eduardo Julian | 2017-08-01 00:12:40 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-08-01 00:12:40 -0400 |
commit | b802e8efe275ee75473b755429b1805c5c83abbd (patch) | |
tree | 98fea1b2f73afc185117f086ae9373cb5516a42f /stdlib | |
parent | 27466e65e78af24f8e750549055123d6c8559839 (diff) |
- Broken down lux/data/format/json module into smaller family of modules.
- Re-implemented JSON parsing in terms of lux/control/parser.
Diffstat (limited to 'stdlib')
-rw-r--r-- | stdlib/source/lux/data/format/json.lux | 910 | ||||
-rw-r--r-- | stdlib/source/lux/data/format/json/codec.lux | 536 | ||||
-rw-r--r-- | stdlib/source/lux/data/format/json/reader.lux | 177 | ||||
-rw-r--r-- | stdlib/source/lux/data/text/format.lux | 5 | ||||
-rw-r--r-- | stdlib/test/test/lux/data/format/json.lux | 69 |
5 files changed, 769 insertions, 928 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index c4951f188..379e3b23b 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -1,4 +1,4 @@ -(;module: {#;doc "Functionality for reading, generating and processing values in the JSON format. +(;module: {#;doc "Functionality for generating and processing values in the JSON format. For more information, please see: http://www.json.org/"} lux @@ -51,20 +51,15 @@ [Object (d;Dict String JSON)] ) -(type: #export (Parser a) - {#;doc "JSON parsers."} - (-> JSON (R;Result a))) - -(type: #export (Gen a) - {#;doc "JSON generators."} - (-> a JSON)) +(type: #export (Reader a) + {#;doc "JSON reader."} + (p;Parser (List JSON) a)) ## [Syntax] (syntax: #export (json token) - {#;doc (doc "A way to produce JSON literals." + {#;doc (doc "A simple way to produce JSON literals." (json true) - (json 123) - (json 456.78) + (json 123.456) (json "Some text") (json #null) (json ["this" "is" "an" "array"]) @@ -77,7 +72,6 @@ [_ (<ast-tag> value)] (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value)))))))) ([#;Bool code;bool #Boolean] - [#;Int (|>. int-to-real code;real) #Number] [#;Real code;real #Number] [#;Text code;text #String]) @@ -104,44 +98,6 @@ (wrap (list token)) ))) -## [Values] -(def: #hidden (show-null _) (-> Null Text) "null") -(do-template [<name> <type> <codec>] - [(def: <name> (-> <type> Text) <codec>)] - - [show-boolean Boolean (:: bool;Codec<Text,Bool> encode)] - [show-number Number (:: number;Codec<Text,Real> encode)] - [show-string String text;encode]) - -(def: (show-array show-json elems) - (-> (-> JSON Text) (-> Array Text)) - ($_ text/append "[" - (|> elems (Vector/map show-json) vector;to-list (text;join-with ",")) - "]")) - -(def: (show-object show-json object) - (-> (-> JSON Text) (-> Object Text)) - ($_ text/append "{" - (|> object - d;entries - (L/map (function [[key value]] ($_ text/append (show-string key) ":" (show-json value)))) - (text;join-with ",")) - "}")) - -(def: (show-json json) - (-> JSON Text) - (case json - (^template [<tag> <show>] - (<tag> value) - (<show> value)) - ([#Null show-null] - [#Boolean show-boolean] - [#Number show-number] - [#String show-string] - [#Array (show-array show-json)] - [#Object (show-object show-json)]) - )) - (def: #export null {#;doc "The null JSON value."} JSON @@ -167,10 +123,10 @@ (#R;Success value) #;None - (#R;Error ($_ text/append "Missing field " (show-string key) " on object."))) + (#R;Error ($_ text/append "Missing field \"" key "\" on object."))) _ - (#R;Error ($_ text/append "Cannot get field " (show-string key) " of a non-object.")))) + (#R;Error ($_ text/append "Cannot get field \"" key "\" of a non-object.")))) (def: #export (set key value json) {#;doc "A JSON object field setter."} @@ -180,7 +136,7 @@ (#R;Success (#Object (d;put key value obj))) _ - (#R;Error ($_ text/append "Cannot set field " (show-string key) " of a non-object.")))) + (#R;Error ($_ text/append "Cannot set field \"" key "\" of a non-object.")))) (do-template [<name> <tag> <type> <desc>] [(def: #export (<name> key json) @@ -191,7 +147,7 @@ (#R;Success value) (#R;Success _) - (#R;Error ($_ text/append "Wrong value type at key " (show-string key))) + (#R;Error ($_ text/append "Wrong value type at key: " key)) (#R;Error error) (#R;Error error)))] @@ -206,404 +162,24 @@ (do-template [<name> <type> <tag> <desc>] [(def: #export (<name> value) {#;doc (#;TextA ($_ text/append "A JSON generator for " <desc> "."))} - (Gen <type>) + (-> <type> JSON) (<tag> value))] - [gen-boolean Boolean #Boolean "booleans"] - [gen-number Number #Number "numbers"] - [gen-string String #String "strings"] - [gen-array Array #Array "arrays"] - [gen-object Object #Object "objects"] + [boolean Boolean #Boolean "booleans"] + [number Number #Number "numbers"] + [string String #String "strings"] + [array Array #Array "arrays"] + [object Object #Object "objects"] ) -(def: #export (gen-nullable gen) +(def: #export (nullable writer) {#;doc "Builds a JSON generator for potentially inexistent values."} - (All [a] (-> (Gen a) (Gen (Maybe a)))) + (All [a] (-> (-> a JSON) (-> (Maybe a) JSON))) (function [elem] (case elem #;None #Null - (#;Some value) (gen value)))) - -## Lexers -(def: space~ - (l;Lexer Text) - (l;some l;space)) - -(def: data-sep - (l;Lexer [Text Unit Text]) - ($_ p;seq space~ (l;this ",") space~)) - -(def: null~ - (l;Lexer Null) - (do p;Monad<Parser> - [_ (l;this "null")] - (wrap []))) - -(do-template [<name> <token> <value>] - [(def: <name> - (l;Lexer Boolean) - (do p;Monad<Parser> - [_ (l;this <token>)] - (wrap <value>)))] - - [t~ "true" true] - [f~ "false" false] - ) - -(def: boolean~ - (l;Lexer Boolean) - (p;either t~ f~)) - -(def: number~ - (l;Lexer Number) - (do p;Monad<Parser> - [signed? (l;this? "-") - digits (l;many l;decimal) - decimals (p;default "0" - (do @ - [_ (l;this ".")] - (l;many l;decimal))) - exp (p;default "" - (do @ - [mark (l;one-of "eE") - signed?' (l;this? "-") - offset (l;many l;decimal)] - (wrap ($_ text/append mark (if signed?' "-" "") offset))))] - (case (real/decode ($_ text/append (if signed? "-" "") digits "." decimals exp)) - (#R;Error message) - (p;fail message) - - (#R;Success value) - (wrap value)))) - -(def: escaped~ - (l;Lexer Text) - ($_ p;either - (p;after (l;this "\\t") (p/wrap "\t")) - (p;after (l;this "\\b") (p/wrap "\b")) - (p;after (l;this "\\n") (p/wrap "\n")) - (p;after (l;this "\\r") (p/wrap "\r")) - (p;after (l;this "\\f") (p/wrap "\f")) - (p;after (l;this "\\\"") (p/wrap "\"")) - (p;after (l;this "\\\\") (p/wrap "\\")))) - -(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)))))) - -(def: (kv~ json~) - (-> (-> Unit (l;Lexer JSON)) (l;Lexer [String JSON])) - (do p;Monad<Parser> - [key string~ - _ space~ - _ (l;this ":") - _ space~ - value (json~ [])] - (wrap [key value]))) - -(do-template [<name> <type> <open> <close> <elem-parser> <prep>] - [(def: (<name> json~) - (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>)) - (do p;Monad<Parser> - [_ (l;this <open>) - _ space~ - elems (p;sep-by data-sep <elem-parser>) - _ space~ - _ (l;this <close>)] - (wrap (<prep> elems))))] - - [array~ Array "[" "]" (json~ []) vector;from-list] - [object~ Object "{" "}" (kv~ json~) (d;from-list text;Hash<Text>)] - ) - -(def: (json~' _) - (-> Unit (l;Lexer JSON)) - ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) - -## [Structures] -(struct: #export _ (Functor Parser) - (def: (map f ma) - (function [json] - (case (ma json) - (#R;Error msg) - (#R;Error msg) - - (#R;Success a) - (#R;Success (f a)))))) - -(struct: #export _ (Applicative Parser) - (def: functor Functor<Parser>) - - (def: (wrap x json) - (#R;Success x)) - - (def: (apply ff fa) - (function [json] - (case (ff json) - (#R;Success f) - (case (fa json) - (#R;Success a) - (#R;Success (f a)) - - (#R;Error msg) - (#R;Error msg)) - - (#R;Error msg) - (#R;Error msg))))) - -(struct: #export _ (Monad Parser) - (def: applicative Applicative<Parser>) - - (def: (join mma) - (function [json] - (case (mma json) - (#R;Error msg) - (#R;Error msg) - - (#R;Success ma) - (ma json))))) - -## [Values] -## Syntax -(do-template [<name> <type> <tag> <desc> <pre>] - [(def: #export (<name> json) - {#;doc (#;TextA ($_ text/append "Reads a JSON value as " <desc> "."))} - (Parser <type>) - (case json - (<tag> value) - (#R;Success (<pre> value)) - - _ - (#R;Error ($_ text/append "JSON value is not " <desc> ": " (show-json json)))))] - - [unit Unit #Null "unit" id] - [bool Bool #Boolean "bool" id] - [int Int #Number "int" real-to-int] - [real Real #Number "real" id] - [text Text #String "text" id] - ) - -(do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>] - [(def: #export (<test> test json) - {#;doc (#;TextA ($_ text/append "Asks whether a JSON value is a " <desc> "."))} - (-> <type> (Parser Bool)) - (case json - (<tag> value) - (#R;Success (:: <eq> = test (<pre> value))) - - _ - (#R;Error ($_ text/append "JSON value is not a " <desc> ": " (show-json json))))) - - (def: #export (<check> test json) - {#;doc (#;TextA ($_ text/append "Ensures a JSON value is a " <desc> "."))} - (-> <type> (Parser Unit)) - (case json - (<tag> value) - (let [value (<pre> value)] - (if (:: <eq> = test value) - (#R;Success []) - (#R;Error ($_ text/append "Value mismatch: " - (<encoder> test) "=/=" (<encoder> value))))) - - _ - (#R;Error ($_ text/append "JSON value is not a " <desc> ": " (show-json json)))))] - - [bool? bool! Bool bool;Eq<Bool> (:: bool;Codec<Text,Bool> encode) #Boolean "boolean" id] - [int? int! Int number;Eq<Int> (:: number;Codec<Text,Int> encode) #Number "number" real-to-int] - [real? real! Real number;Eq<Real> (:: number;Codec<Text,Real> encode) #Number "number" id] - [text? text! Text text;Eq<Text> text;encode #String "string" id] - ) - -(def: #export (nullable parser) - {#;doc "A parser that can handle the presence of null values."} - (All [a] (-> (Parser a) (Parser (Maybe a)))) - (function [json] - (case json - #Null - (#R;Success #;None) - - _ - (case (parser json) - (#R;Error error) - (#R;Error error) - - (#R;Success value) - (#R;Success (#;Some value))) - ))) - -(def: #export (array parser) - {#;doc "Parses a JSON array, assuming that every element can be parsed the same way."} - (All [a] (-> (Parser a) (Parser (List a)))) - (function [json] - (case json - (#Array values) - (do R;Monad<Result> - [elems (M;map @ parser (vector;to-list values))] - (wrap elems)) - - _ - (#R;Error ($_ text/append "JSON value is not an array: " (show-json json)))))) - -(def: #export (object parser) - {#;doc "Parses a JSON object, assuming that every field's value can be parsed the same way."} - (All [a] (-> (Parser a) (Parser (d;Dict String a)))) - (function [json] - (case json - (#Object fields) - (do R;Monad<Result> - [kvs (M;map @ - (function [[key val']] - (do @ - [val (parser val')] - (wrap [key val]))) - (d;entries fields))] - (wrap (d;from-list text;Hash<Text> kvs))) - - _ - (#R;Error ($_ text/append "JSON value is not an object: " (show-json json)))))) + (#;Some value) (writer value)))) -(def: #export (nth idx parser) - {#;doc "Parses an element inside a JSON array."} - (All [a] (-> Nat (Parser a) (Parser a))) - (function [json] - (case json - (#Array values) - (case (vector;nth idx values) - (#;Some value) - (case (parser value) - (#R;Success output) - (#R;Success output) - - (#R;Error error) - (#R;Error ($_ text/append "JSON array index [" (nat/encode idx) "]: (" error ") @ " (show-json json)))) - - #;None - (#R;Error ($_ text/append "JSON array does not have index " (nat/encode idx) " @ " (show-json json)))) - - _ - (#R;Error ($_ text/append "JSON value is not an array: " (show-json json)))))) - -(def: #export (field field-name parser) - {#;doc "Parses a field inside a JSON object."} - (All [a] (-> Text (Parser a) (Parser a))) - (function [json] - (case (get field-name json) - (#;Some value) - (case (parser value) - (#R;Success output) - (#R;Success output) - - (#R;Error error) - (#R;Error ($_ text/append "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json)))) - - (#R;Error _) - (#R;Error ($_ text/append "JSON object does not have field " (show-string field-name) " @ " (show-json json)))))) - -(def: #export any - {#;doc "Just returns the JSON input without applying any logic."} - (Parser JSON) - (function [json] - (#R;Success json))) - -(def: #export (seq pa pb) - {#;doc "Sequencing combinator."} - (All [a b] (-> (Parser a) (Parser b) (Parser [a b]))) - (do Monad<Parser> - [=a pa - =b pb] - (wrap [=a =b]))) - -(def: #export (alt pa pb) - {#;doc "Heterogeneous alternative combinator."} - (All [a b] (-> (Parser a) (Parser b) (Parser (| a b)))) - (function [json] - (case (pa json) - (#R;Success a) - (sum;right (sum;left a)) - - (#R;Error message0) - (case (pb json) - (#R;Success b) - (sum;right (sum;right b)) - - (#R;Error message1) - (#R;Error message0))))) - -(def: #export (either pl pr) - {#;doc "Homogeneous alternative combinator."} - (All [a] (-> (Parser a) (Parser a) (Parser a))) - (function [json] - (case (pl json) - (#R;Success x) - (#R;Success x) - - _ - (pr json)))) - -(def: #export (opt p) - {#;doc "Optionality combinator."} - (All [a] - (-> (Parser a) (Parser (Maybe a)))) - (function [json] - (case (p json) - (#R;Error _) (#R;Success #;None) - (#R;Success x) (#R;Success (#;Some x))))) - -(def: #export (run json parser) - (All [a] (-> JSON (Parser a) (R;Result a))) - (parser json)) - -(def: #export (ensure test parser) - {#;doc "Only parses a JSON if it passes a test (which is also a parser)."} - (All [a] (-> (Parser Unit) (Parser a) (Parser a))) - (function [json] - (case (test json) - (#R;Success _) - (parser json) - - (#R;Error error) - (#R;Error error)))) - -(def: #export (array-size! size) - {#;doc "Ensures a JSON array has the specified size."} - (-> Nat (Parser Unit)) - (function [json] - (case json - (#Array parts) - (if (n.= size (vector;size parts)) - (#R;Success []) - (#R;Error ($_ text/append "JSON array does no have size " (nat/encode size) " " (show-json json)))) - - _ - (#R;Error ($_ text/append "JSON value is not an array: " (show-json json)))))) - -(def: #export (object-fields! wanted-fields) - {#;doc "Ensures that every field in the list of wanted-fields is present in a JSON object."} - (-> (List String) (Parser Unit)) - (function [json] - (case json - (#Object kvs) - (let [actual-fields (d;keys kvs)] - (if (and (n.= (list;size wanted-fields) (list;size actual-fields)) - (list;every? (list;member? text;Eq<Text> wanted-fields) - actual-fields)) - (#R;Success []) - (#R;Error ($_ text/append "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]")))) - - _ - (#R;Error ($_ text/append "JSON value is not an object: " (show-json json)))))) - -## [Structures] (struct: #export _ (Eq JSON) (def: (= x y) (case [x y] @@ -641,451 +217,3 @@ _ false))) - -(struct: #export _ (Codec Text JSON) - (def: encode show-json) - (def: decode (function [input] (l;run input (json~' []))))) - -## [Syntax] -(type: Shape - (#ArrayShape (List Code)) - (#ObjectShape (List [Text Code]))) - -(def: _shape^ - (s;Syntax Shape) - (p;alt (s;tuple (p;some s;any)) - (s;record (p;some (p;seq s;text s;any))))) - -(syntax: #export (shape [shape _shape^]) - {#;doc (doc "Builds a parser that ensures the (inclusive) shape of an array or object." - (shape [bool! int! real!]) - (shape {"isAlive" bool! - "age" int! - "income" real!}))} - (case shape - (#ArrayShape parts) - (let [array-size (list;size parts) - parsers (|> parts - (list;zip2 (list;indices array-size)) - (L/map (function [[idx parser]] - (` (nth (~ (code;nat idx)) (~ parser))))))] - (wrap (list (` ($_ seq (~@ parsers)))))) - - (#ObjectShape kvs) - (let [fields (L/map product;left kvs) - parsers (L/map (function [[field-name parser]] - (` (field (~ (code;text field-name)) (~ parser)))) - kvs)] - (wrap (list (` ($_ seq (~@ parsers)))))) - )) - -(syntax: #export (shape! [shape _shape^]) - {#;doc (doc "Builds a parser that ensures the (exclusive) shape of an array or object." - (shape! [bool! int! real!]) - (shape! {"isAlive" bool! - "age" int! - "income" real!}))} - (case shape - (#ArrayShape parts) - (let [array-size (list;size parts) - parsers (|> parts - (list;zip2 (list;indices array-size)) - (L/map (function [[idx parser]] - (` (nth (~ (code;nat idx)) (~ parser))))))] - (wrap (list (` (ensure (array-size! (~ (code;nat array-size))) - ($_ seq (~@ parsers))))))) - - (#ObjectShape kvs) - (let [fields (L/map product;left kvs) - parsers (L/map (function [[field-name parser]] - (` (field (~ (code;text field-name)) (~ parser)))) - kvs)] - (wrap (list (` (ensure (object-fields! (list (~@ (L/map code;text fields)))) - ($_ seq (~@ parsers))))))) - )) - -## [Polytypism] -(def: #hidden _map_ - (All [a b] (-> (-> a b) (List a) (List b))) - L/map) - -(def: #hidden (rec-encode non-rec) - (All [a] (-> (-> (-> a JSON) - (-> a JSON)) - (-> a JSON))) - (function [input] - (non-rec (rec-encode non-rec) input))) - -(poly: #hidden (Codec<JSON,?>//encode env :x:) - (let [->Codec//encode (: (-> Code Code) - (function [.type.] (` (-> (~ .type.) JSON))))] - (with-expansions - [<basic> (do-template [<type> <matcher> <encoder>] - [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))] - - [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #Null)] - [Bool poly;bool ;;gen-boolean] - [Int poly;int (|>. ;int-to-real ;;gen-number)] - [Real poly;real ;;gen-number] - [Text poly;text ;;gen-string])] - ($_ macro;either - <basic> - (with-gensyms [g!input g!key g!val] - (do @ - [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:) - _ (poly;text :key:) - .val. (Codec<JSON,?>//encode env :val:)] - (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) - (function [(~ g!input)] - (|> (~ g!input) - d;entries - (;;_map_ (: (-> [Text (~ (poly;to-ast env :val:))] - [Text JSON]) - (function [[(~ g!key) (~ g!val)]] - [(~ g!key) - ((~ .val.) (~ g!val))]))) - (d;from-list text;Hash<Text>) - #;;Object)) - ))))) - (do @ - [:sub: (poly;apply-1 (ident-for ;Maybe) :x:) - .sub. (Codec<JSON,?>//encode env :sub:)] - (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) - (;;gen-nullable (~ .sub.)))))) - (do @ - [:sub: (poly;apply-1 (ident-for ;List) :x:) - .sub. (Codec<JSON,?>//encode env :sub:)] - (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) - (|>. (;;_map_ (~ .sub.)) vector;from-list ;;gen-array))))) - (with-gensyms [g!type-fun g!case g!input] - (do @ - [members (poly;sum+ :x:) - pattern-matching (M;map @ - (function [[tag :case:]] - (do @ - [g!encode (Codec<JSON,?>//encode env :case:)] - (wrap (list (` ((~ (code;nat tag)) (~ g!case))) - (` (;;json [(~ (code;int (nat-to-int tag))) - ((~ g!encode) (~ g!case))])))))) - (list;enumerate members))] - (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) - (function [(~ g!input)] - (case (~ g!input) - (~@ (L/join pattern-matching))))))))) - (with-gensyms [g!type-fun g!case g!input] - (do @ - [[g!vars members] (poly;variant :x:) - #let [new-env (poly;extend-env [:x: g!type-fun] - (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) - env)] - pattern-matching (M;map @ - (function [[name :case:]] - (do @ - [#let [tag (code;tag name)] - encoder (Codec<JSON,?>//encode new-env :case:)] - (wrap (list (` ((~ tag) (~ g!case))) - (` (;;json [(~ (code;text (product;right name))) - ((~ encoder) (~ g!case))])))))) - members) - #let [:x:+ (case g!vars - #;Nil - (->Codec//encode (poly;to-ast env :x:)) - - _ - (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (L/map ->Codec//encode g!vars)) - (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] - (wrap (` (: (~ :x:+) - (function [(~@ g!vars) (~ g!input)] - (case (~ g!input) - (~@ (L/join pattern-matching)))) - ))))) - (with-gensyms [g!type-fun g!case g!input] - (do @ - [[g!vars members] (poly;record :x:) - #let [new-env (poly;extend-env [:x: g!type-fun] - (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) - env)] - synthesis (M;map @ - (function [[name :slot:]] - (do @ - [encoder (Codec<JSON,?>//encode new-env :slot:)] - (wrap [(` (~ (code;text (product;right name)))) - (` ((~ encoder) (get@ (~ (code;tag name)) (~ g!input))))]))) - members) - #let [:x:+ (case g!vars - #;Nil - (->Codec//encode (poly;to-ast env :x:)) - - _ - (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (L/map ->Codec//encode g!vars)) - (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] - (wrap (` (: (~ :x:+) - (function [(~@ g!vars) (~ g!input)] - (;;json (~ (code;record synthesis)))) - ))))) - (with-gensyms [g!type-fun g!case] - (do @ - [[g!vars members] (poly;tuple :x:) - #let [new-env (poly;extend-env [:x: g!type-fun] - (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) - env)] - pattern-matching (M;map @ - (function [:member:] - (do @ - [g!member (macro;gensym "g!member") - encoder (Codec<JSON,?>//encode new-env :member:)] - (wrap [g!member encoder]))) - members) - #let [:x:+ (case g!vars - #;Nil - (->Codec//encode (poly;to-ast env :x:)) - - _ - (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (L/map ->Codec//encode g!vars)) - (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))] - #let [.tuple. (` [(~@ (L/map product;left pattern-matching))])]] - (wrap (` (: (~ :x:+) - (function [(~@ g!vars) (~ .tuple.)] - (;;json [(~@ (L/map (function [[g!member g!encoder]] - (` ((~ g!encoder) (~ g!member)))) - pattern-matching))])) - ))) - )) - ## Type recursion - (with-gensyms [g!rec] - (do @ - [:non-rec: (poly;recursive :x:) - #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)] - .non-rec. (Codec<JSON,?>//encode new-env :non-rec:)] - (wrap (` (: (~ (poly;gen-type new-env ->Codec//encode g!rec (list) :x:)) - (rec-encode (;function [(~ g!rec)] - (~ .non-rec.)))))))) - (poly;self env :x:) - (poly;recursion env :x:) - ## Type applications - (do @ - [[:func: :args:] (poly;apply :x:) - .func. (Codec<JSON,?>//encode env :func:) - .args. (M;map @ (Codec<JSON,?>//encode env) :args:)] - (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) - ((~ .func.) (~@ .args.)))))) - ## Bound type-vars - (poly;bound env :x:) - ## If all else fails... - (macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :x:))) - )))) - -(def: #hidden (rec-decode non-rec) - (All [a] (-> (-> (-> JSON (R;Result a)) - (-> JSON (R;Result a))) - (-> JSON (R;Result a)))) - (function [input] - (non-rec (rec-decode non-rec) input))) - -(poly: #hidden (Codec<JSON,?>//decode env :x:) - (let [->Codec//decode (: (-> Code Code) - (function [.type.] (` (-> JSON (R;Result (~ .type.))))))] - (with-expansions - [<basic> (do-template [<type> <matcher> <decoder>] - [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))] - - [Unit poly;unit ;;unit] - [Bool poly;bool ;;bool] - [Int poly;int ;;int] - [Real poly;real ;;real] - [Text poly;text ;;text]) - <complex> (do-template [<type> <matcher> <decoder>] - [(do @ - [:sub: (<matcher> :x:) - .sub. (Codec<JSON,?>//decode env :sub:)] - (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) - (<decoder> (~ .sub.))))))] - - [Maybe (poly;apply-1 (ident-for ;Maybe)) ;;nullable] - [List (poly;apply-1 (ident-for ;List)) ;;array])] - ($_ macro;either - <basic> - (with-gensyms [g!input g!output g!key g!val] - (do @ - [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:) - _ (poly;text :key:) - .val. (Codec<JSON,?>//decode env :val:)] - (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) - (function [(~ g!input)] - (do R;Monad<Result> - [(~ g!key) (;;fields (~ g!input)) - (~ g!output) (M;map R;Monad<Result> - (function [(~ g!key)] - (do R;Monad<Result> - [(~ g!val) (;;get (~ g!key) (~ g!input)) - (~ g!val) (;;run (~ g!val) (~ .val.))] - ((~ (' wrap)) [(~ g!key) (~ g!val)]))) - (~ g!key))] - ((~' wrap) (d;from-list text;Hash<Text> (~ g!output))))) - ))) - )) - <complex> - (with-gensyms [g!type-fun g!case g!input g!_] - (do @ - [members (poly;sum+ :x:) - pattern-matching (M;map @ - (function [[tag :case:]] - (do @ - [g!decode (Codec<JSON,?>//decode env :case:)] - (wrap (list (` (do Monad<Parser> - [(~ g!_) (;;nth +0 (;;int! (~ (code;int (nat-to-int tag))))) - (~ g!_) (;;nth +1 (~ g!decode))] - ((~' wrap) ((~ (code;nat tag)) (~ g!_))))))))) - (list;enumerate members))] - (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) - ($_ ;;either - (~@ (L/join pattern-matching)))))))) - (with-gensyms [g!type-fun g!_] - (do @ - [[g!vars members] (poly;variant :x:) - #let [new-env (poly;extend-env [:x: g!type-fun] - (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) - env)] - pattern-matching (M;map @ - (function [[name :case:]] - (do @ - [#let [tag (code;tag name)] - decoder (Codec<JSON,?>//decode new-env :case:)] - (wrap (list (` (do Monad<Parser> - [(~ g!_) (;;nth +0 (;;text! (~ (code;text (product;right name))))) - (~ g!_) (;;nth +1 (~ decoder))] - ((~ (' wrap)) ((~ tag) (~ g!_))))))))) - members) - #let [:x:+ (case g!vars - #;Nil - (->Codec//decode (poly;to-ast env :x:)) - - _ - (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (L/map ->Codec//decode g!vars)) - (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars))))))))) - base-parser (` ($_ ;;either - (~@ (L/join pattern-matching)))) - parser (case g!vars - #;Nil - base-parser - - _ - (` (function [(~@ g!vars)] (~ base-parser))))]] - (wrap (` (: (~ :x:+) (~ parser)))) - )) - (with-gensyms [g!type-fun g!case g!input] - (do @ - [[g!vars members] (poly;record :x:) - #let [new-env (poly;extend-env [:x: g!type-fun] - (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) - env)] - extraction (M;map @ - (function [[name :slot:]] - (do @ - [#let [g!member (code;symbol ["" (product;right name)])] - decoder (Codec<JSON,?>//decode new-env :slot:)] - (wrap (list g!member - (` (;;get (~ (code;text (product;right name))) (~ g!input))) - g!member - (` ((~ decoder) (~ g!member))))))) - members) - #let [:x:+ (case g!vars - #;Nil - (->Codec//decode (poly;to-ast env :x:)) - - _ - (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (L/map ->Codec//decode g!vars)) - (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] - (wrap (` (: (~ :x:+) - (function [(~@ g!vars) (~ g!input)] - (do R;Monad<Result> - [(~@ (L/join extraction))] - ((~ (' wrap)) (~ (code;record (L/map (function [[name :slot:]] - [(code;tag name) (code;symbol ["" (product;right name)])]) - members)))))) - ))))) - (with-gensyms [g!type-fun g!case g!input] - (do @ - [[g!vars members] (poly;tuple :x:) - #let [new-env (poly;extend-env [:x: g!type-fun] - (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) - env)] - pattern-matching (M;map @ - (function [:member:] - (do @ - [g!member (macro;gensym "g!member") - decoder (Codec<JSON,?>//decode new-env :member:)] - (wrap [g!member decoder]))) - members) - #let [:x:+ (case g!vars - #;Nil - (->Codec//decode (poly;to-ast env :x:)) - - _ - (` (All (~ g!type-fun) [(~@ g!vars)] - (-> (~@ (L/map ->Codec//decode g!vars)) - (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))] - #let [.decoder. (case g!vars - #;Nil - (` (;;shape [(~@ (L/map product;right pattern-matching))])) - - _ - (` (function [(~@ g!vars)] - (;;shape [(~@ (L/map product;right pattern-matching))]))))]] - (wrap (` (: (~ :x:+) (~ .decoder.)))) - )) - ## Type recursion - (with-gensyms [g!rec] - (do @ - [:non-rec: (poly;recursive :x:) - #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)] - .non-rec. (Codec<JSON,?>//decode new-env :non-rec:)] - (wrap (` (: (~ (poly;gen-type new-env ->Codec//decode g!rec (list) :x:)) - (rec-decode (;function [(~ g!rec)] - (~ .non-rec.)))))))) - (poly;self env :x:) - (poly;recursion env :x:) - ## Type applications - (do @ - [[:func: :args:] (poly;apply :x:) - .func. (Codec<JSON,?>//decode env :func:) - .args. (M;map @ (Codec<JSON,?>//decode env) :args:)] - (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) - ((~ .func.) (~@ .args.)))))) - ## Bound type-vars - (do @ - [g!bound (poly;bound env :x:)] - (wrap g!bound)) - ## If all else fails... - (macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:))) - )))) - -(syntax: #export (Codec<JSON,?> :x:) - {#;doc (doc "A macro for automatically producing JSON codecs." - (type: Variant - (#Case0 Bool) - (#Case1 Int) - (#Case2 Real)) - - (type: Record - {#unit Unit - #bool Bool - #int Int - #real Real - #text Text - #maybe (Maybe Int) - #list (List Int) - #variant Variant - #tuple [Int Real Text] - #dict (Dict Text Int)}) - - (derived: (Codec<JSON,?> Record)))} - (wrap (list (` (: (Codec JSON (~ :x:)) - (struct (def: (~ (' encode)) (Codec<JSON,?>//encode (~ :x:))) - (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:))) - )))))) diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux new file mode 100644 index 000000000..2bd298419 --- /dev/null +++ b/stdlib/source/lux/data/format/json/codec.lux @@ -0,0 +1,536 @@ +(;module: {#;doc "Codecs for values in the JSON format. + + For more information, please see: http://www.json.org/"} + lux + (lux (control functor + applicative + ["M" monad #+ do Monad] + [eq #+ Eq] + codec + ["p" parser "p/" Monad<Parser>]) + (data [bool] + [text "text/" Eq<Text> Monoid<Text>] + (text ["l" lexer]) + [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>] + maybe + ["R" result] + [sum] + [product] + (coll [list "L/" Fold<List> Monad<List>] + [vector #+ Vector vector "Vector/" Monad<Vector>] + ["d" dict])) + [macro #+ Monad<Lux> with-gensyms] + (macro ["s" syntax #+ syntax:] + [code] + [poly #+ poly:]) + [type] + ) + [.. #+ JSON] + [../reader]) + +## [Values] +(def: #hidden (show-null _) (-> ..;Null Text) "null") +(do-template [<name> <type> <codec>] + [(def: <name> (-> <type> Text) <codec>)] + + [show-boolean ..;Boolean (:: bool;Codec<Text,Bool> encode)] + [show-number ..;Number (:: number;Codec<Text,Real> encode)] + [show-string ..;String text;encode]) + +(def: (show-array show-json elems) + (-> (-> JSON Text) (-> ..;Array Text)) + ($_ text/append "[" + (|> elems (Vector/map show-json) vector;to-list (text;join-with ",")) + "]")) + +(def: (show-object show-json object) + (-> (-> JSON Text) (-> ..;Object Text)) + ($_ text/append "{" + (|> object + d;entries + (L/map (function [[key value]] ($_ text/append (show-string key) ":" (show-json value)))) + (text;join-with ",")) + "}")) + +(def: (show-json json) + (-> JSON Text) + (case json + (^template [<tag> <show>] + (<tag> value) + (<show> value)) + ([#..;Null show-null] + [#..;Boolean show-boolean] + [#..;Number show-number] + [#..;String show-string] + [#..;Array (show-array show-json)] + [#..;Object (show-object show-json)]) + )) + +(def: space~ + (l;Lexer Text) + (l;some l;space)) + +(def: data-sep + (l;Lexer [Text Unit Text]) + ($_ p;seq space~ (l;this ",") space~)) + +(def: null~ + (l;Lexer ..;Null) + (do p;Monad<Parser> + [_ (l;this "null")] + (wrap []))) + +(do-template [<name> <token> <value>] + [(def: <name> + (l;Lexer ..;Boolean) + (do p;Monad<Parser> + [_ (l;this <token>)] + (wrap <value>)))] + + [t~ "true" true] + [f~ "false" false] + ) + +(def: boolean~ + (l;Lexer ..;Boolean) + (p;either t~ f~)) + +(def: number~ + (l;Lexer ..;Number) + (do p;Monad<Parser> + [signed? (l;this? "-") + digits (l;many l;decimal) + decimals (p;default "0" + (do @ + [_ (l;this ".")] + (l;many l;decimal))) + exp (p;default "" + (do @ + [mark (l;one-of "eE") + signed?' (l;this? "-") + offset (l;many l;decimal)] + (wrap ($_ text/append mark (if signed?' "-" "") offset))))] + (case (real/decode ($_ text/append (if signed? "-" "") digits "." decimals exp)) + (#R;Error message) + (p;fail message) + + (#R;Success value) + (wrap value)))) + +(def: escaped~ + (l;Lexer Text) + ($_ p;either + (p;after (l;this "\\t") (p/wrap "\t")) + (p;after (l;this "\\b") (p/wrap "\b")) + (p;after (l;this "\\n") (p/wrap "\n")) + (p;after (l;this "\\r") (p/wrap "\r")) + (p;after (l;this "\\f") (p/wrap "\f")) + (p;after (l;this "\\\"") (p/wrap "\"")) + (p;after (l;this "\\\\") (p/wrap "\\")))) + +(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)))))) + +(def: (kv~ json~) + (-> (-> Unit (l;Lexer JSON)) (l;Lexer [..;String JSON])) + (do p;Monad<Parser> + [key string~ + _ space~ + _ (l;this ":") + _ space~ + value (json~ [])] + (wrap [key value]))) + +(do-template [<name> <type> <open> <close> <elem-parser> <prep>] + [(def: (<name> json~) + (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>)) + (do p;Monad<Parser> + [_ (l;this <open>) + _ space~ + elems (p;sep-by data-sep <elem-parser>) + _ space~ + _ (l;this <close>)] + (wrap (<prep> elems))))] + + [array~ ..;Array "[" "]" (json~ []) vector;from-list] + [object~ ..;Object "{" "}" (kv~ json~) (d;from-list text;Hash<Text>)] + ) + +(def: (json~' _) + (-> Unit (l;Lexer JSON)) + ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) + +(struct: #export _ (Codec Text JSON) + (def: encode show-json) + (def: decode (function [input] (l;run input (json~' []))))) + +## [Polytypism] +(def: #hidden _map_ + (All [a b] (-> (-> a b) (List a) (List b))) + L/map) + +(def: tag + (-> Nat Real) + (|>. nat-to-int int-to-real)) + +(def: #hidden (rec-encode non-rec) + (All [a] (-> (-> (-> a JSON) + (-> a JSON)) + (-> a JSON))) + (function [input] + (non-rec (rec-encode non-rec) input))) + +(poly: #hidden (Codec<JSON,?>//encode env :x:) + (let [->Codec//encode (: (-> Code Code) + (function [.type.] (` (-> (~ .type.) ..;JSON))))] + (with-expansions + [<basic> (do-template [<type> <matcher> <encoder>] + [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))] + + [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)] + [Bool poly;bool ..;boolean] + [Real poly;real ..;number] + [Text poly;text ..;string])] + ($_ macro;either + <basic> + (with-gensyms [g!input g!key g!val] + (do @ + [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:) + _ (poly;text :key:) + .val. (Codec<JSON,?>//encode env :val:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) + (function [(~ g!input)] + (|> (~ g!input) + d;entries + (;;_map_ (: (-> [Text (~ (poly;to-ast env :val:))] + [Text ..;JSON]) + (function [[(~ g!key) (~ g!val)]] + [(~ g!key) + ((~ .val.) (~ g!val))]))) + (d;from-list text;Hash<Text>) + #..;Object)) + ))))) + (do @ + [:sub: (poly;apply-1 (ident-for ;Maybe) :x:) + .sub. (Codec<JSON,?>//encode env :sub:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) + (..;nullable (~ .sub.)))))) + (do @ + [:sub: (poly;apply-1 (ident-for ;List) :x:) + .sub. (Codec<JSON,?>//encode env :sub:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) + (|>. (;;_map_ (~ .sub.)) vector;from-list ..;array))))) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [members (poly;sum+ :x:) + pattern-matching (M;map @ + (function [[tag :case:]] + (do @ + [g!encode (Codec<JSON,?>//encode env :case:)] + (wrap (list (` ((~ (code;nat tag)) (~ g!case))) + (` (..;json [(~ (code;real (;;tag tag))) + ((~ g!encode) (~ g!case))])))))) + (list;enumerate members))] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) + (function [(~ g!input)] + (case (~ g!input) + (~@ (L/join pattern-matching))))))))) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars members] (poly;variant :x:) + #let [new-env (poly;extend-env [:x: g!type-fun] + (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) + env)] + pattern-matching (M;map @ + (function [[name :case:]] + (do @ + [#let [tag (code;tag name)] + encoder (Codec<JSON,?>//encode new-env :case:)] + (wrap (list (` ((~ tag) (~ g!case))) + (` (..;json [(~ (code;text (product;right name))) + ((~ encoder) (~ g!case))])))))) + members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//encode (poly;to-ast env :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (L/map ->Codec//encode g!vars)) + (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] + (wrap (` (: (~ :x:+) + (function [(~@ g!vars) (~ g!input)] + (case (~ g!input) + (~@ (L/join pattern-matching)))) + ))))) + (with-gensyms [g!type-fun g!case g!input] + (do @ + [[g!vars members] (poly;record :x:) + #let [new-env (poly;extend-env [:x: g!type-fun] + (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) + env)] + synthesis (M;map @ + (function [[name :slot:]] + (do @ + [encoder (Codec<JSON,?>//encode new-env :slot:)] + (wrap [(` (~ (code;text (product;right name)))) + (` ((~ encoder) (get@ (~ (code;tag name)) (~ g!input))))]))) + members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//encode (poly;to-ast env :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (L/map ->Codec//encode g!vars)) + (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] + (wrap (` (: (~ :x:+) + (function [(~@ g!vars) (~ g!input)] + (..;json (~ (code;record synthesis)))) + ))))) + (with-gensyms [g!type-fun g!case] + (do @ + [[g!vars members] (poly;tuple :x:) + #let [new-env (poly;extend-env [:x: g!type-fun] + (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) + env)] + pattern-matching (M;map @ + (function [:member:] + (do @ + [g!member (macro;gensym "g!member") + encoder (Codec<JSON,?>//encode new-env :member:)] + (wrap [g!member encoder]))) + members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//encode (poly;to-ast env :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (L/map ->Codec//encode g!vars)) + (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))] + #let [.tuple. (` [(~@ (L/map product;left pattern-matching))])]] + (wrap (` (: (~ :x:+) + (function [(~@ g!vars) (~ .tuple.)] + (..;json [(~@ (L/map (function [[g!member g!encoder]] + (` ((~ g!encoder) (~ g!member)))) + pattern-matching))])) + ))) + )) + ## Type recursion + (with-gensyms [g!rec] + (do @ + [:non-rec: (poly;recursive :x:) + #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)] + .non-rec. (Codec<JSON,?>//encode new-env :non-rec:)] + (wrap (` (: (~ (poly;gen-type new-env ->Codec//encode g!rec (list) :x:)) + (;;rec-encode (;function [(~ g!rec)] + (~ .non-rec.)))))))) + (poly;self env :x:) + (poly;recursion env :x:) + ## Type applications + (do @ + [[:func: :args:] (poly;apply :x:) + .func. (Codec<JSON,?>//encode env :func:) + .args. (M;map @ (Codec<JSON,?>//encode env) :args:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) + ((~ .func.) (~@ .args.)))))) + ## Bound type-vars + (poly;bound env :x:) + ## If all else fails... + (macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :x:))) + )))) + +(poly: #hidden (Codec<JSON,?>//decode env :x:) + (let [->Codec//decode (: (-> Code Code) + (function [.type.] (` (..;Reader (~ .type.)))))] + (with-expansions + [<basic> (do-template [<type> <matcher> <decoder>] + [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))] + + [Unit poly;unit ../reader;null] + [Bool poly;bool ../reader;boolean] + [Real poly;real ../reader;number] + [Text poly;text ../reader;string])] + ($_ macro;either + <basic> + (do @ + [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:) + _ (poly;text :key:) + .val. (Codec<JSON,?>//decode env :val:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) + (../reader;object (~ .val.)))))) + (do @ + [:sub: (poly;apply-1 (ident-for ;Maybe) :x:) + .sub. (Codec<JSON,?>//decode env :sub:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) + (../reader;nullable (~ .sub.)))))) + (do @ + [:sub: (poly;apply-1 (ident-for ;List) :x:) + .sub. (Codec<JSON,?>//decode env :sub:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) + (../reader;array (p;some (~ .sub.))))))) + (with-gensyms [g!type-fun g!case g!_] + (do @ + [members (poly;sum+ :x:) + pattern-matching (M;map @ + (function [[tag :case:]] + (do @ + [g!decode (Codec<JSON,?>//decode env :case:)] + (wrap (list (` (|> (~ g!decode) + (p;after (../reader;number! (~ (code;real (;;tag tag))))) + ../reader;array)))))) + (list;enumerate members))] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) + ($_ p;alt + (~@ (L/join pattern-matching)))))))) + (with-gensyms [g!type-fun g!_] + (do @ + [[g!vars members] (poly;variant :x:) + #let [new-env (poly;extend-env [:x: g!type-fun] + (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) + env)] + pattern-matching (M;map @ + (function [[name :case:]] + (do @ + [g!decode (Codec<JSON,?>//decode new-env :case:)] + (wrap (list (` (|> (~ g!decode) + (:: p;Monad<Parser> (~' map) (|>. (~ (code;tag name)))) + (p;after (../reader;string! (~ (code;text (product;right name))))) + ../reader;array)))))) + members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//decode (poly;to-ast env :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (L/map ->Codec//decode g!vars)) + (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars))))))))) + base-parser (` ($_ p;either + (~@ (L/join pattern-matching)))) + parser (case g!vars + #;Nil + base-parser + + _ + (` (function [(~@ g!vars)] (~ base-parser))))]] + (wrap (` (: (~ :x:+) (~ parser)))) + )) + (with-gensyms [g!type-fun g!case] + (do @ + [[g!vars members] (poly;record :x:) + #let [new-env (poly;extend-env [:x: g!type-fun] + (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) + env)] + extraction (M;map @ + (function [[name :slot:]] + (do @ + [g!decoder (Codec<JSON,?>//decode new-env :slot:)] + (wrap (` (../reader;field (~ (code;text (product;right name))) + (~ g!decoder)))))) + members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//decode (poly;to-ast env :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (L/map ->Codec//decode g!vars)) + (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] + (case g!vars + #;Nil + (wrap (` (: (~ :x:+) + (|> ($_ p;seq (~@ extraction)) + (p;before ../reader;any))))) + + _ + (wrap (` (: (~ :x:+) + (function [(~@ g!vars)] + (|> ($_ p;seq (~@ extraction)) + (p;before ../reader;any))))))))) + (with-gensyms [g!type-fun g!case] + (do @ + [[g!vars members] (poly;tuple :x:) + #let [new-env (poly;extend-env [:x: g!type-fun] + (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars) + env)] + pattern-matching (M;map @ (Codec<JSON,?>//decode new-env) members) + #let [:x:+ (case g!vars + #;Nil + (->Codec//decode (poly;to-ast env :x:)) + + _ + (` (All (~ g!type-fun) [(~@ g!vars)] + (-> (~@ (L/map ->Codec//decode g!vars)) + (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))] + #let [.decoder. (case g!vars + #;Nil + (` (../reader;array ($_ p;seq (~@ pattern-matching)))) + + _ + (` (function [(~@ g!vars)] + (../reader;array ($_ p;seq (~@ pattern-matching))))))]] + (wrap (` (: (~ :x:+) (~ .decoder.)))) + )) + ## Type recursion + (with-gensyms [g!rec] + (do @ + [:non-rec: (poly;recursive :x:) + #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)] + .non-rec. (Codec<JSON,?>//decode new-env :non-rec:)] + (wrap (` (: (~ (poly;gen-type new-env ->Codec//decode g!rec (list) :x:)) + (p;rec (;function [(~ g!rec)] + (~ .non-rec.)))))))) + (poly;self env :x:) + (poly;recursion env :x:) + ## Type applications + (do @ + [[:func: :args:] (poly;apply :x:) + .func. (Codec<JSON,?>//decode env :func:) + .args. (M;map @ (Codec<JSON,?>//decode env) :args:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) + ((~ .func.) (~@ .args.)))))) + ## Bound type-vars + (do @ + [g!bound (poly;bound env :x:)] + (wrap g!bound)) + ## If all else fails... + (macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:))) + )))) + +(syntax: #export (Codec<JSON,?> :x:) + {#;doc (doc "A macro for automatically producing JSON codecs." + (type: Variant + (#Case0 Bool) + (#Case1 Text) + (#Case2 Real)) + + (type: Record + {#unit Unit + #bool Bool + #real Real + #text Text + #maybe (Maybe Real) + #list (List Real) + #variant Variant + #tuple [Bool Real Text] + #dict (Dict Text Real)}) + + (derived: (Codec<JSON,?> Record)))} + (with-gensyms [g!inputs] + (wrap (list (` (: (Codec ..;JSON (~ :x:)) + (struct (def: (~' encode) (Codec<JSON,?>//encode (~ :x:))) + (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ :x:)))) + ))))))) diff --git a/stdlib/source/lux/data/format/json/reader.lux b/stdlib/source/lux/data/format/json/reader.lux new file mode 100644 index 000000000..83713bcf3 --- /dev/null +++ b/stdlib/source/lux/data/format/json/reader.lux @@ -0,0 +1,177 @@ +(;module: {#;doc "Functionality for reading values in the JSON format. + + For more information, please see: http://www.json.org/"} + lux + (lux (control [monad #+ do Monad] + [eq #+ Eq] + codec + ["p" parser "p/" Monad<Parser>]) + (data [bool] + [text "text/" Monoid<Text>] + [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>] + ["R" result] + (coll [list] + [vector] + ["d" dict])) + ) + [.. #+ JSON Reader]) + +(def: unconsumed-input-error Text "Unconsumed JSON.") + +(def: #export (run json parser) + (All [a] (-> JSON (Reader a) (R;Result a))) + (case (p;run (list json) parser) + (#R;Success [remainder output]) + (case remainder + #;Nil + (#R;Success output) + + _ + (#R;Error unconsumed-input-error)) + + (#R;Error error) + (#R;Error error))) + +(def: #export (fail error) + (All [a] (-> Text (Reader a))) + (function [inputs] + (#R;Error error))) + +(def: #export any + {#;doc "Just returns the JSON input without applying any logic."} + (Reader JSON) + (<| (function [inputs]) + (case inputs + #;Nil + (#R;Error "Empty JSON stream.") + + (#;Cons head tail) + (#R;Success [tail head])))) + +(do-template [<name> <type> <tag> <desc>] + [(def: #export <name> + {#;doc (#;TextA ($_ text/append "Reads a JSON value as " <desc> "."))} + (Reader <type>) + (do p;Monad<Parser> + [head any] + (case head + (<tag> value) + (wrap value) + + _ + (fail ($_ text/append "JSON value is not " <desc> ".")))))] + + [null Unit #..;Null "null"] + [boolean Bool #..;Boolean "boolean"] + [number Real #..;Number "number"] + [string Text #..;String "string"] + ) + +(do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>] + [(def: #export (<test> test) + {#;doc (#;TextA ($_ text/append "Asks whether a JSON value is a " <desc> "."))} + (-> <type> (Reader Bool)) + (do p;Monad<Parser> + [head any] + (case head + (<tag> value) + (wrap (:: <eq> = test (<pre> value))) + + _ + (fail ($_ text/append "JSON value is not " <desc> "."))))) + + (def: #export (<check> test) + {#;doc (#;TextA ($_ text/append "Ensures a JSON value is a " <desc> "."))} + (-> <type> (Reader Unit)) + (do p;Monad<Parser> + [head any] + (case head + (<tag> value) + (let [value (<pre> value)] + (if (:: <eq> = test value) + (wrap []) + (fail ($_ text/append "Value mismatch: " (<encoder> test) "=/=" (<encoder> value))))) + + _ + (fail ($_ text/append "JSON value is not a " <desc> ".")))))] + + [boolean? boolean! Bool bool;Eq<Bool> (:: bool;Codec<Text,Bool> encode) #..;Boolean "boolean" id] + [number? number! Real number;Eq<Real> (:: number;Codec<Text,Real> encode) #..;Number "number" id] + [string? string! Text text;Eq<Text> text;encode #..;String "string" id] + ) + +(def: #export (nullable parser) + (All [a] (-> (Reader a) (Reader (Maybe a)))) + (p;alt null + parser)) + +(def: #export (array parser) + {#;doc "Parses a JSON array, assuming that every element can be parsed the same way."} + (All [a] (-> (Reader a) (Reader a))) + (do p;Monad<Parser> + [head any] + (case head + (#..;Array values) + (case (p;run (vector;to-list values) parser) + (#R;Error error) + (fail error) + + (#R;Success [remainder output]) + (case remainder + #;Nil + (wrap output) + + _ + (fail unconsumed-input-error))) + + _ + (fail "JSON value is not an array.")))) + +(def: #export (object parser) + {#;doc "Parses a JSON object, assuming that every element can be parsed the same way."} + (All [a] (-> (Reader a) (Reader (d;Dict Text a)))) + (do p;Monad<Parser> + [head any] + (case head + (#..;Object object) + (case (do R;Monad<Result> + [] + (|> (d;entries object) + (monad;map @ (function [[key val]] + (do @ + [val (run val parser)] + (wrap [key val])))) + (:: @ map (d;from-list text;Hash<Text>)))) + (#R;Success table) + (wrap table) + + (#R;Error error) + (fail error)) + + _ + (fail "JSON value is not an array.")))) + +(def: #export (field field-name parser) + {#;doc "Parses a field inside a JSON object."} + (All [a] (-> Text (Reader a) (Reader a))) + (do p;Monad<Parser> + [head any] + (case head + (#..;Object object) + (case (d;get field-name object) + (#;Some value) + (case (run value parser) + (#R;Success output) + (function [tail] + (#R;Success [(#;Cons (#..;Object (d;remove field-name object)) + tail) + output])) + + (#R;Error error) + (fail error)) + + _ + (fail ($_ text/append "JSON object does not have field \"" field-name "\"."))) + + _ + (fail "JSON value is not an object.")))) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 88ea5ecc0..37e5e7cb6 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -8,7 +8,8 @@ [ident] (coll [list "L/" Monad<List>]) (format [xml] - [json])) + [json] + [json/codec])) (time [instant] [duration] [date]) @@ -50,7 +51,7 @@ [%oct Nat (:: number;Octal@Codec<Text,Nat> encode)] [%hex Nat (:: number;Hex@Codec<Text,Nat> encode)] [%xml xml;XML (:: xml;Codec<Text,XML> encode)] - [%json json;JSON (:: json;Codec<Text,JSON> encode)] + [%json json;JSON (:: json/codec;Codec<Text,JSON> encode)] [%instant instant;Instant (:: instant;Codec<Text,Instant> encode)] [%duration duration;Duration (:: duration;Codec<Text,Duration> encode)] [%date date;Date (:: date;Codec<Text,Date> encode)] diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 6372b26f1..68e1427ee 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -4,14 +4,17 @@ (control [monad #+ do Monad] codec [eq #+ Eq] - pipe) + pipe + ["p" parser]) (data [text "Text/" Monoid<Text>] text/format ["R" result] [bool] [maybe] [number "i/" Number<Int>] - (format ["&" json]) + (format ["@" json] + (json ["@;" reader] + ["@;" codec])) (coll [vector #+ vector] ["d" dict] [list])) @@ -25,7 +28,7 @@ ) (def: gen-json - (r;Random &;JSON) + (r;Random @;JSON) (r;rec (function [gen-json] (do r;Monad<Random> [size (:: @ map (n.% +2) r;nat)] @@ -40,16 +43,16 @@ (context: "JSON" [sample gen-json - #let [(^open "&/") &;Eq<JSON> - (^open "&/") &;Codec<Text,JSON>]] + #let [(^open "@/") @;Eq<JSON> + (^open "@/") @codec;Codec<Text,JSON>]] ($_ seq (test "Every JSON is equal to itself." - (&/= sample sample)) + (@/= sample sample)) (test "Can encode/decode JSON." - (|> sample &/encode &/decode + (|> sample @/encode @/decode (case> (#;Right result) - (&/= sample result) + (@/= sample result) (#;Left _) false))) @@ -57,7 +60,7 @@ (type: Variant (#Case0 Bool) - (#Case1 Int) + (#Case1 Text) (#Case2 Real)) (type: #rec Recursive @@ -67,14 +70,13 @@ (type: Record {#unit Unit #bool Bool - #int Int #real Real #text Text - #maybe (Maybe Int) - #list (List Int) + #maybe (Maybe Real) + #list (List Real) #variant Variant - #tuple [Int Real Text] - #dict (d;Dict Text Int) + #tuple [Bool Real Text] + #dict (d;Dict Text Real) #recursive Recursive}) (def: gen-recursive @@ -88,23 +90,21 @@ (def: gen-record (r;Random Record) (do r;Monad<Random> - [size (:: @ map (n.% +2) r;nat) - #let [gen-int (|> r;int (:: @ map (|>. i/abs (i.% 1_000_000))))]] + [size (:: @ map (n.% +2) r;nat)] ($_ r;seq (:: @ wrap []) r;bool - gen-int r;real (r;text size) - (r;maybe gen-int) - (r;list size gen-int) - ($_ r;alt r;bool gen-int r;real) - ($_ r;seq gen-int r;real (r;text size)) - (r;dict text;Hash<Text> size (r;text size) gen-int) + (r;maybe r;real) + (r;list size r;real) + ($_ r;alt r;bool (r;text size) r;real) + ($_ r;seq r;bool r;real (r;text size)) + (r;dict text;Hash<Text> size (r;text size) r;real) gen-recursive ))) -(derived: (&;Codec<JSON,?> Record)) +(derived: (@codec;Codec<JSON,?> Record)) (struct: _ (Eq Record) (def: (= recL recR) @@ -114,7 +114,7 @@ (:: bool;Eq<Bool> = left' right') [(#Case1 left') (#Case1 right')] - (i.= left' right') + (:: text;Eq<Text> = left' right') [(#Case2 left') (#Case2 right')] (r.= left' right') @@ -122,29 +122,28 @@ _ false))] (and (:: bool;Eq<Bool> = (get@ #bool recL) (get@ #bool recR)) - (i.= (get@ #int recL) (get@ #int recR)) (r.= (get@ #real recL) (get@ #real 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)) + (:: (maybe;Eq<Maybe> number;Eq<Real>) = (get@ #maybe recL) (get@ #maybe recR)) + (:: (list;Eq<List> number;Eq<Real>) = (get@ #list recL) (get@ #list recR)) (variant/= (get@ #variant recL) (get@ #variant recR)) (let [[tL0 tL1 tL2] (get@ #tuple recL) [tR0 tR1 tR2] (get@ #tuple recR)] - (and (i.= tL0 tR0) + (and (:: bool;Eq<Bool> = tL0 tR0) (r.= tL1 tR1) (:: text;Eq<Text> = tL2 tR2))) - (:: (d;Eq<Dict> i.=) = (get@ #dict recL) (get@ #dict recR)) + (:: (d;Eq<Dict> number;Eq<Real>) = (get@ #dict recL) (get@ #dict recR)) (:: Eq<Recursive> = (get@ #recursive recL) (get@ #recursive recR)) )))) (context: "Polytypism" [sample gen-record - #let [(^open "&/") Eq<Record> - (^open "&/") Codec<JSON,Record>]] + #let [(^open "@/") Eq<Record> + (^open "@/") Codec<JSON,Record>]] (test "Can encode/decode arbitrary types." - (|> sample &/encode &/decode - (case> (#;Right result) - (&/= sample result) + (|> sample @/encode @/decode + (case> (#R;Success result) + (@/= sample result) - (#;Left _) + (#R;Error error) false)))) |