From b802e8efe275ee75473b755429b1805c5c83abbd Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 1 Aug 2017 00:12:40 -0400
Subject: - Broken down lux/data/format/json module into smaller family of
 modules. - Re-implemented JSON parsing in terms of lux/control/parser.

---
 stdlib/source/lux/data/format/json.lux | 910 +--------------------------------
 1 file changed, 19 insertions(+), 891 deletions(-)

(limited to 'stdlib/source/lux/data/format/json.lux')

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:)))
-                            ))))))
-- 
cgit v1.2.3