path: root/stdlib/source/lux/data/format/json.lux

##  Copyright (c) Eduardo Julian. All rights reserved.
##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
##  If a copy of the MPL was not distributed with this file,
##  You can obtain one at http://mozilla.org/MPL/2.0/.

(;module:
  lux
  (lux (control functor
                applicative
                monad
                eq
                codec)
       (data [bool]
             [text "Text/" Eq<Text> Monoid<Text>]
             text/format
             [number #* "Real/" Codec<Text,Real>]
             maybe
             [char "Char/" Eq<Char> Codec<Text,Char>]
             [error #- fail]
             [sum]
             [product]
             (struct [list "" Fold<List> "List/" Monad<List>]
                     [vector #+ Vector vector "Vector/" Monad<Vector>]
                     [dict #+ Dict]))
       (codata [function])
       [compiler #+ Monad<Lux> with-gensyms]
       (macro [syntax #+ syntax:]
              [ast]
              [poly #+ poly:])
       [type]
       [lexer #+ Lexer Monad<Lexer>]))

## [Types]
(do-template [<name> <type>]
  [(type: #export <name> <type>)]

  [Null    Unit]
  [Boolean Bool]
  [Number  Real]
  [String  Text]
  )

(type: #export #rec JSON
  (#Null    Null)
  (#Boolean Boolean)
  (#Number  Number)
  (#String  String)
  (#Array   (Vector JSON))
  (#Object  (Dict String JSON)))

(do-template [<name> <type>]
  [(type: #export <name> <type>)]

  [Array   (Vector JSON)]
  [Object  (Dict String JSON)]
  )

(type: #export (Parser a)
  (-> JSON (Error a)))

(type: #export (Gen a)
  (-> a JSON))

## [Syntax]
(syntax: #export (json token)
  (let [(^open) Monad<Lux>
        wrapper (lambda [x] (` (;;json (~ x))))]
    (case token
      (^template [<ast-tag> <ctor> <json-tag>]
        [_ (<ast-tag> value)]
        (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value))))))))
      ([#;BoolS ast;bool            #Boolean]
       [#;IntS  (|>. int-to-real ast;real) #Number]
       [#;RealS ast;real            #Number]
       [#;TextS ast;text            #String])

      [_ (#;TagS ["" "null"])]
      (wrap (list (` (: JSON #Null))))

      [_ (#;TupleS members)]
      (wrap (list (` (: JSON (#Array (vector (~@ (List/map wrapper members))))))))

      [_ (#;RecordS pairs)]
      (do Monad<Lux>
        [pairs' (mapM @
                      (lambda [[slot value]]
                        (case slot
                          [_ (#;TextS key-name)]
                          (wrap (` [(~ (ast;text key-name)) (~ (wrapper value))]))

                          _
                          (compiler;fail "Wrong syntax for JSON object.")))
                      pairs)]
        (wrap (list (` (: JSON (#Object (dict;from-list text;Hash<Text> (list (~@ pairs')))))))))
      
      _
      (wrap (list token))
      )))

## [Values]
(def: #hidden (show-null _) (-> Null Text) "null")
(do-template [<name> <type> <codec>]
  [(def: <name> (-> <type> Text) (:: <codec> encode))]

  [show-boolean Boolean bool;Codec<Text,Bool>]
  [show-number  Number number;Codec<Text,Real>]
  [show-string  String text;Codec<Text,Text>])

(def: (show-array show-json elems)
  (-> (-> JSON Text) (-> Array Text))
  (format "["
          (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
          "]"))

(def: (show-object show-json object)
  (-> (-> JSON Text) (-> Object Text))
  (format "{"
          (|> object
              dict;entries
              (List/map (lambda [[key value]] (format (:: text;Codec<Text,Text> encode 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
  JSON
  #Null)

(def: #export (keys json)
  (-> JSON (Error (List String)))
  (case json
    (#Object obj)
    (#;Right (dict;keys obj))

    _
    (#;Left (format "Can't get keys of a non-object."))))

(def: #export (get key json)
  (-> String JSON (Error JSON))
  (case json
    (#Object obj)
    (case (dict;get key obj)
      (#;Some value)
      (#;Right value)

      #;None
      (#;Left (format "Missing field " (show-string key) " on object.")))

    _
    (#;Left (format "Can't get field " (show-string key) " of a non-object."))))

(def: #export (set key value json)
  (-> String JSON JSON (Error JSON))
  (case json
    (#Object obj)
    (#;Right (#Object (dict;put key value obj)))

    _
    (#;Left (format "Can't set field " (show-string key) " of a non-object."))))

(do-template [<name> <tag> <type>]
  [(def: #export (<name> key json)
     (-> Text JSON (Error <type>))
     (case (get key json)
       (#;Right (<tag> value))
       (#;Right value)

       (#;Right _)
       (#;Left (format "Wrong value type at key " (show-string key)))

       (#;Left error)
       (#;Left error)))]

  [get-boolean #Boolean Boolean]
  [get-number  #Number  Number]
  [get-string  #String  String]
  [get-array   #Array   Array]
  [get-object  #Object  Object]
  )

(do-template [<name> <type> <tag>]
  [(def: #export (<name> value)
     (Gen <type>)
     (<tag> value))]

  [gen-boolean Boolean #Boolean]
  [gen-number  Number  #Number]
  [gen-string  String  #String]
  [gen-array   Array   #Array]
  [gen-object  Object  #Object]
  )

(def: #export (gen-nullable gen)
  (All [a] (-> (Gen a) (Gen (Maybe a))))
  (lambda [elem]
    (case elem
      #;None         #Null
      (#;Some value) (gen value))))

## Lexers
(def: space~
  (Lexer Text)
  (lexer;some' lexer;space))

(def: data-sep
  (Lexer [Text Char Text])
  ($_ lexer;seq space~ (lexer;char #",") space~))

(def: null~
  (Lexer Null)
  (do Monad<Lexer>
    [_ (lexer;text "null")]
    (wrap [])))

(do-template [<name> <token> <value>]
  [(def: <name>
     (Lexer Boolean)
     (do Monad<Lexer>
       [_ (lexer;text <token>)]
       (wrap <value>)))]

  [t~ "true"  true]
  [f~ "false" false]
  )

(def: boolean~
  (Lexer Boolean)
  (lexer;either t~ f~))

(def: number~
  (Lexer Number)
  (do Monad<Lexer>
    [?sign (: (Lexer Text)
              (lexer;default ""
                (lexer;text "-")))
     digits (: (Lexer Text)
               (lexer;many' lexer;digit))
     decimals (: (Lexer Text)
                 (lexer;default "0"
                   (do @
                     [_ (lexer;text ".")]
                     (lexer;many' lexer;digit))))
     exp (: (Lexer Text)
            (lexer;default ""
              (do @
                [mark (lexer;either (lexer;text "e") (lexer;text "E"))
                 sign (lexer;default "" (lexer;text "-"))
                 offset (lexer;many' lexer;digit)]
                (wrap (format mark sign offset)))))]
    (case (: (Error Real)
             (Real/decode (format ?sign digits "." decimals exp)))
      (#;Left message)
      (lexer;fail message)
      
      (#;Right value)
      (wrap value))))

(def: (un-escape escaped)
  (-> Char Text)
  (case escaped
    #"t"  "\t"
    #"b"  "\b"
    #"n"  "\n"
    #"r"  "\r"
    #"f"  "\f"
    #"\"" "\""
    #"\\" "\\"
    _     ""))

(def: string-body~
  (Lexer Text)
  (loop [_ []]
    (do Monad<Lexer>
      [chars (lexer;some' (lexer;none-of "\\\""))
       stop-char lexer;peek]
      (if (Char/= #"\\" stop-char)
        (do @
          [_ lexer;any
           escaped lexer;any
           next-chars (recur [])]
          (wrap (format chars (un-escape escaped) next-chars)))
        (wrap chars)))))

(def: string~
  (Lexer String)
  (do Monad<Lexer>
    [_ (lexer;text "\"")
     string-body string-body~
     _ (lexer;text "\"")]
    (wrap string-body)))

(def: (kv~ json~)
  (-> (-> Unit (Lexer JSON)) (Lexer [String JSON]))
  (do Monad<Lexer>
    [key string~
     _ space~
     _ (lexer;char #":")
     _ space~
     value (json~ [])]
    (wrap [key value])))

(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
  [(def: (<name> json~)
     (-> (-> Unit (Lexer JSON)) (Lexer <type>))
     (do Monad<Lexer>
       [_ (lexer;char <open>)
        _ space~
        elems (lexer;sep-by data-sep <elem-parser>)
        _ space~
        _ (lexer;char <close>)]
       (wrap (<prep> elems))))]

  [array~  Array  #"[" #"]" (json~ [])  vector;from-list]
  [object~ Object #"{" #"}" (kv~ json~) (dict;from-list text;Hash<Text>)]
  )

(def: (json~' _)
  (-> Unit (Lexer JSON))
  ($_ lexer;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))

## [Structures]
(struct: #export _ (Functor Parser)
  (def: (map f ma)
    (lambda [json]
      (case (ma json)
        (#;Left msg)
        (#;Left msg)

        (#;Right a)
        (#;Right (f a))))))

(struct: #export _ (Applicative Parser)
  (def: functor Functor<Parser>)

  (def: (wrap x json)
    (#;Right x))

  (def: (apply ff fa)
    (lambda [json]
      (case (ff json)
        (#;Right f)
        (case (fa json)
          (#;Right a)
          (#;Right (f a))

          (#;Left msg)
          (#;Left msg))

        (#;Left msg)
        (#;Left msg)))))

(struct: #export _ (Monad Parser)
  (def: applicative Applicative<Parser>)

  (def: (join mma)
    (lambda [json]
      (case (mma json)
        (#;Left msg)
        (#;Left msg)

        (#;Right ma)
        (ma json)))))

## [Values]
## Syntax
(do-template [<name> <type> <tag> <desc> <pre>]
  [(def: #export (<name> json)
     (Parser <type>)
     (case json
       (<tag> value)
       (#;Right (<pre> value))

       _
       (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))]

  [unit Unit #Null    "null"    id]
  [bool Bool #Boolean "boolean" id]
  [int  Int  #Number  "number"  real-to-int]
  [real Real #Number  "number"  id]
  [text Text #String  "string"  id]
  )

(do-template [<test> <check> <type> <eq> <codec> <tag> <desc> <pre>]
  [(def: #export (<test> test json)
     (-> <type> (Parser Bool))
     (case json
       (<tag> value)
       (#;Right (:: <eq> = test (<pre> value)))

       _
       (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))

   (def: #export (<check> test json)
     (-> <type> (Parser Unit))
     (case json
       (<tag> value)
       (let [value (<pre> value)]
         (if (:: <eq> = test value)
           (#;Right [])
           (#;Left (format "Value mismatch: "
                           (:: <codec> encode test) "=/=" (:: <codec> encode value)))))

       _
       (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))]

  [bool? bool! Bool bool;Eq<Bool>   bool;Codec<Text,Bool>   #Boolean "boolean" id]
  [int?  int!  Int  number;Eq<Int>  number;Codec<Text,Int>  #Number  "number"  real-to-int]
  [real? real! Real number;Eq<Real> number;Codec<Text,Real> #Number  "number"  id]
  [text? text! Text text;Eq<Text>   text;Codec<Text,Text>   #String  "string"  id]
  )

(def: #export (char json)
  (Parser Char)
  (case json
    (#String input)
    (case (Char/decode (format "#\"" input "\""))
      (#;Right value)
      (#;Right value)

      (#;Left _)
      (#;Left (format "Invalid format for char: " input)))

    _
    (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))

(def: #export (char? test json)
  (-> Char (Parser Bool))
  (case json
    (#String input)
    (case (Char/decode (format "#\"" input "\""))
      (#;Right value)
      (if (:: char;Eq<Char> = test value)
        (#;Right true)
        (#;Left (format "Value mismatch: "
                        (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value))))

      (#;Left _)
      (#;Left (format "Invalid format for char: " input)))

    _
    (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))

(def: #export (char! test json)
  (-> Char (Parser Unit))
  (case json
    (#String input)
    (case (Char/decode (format "#\"" input "\""))
      (#;Right value)
      (if (:: char;Eq<Char> = test value)
        (#;Right [])
        (#;Left (format "Value mismatch: "
                        (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value))))

      (#;Left _)
      (#;Left (format "Invalid format for char: " input)))

    _
    (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))

(def: #export (nullable parser)
  (All [a] (-> (Parser a) (Parser (Maybe a))))
  (lambda [json]
    (case json
      #Null
      (#;Right #;None)
      
      _
      (case (parser json)
        (#;Left error)
        (#;Left error)

        (#;Right value)
        (#;Right (#;Some value)))
      )))

(def: #export (array parser)
  (All [a] (-> (Parser a) (Parser (List a))))
  (lambda [json]
    (case json
      (#Array values)
      (do Monad<Error>
        [elems (mapM @ parser (vector;to-list values))]
        (wrap elems))

      _
      (#;Left (format "JSON value is not an array: " (show-json json))))))

(def: #export (object parser)
  (All [a] (-> (Parser a) (Parser (Dict String a))))
  (lambda [json]
    (case json
      (#Object fields)
      (do Monad<Error>
        [kvs (mapM @
                   (lambda [[key val']]
                     (do @
                       [val (parser val')]
                       (wrap [key val])))
                   (dict;entries fields))]
        (wrap (dict;from-list text;Hash<Text> kvs)))

      _
      (#;Left (format "JSON value is not an object: " (show-json json))))))

(def: #export (at idx parser)
  (All [a] (-> Nat (Parser a) (Parser a)))
  (lambda [json]
    (case json
      (#Array values)
      (case (vector;at idx values)
        (#;Some value)
        (case (parser value)
          (#;Right output)
          (#;Right output)

          (#;Left error)
          (#;Left (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json))))

        #;None
        (#;Left (format "JSON array does not have index " (%n idx) " @ " (show-json json))))
      
      _
      (#;Left (format "JSON value is not an array: " (show-json json))))))

(def: #export (field field-name parser)
  (All [a] (-> Text (Parser a) (Parser a)))
  (lambda [json]
    (case (get field-name json)
      (#;Some value)
      (case (parser value)
        (#;Right output)
        (#;Right output)

        (#;Left error)
        (#;Left (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json))))

      (#;Left _)
      (#;Left (format "JSON object does not have field " (show-string field-name) " @ " (show-json json))))))

(def: #export any
  (Parser JSON)
  (lambda [json]
    (#;Right json)))

(def: #export (seq pa pb)
  (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 json)
  (All [a b] (-> (Parser a) (Parser b) (Parser (| a b))))
  (case (pa json)
    (#;Right a)
    (sum;right (sum;left a))

    (#;Left message0)
    (case (pb json)
      (#;Right b)
      (sum;right (sum;right b))

      (#;Left message1)
      (#;Left message0))))

(def: #export (either pl pr json)
  (All [a] (-> (Parser a) (Parser a) (Parser a)))
  (case (pl json)
    (#;Right x)
    (#;Right x)

    _
    (pr json)))

(def: #export (opt p json)
  (All [a]
    (-> (Parser a) (Parser (Maybe a))))
  (case (p json)
    (#;Left _)  (#;Right #;None)
    (#;Right x) (#;Right (#;Some x))))

(def: #export (run parser json)
  (All [a] (-> (Parser a) JSON (Error a)))
  (parser json))

(def: #export (ensure test parser json)
  (All [a] (-> (Parser Unit) (Parser a) (Parser a)))
  (case (test json)
    (#;Right _)
    (parser json)

    (#;Left error)
    (#;Left error)))

(def: #export (array-size! array-size json)
  (-> Nat (Parser Unit))
  (case json
    (#Array parts)
    (if (n.= array-size (vector;size parts))
      (#;Right [])
      (#;Left (format "JSON array does no have size " (%n array-size) " " (show-json json))))

    _
    (#;Left (format "JSON value is not an array: " (show-json json)))))

(def: #export (object-fields! wanted-fields json)
  (-> (List String) (Parser Unit))
  (case json
    (#Object kvs)
    (let [actual-fields (dict;keys kvs)]
      (if (and (n.= (list;size wanted-fields) (list;size actual-fields))
               (list;every? (list;member? text;Eq<Text> wanted-fields)
                            actual-fields))
        (#;Right [])
        (#;Left (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]"))))

    _
    (#;Left (format "JSON value is not an object: " (show-json json)))))

## [Structures]
(struct: #export _ (Eq JSON)
  (def: (= x y)
    (case [x y]
      [#Null #Null]
      true

      (^template [<tag> <struct>]
        [(<tag> x') (<tag> y')]
        (:: <struct> = x' y'))
      ([#Boolean bool;Eq<Bool>]
       [#Number  number;Eq<Real>]
       [#String  text;Eq<Text>])

      [(#Array xs) (#Array ys)]
      (and (n.= (vector;size xs) (vector;size ys))
           (fold (lambda [idx prev]
                   (and prev
                        (default false
                          (do Monad<Maybe>
                            [x' (vector;at idx xs)
                             y' (vector;at idx ys)]
                            (wrap (= x' y'))))))
                 true
                 (list;indices (vector;size xs))))
      
      [(#Object xs) (#Object ys)]
      (and (n.= (dict;size xs) (dict;size ys))
           (fold (lambda [[xk xv] prev]
                   (and prev
                        (case (dict;get xk ys)
                          #;None   false
                          (#;Some yv) (= xv yv))))
                 true
                 (dict;entries xs)))
      
      _
      false)))

(struct: #export _ (Codec Text JSON)
  (def: encode show-json)
  (def: decode (lexer;run (json~' []))))

## [Syntax]
(type: Shape
  (#ArrayShape (List AST))
  (#ObjectShape (List [Text AST])))

(def: _shape^
  (syntax;Syntax Shape)
  (syntax;alt (syntax;tuple (syntax;some syntax;any))
              (syntax;record (syntax;some (syntax;seq syntax;text syntax;any)))))

(syntax: #export (shape^ [shape _shape^])
  (case shape
    (#ArrayShape parts)
    (let [array-size (list;size parts)
          parsers (|> parts
                      (list;zip2 (list;indices array-size))
                      (List/map (lambda [[idx parser]]
                                  (` (at (~ (ast;nat idx)) (~ parser))))))]
      (wrap (list (` ($_ seq (~@ parsers))))))

    (#ObjectShape kvs)
    (let [fields (List/map product;left kvs)
          parsers (List/map (lambda [[field-name parser]]
                              (` (field (~ (ast;text field-name)) (~ parser))))
                            kvs)]
      (wrap (list (` ($_ seq (~@ parsers))))))
    ))

(syntax: #export (shape!^ [shape _shape^])
  (case shape
    (#ArrayShape parts)
    (let [array-size (list;size parts)
          parsers (|> parts
                      (list;zip2 (list;indices array-size))
                      (List/map (lambda [[idx parser]]
                                  (` (at (~ (ast;nat idx)) (~ parser))))))]
      (wrap (list (` (ensure (array-size! (~ (ast;nat array-size)))
                             ($_ seq (~@ parsers)))))))

    (#ObjectShape kvs)
    (let [fields (List/map product;left kvs)
          parsers (List/map (lambda [[field-name parser]]
                              (` (field (~ (ast;text field-name)) (~ parser))))
                            kvs)]
      (wrap (list (` (ensure (object-fields! (list (~@ (List/map ast;text fields))))
                             ($_ seq (~@ parsers)))))))
    ))

## [Polytypism]
(def: #hidden _map_
  (All [a b] (-> (-> a b) (List a) (List b)))
  List/map)

(poly: #export (Codec<JSON,?>//encode *env* :x:)
  (let [->Codec//encode (: (-> AST AST)
                           (lambda [.type.] (` (-> (~ .type.) JSON))))]
    (let% [<basic> (do-template [<type> <matcher> <encoder>]
                     [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))]

                     [Unit poly;unit (lambda [(~ (ast;symbol ["" "0"]))] #Null)]
                     [Bool poly;bool ;;gen-boolean]
                     [Int  poly;int  (|>. ;int-to-real ;;gen-number)]
                     [Real poly;real ;;gen-number]
                     [Char poly;char (|>. char;as-text ;;gen-string)]
                     [Text poly;text ;;gen-string])]
      ($_ compiler;either
          <basic>
          (with-gensyms [g!type-fun g!case g!input g!key g!val]
            (do @
              [:sub: (poly;list :x:)
               [g!vars members] (poly;tuple :sub:)
               :val: (case members
                       (^ (list :key: :val:))
                       (do @ [_ (poly;text :key:)]
                         (wrap :val:))

                       _
                       (compiler;fail ""))
               #let [new-*env* (poly;extend-env [:x: g!type-fun]
                                                (list;zip2 (|> g!vars list;size poly;type-var-indices)
                                                           g!vars)
                                                *env*)]
               .val. (Codec<JSON,?>//encode new-*env* :val:)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//encode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//encode g!vars))
                                     (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
              (wrap (` (: (~ :x:+)
                          (lambda [(~@ g!vars) (~ g!input)]
                            (|> (~ g!input)
                                (_map_ (: (-> [Text (~ (type;to-ast :val:))]
                                              [Text JSON])
                                          (lambda [[(~ g!key) (~ g!val)]]
                                            [(~ g!key)
                                             ((~ .val.) (~ g!val))])))
                                ;;object))
                          )))
              ))
          (do @
            [:sub: (poly;maybe :x:)
             .sub. (Codec<JSON,?>//encode *env* :sub:)]
            (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
                        (;;gen-nullable (~ .sub.))))))
          (do @
            [:sub: (poly;list :x:)
             .sub. (Codec<JSON,?>//encode *env* :sub:)]
            (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
                        (|>. (_map_ (~ .sub.)) vector;from-list ;;gen-array)))))
          (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 (mapM @
                                      (lambda [[name :case:]]
                                        (do @
                                          [#let [tag (ast;tag name)]
                                           encoder (Codec<JSON,?>//encode new-*env* :case:)]
                                          (wrap (list (` ((~ tag) (~ g!case)))
                                                      (` (;;json [(~ (ast;text (product;right name)))
                                                                  ((~ encoder) (~ g!case))]))))))
                                      members)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//encode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//encode g!vars))
                                     (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
              (wrap (` (: (~ :x:+)
                          (lambda [(~@ g!vars) (~ g!input)]
                            (case (~ g!input)
                              (~@ (List/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 (mapM @
                               (lambda [[name :slot:]]
                                 (do @
                                   [encoder (Codec<JSON,?>//encode new-*env* :slot:)]
                                   (wrap [(` (~ (ast;text (product;right name))))
                                          (` ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))])))
                               members)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//encode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//encode g!vars))
                                     (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
              (wrap (` (: (~ :x:+)
                          (lambda [(~@ g!vars) (~ g!input)]
                            (;;json (~ (ast;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 (mapM @
                                      (lambda [:member:]
                                        (do @
                                          [g!member (compiler;gensym "g!member")
                                           encoder (Codec<JSON,?>//encode new-*env* :member:)]
                                          (wrap [g!member encoder])))
                                      members)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//encode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//encode g!vars))
                                     (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]
               #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]]
              (wrap (` (: (~ :x:+)
                          (lambda [(~@ g!vars) (~ .tuple.)]
                            (;;json [(~@ (List/map (lambda [[g!member g!encoder]]
                                                     (` ((~ g!encoder) (~ g!member))))
                                                   pattern-matching))]))
                          )))
              ))
          (do @
            [[:func: :args:] (poly;apply :x:)
             .func. (Codec<JSON,?>//encode *env* :func:)
             .args. (mapM @ (Codec<JSON,?>//encode *env*) :args:)]
            (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
                        ((~ .func.) (~@ .args.))))))
          (poly;bound *env* :x:)
          (compiler;fail (format "Can't create JSON encoder for: " (%type :x:)))
          ))))

(poly: #export (Codec<JSON,?>//decode *env* :x:)
  (let [->Codec//decode (: (-> AST AST)
                           (lambda [.type.] (` (-> JSON (Error (~ .type.))))))]
    (let% [<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]
                     [Char poly;char ;;char]
                     [Text poly;text ;;text])
           <complex> (do-template [<type> <matcher> <decoder>]
                       [(do @
                          [:sub: (<matcher> :x:)
                           .sub. (Codec<JSON,?>//decode *env* :sub:)]
                          (wrap (` (: (~ (->Codec//decode (type;to-ast :x:)))
                                      (<decoder> (~ .sub.))))))]

                       [Maybe poly;maybe ;;nullable]
                       [List  poly;list  ;;array])]
      ($_ compiler;either
          <basic>
          (with-gensyms [g!type-fun g!case g!input g!key g!val]
            (do @
              [:sub: (poly;list :x:)
               [g!vars members] (poly;tuple :sub:)
               :val: (case members
                       (^ (list :key: :val:))
                       (do @ [_ (poly;text :key:)]
                         (wrap :val:))

                       _
                       (compiler;fail ""))
               #let [new-*env* (poly;extend-env [:x: g!type-fun]
                                                (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
                                                *env*)]
               .val. (Codec<JSON,?>//decode new-*env* :val:)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//decode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//decode g!vars))
                                     (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
              (wrap (` (: (~ :x:+)
                          (lambda [(~@ g!vars) (~ g!input)]
                            (do Monad<Error>
                              [(~ g!key) (;;keys (~ g!input))]
                              (mapM (~ (' %))
                                    (lambda [(~ g!key)]
                                      (do Monad<Error>
                                        [(~ g!val) (;;get (~ g!key) (~ g!input))
                                         (~ g!val) (;;run (~ .val.) (~ g!val))]
                                        ((~ (' wrap)) [(~ g!key) (~ g!val)])))
                                    (~ g!key))))
                          )))
              ))
          <complex>
          (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 (mapM @
                                      (lambda [[name :case:]]
                                        (do @
                                          [#let [tag (ast;tag name)]
                                           decoder (Codec<JSON,?>//decode new-*env* :case:)]
                                          (wrap (list (` (do Monad<Parser>
                                                           [(~ g!_) (;;at +0 (;;text! (~ (ast;text (product;right name)))))
                                                            (~ g!_) (;;at +1 (~ decoder))]
                                                           ((~ (' wrap)) ((~ tag) (~ g!_)))))))))
                                      members)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//decode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//decode g!vars))
                                     (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))
                     base-parser (` ($_ ;;either
                                        (~@ (List/join pattern-matching))))
                     parser (case g!vars
                              #;Nil
                              base-parser

                              _
                              (` (lambda [(~@ 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 (mapM @
                                (lambda [[name :slot:]]
                                  (do @
                                    [#let [g!member (ast;symbol ["" (product;right name)])]
                                     decoder (Codec<JSON,?>//decode new-*env* :slot:)]
                                    (wrap (list g!member
                                                (` (;;get (~ (ast;text (product;right name))) (~ g!input)))
                                                g!member
                                                (` ((~ decoder) (~ g!member)))))))
                                members)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//decode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//decode g!vars))
                                     (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]]
              (wrap (` (: (~ :x:+)
                          (lambda [(~@ g!vars) (~ g!input)]
                            (do Monad<Error>
                              [(~@ (List/join extraction))]
                              ((~ (' wrap)) (~ (ast;record (List/map (lambda [[name :slot:]]
                                                                       [(ast;tag name) (ast;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 (mapM @
                                      (lambda [:member:]
                                        (do @
                                          [g!member (compiler;gensym "g!member")
                                           decoder (Codec<JSON,?>//decode new-*env* :member:)]
                                          (wrap [g!member decoder])))
                                      members)
               #let [:x:+ (case g!vars
                            #;Nil
                            (->Codec//decode (type;to-ast :x:))

                            _
                            (` (All (~ g!type-fun) [(~@ g!vars)]
                                 (-> (~@ (List/map ->Codec//decode g!vars))
                                     (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]
               #let [.decoder. (case g!vars
                                 #;Nil
                                 (` (;;shape^ [(~@ (List/map product;right pattern-matching))]))

                                 _
                                 (` (lambda [(~@ g!vars)]
                                      (;;shape^ [(~@ (List/map product;right pattern-matching))]))))]]
              (wrap (` (: (~ :x:+) (~ .decoder.))))
              ))
          (do @
            [[:func: :args:] (poly;apply :x:)
             .func. (Codec<JSON,?>//decode *env* :func:)
             .args. (mapM @ (Codec<JSON,?>//decode *env*) :args:)]
            (wrap (` (: (~ (->Codec//decode (type;to-ast :x:)))
                        ((~ .func.) (~@ .args.))))))
          (do @
            [g!bound (poly;bound *env* :x:)]
            (wrap g!bound))
          (compiler;fail (format "Can't create JSON decoder for: " (%type :x:)))
          ))))

(syntax: #export (Codec<JSON,?> :x:)
  (wrap (list (` (: (Codec JSON (~ :x:))
                    (struct
                     (def: (~ (' encode)) (Codec<JSON,?>//encode (~ :x:)))
                     (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:)))
                     ))))))