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

(.using
 [library
  [lux {"-" has}
   ["[0]" meta {"+" monad}]
   [abstract
    [equivalence {"+" Equivalence}]
    [codec {"+" Codec}]
    [predicate {"+" Predicate}]
    ["[0]" monad {"+" do}]]
   [control
    ["[0]" pipe]
    ["[0]" maybe]
    ["[0]" try {"+" Try}]
    ["<>" parser ("[1]#[0]" monad)
     ["<[0]>" text {"+" Parser}]
     ["<[0]>" code]]]
   [data
    ["[0]" bit]
    ["[0]" product]
    ["[0]" text ("[1]#[0]" equivalence monoid)]
    [collection
     ["[0]" list ("[1]#[0]" mix functor)]
     ["[0]" sequence {"+" Sequence sequence} ("[1]#[0]" monad)]
     ["[0]" dictionary {"+" Dictionary}]]]
   [macro
    [syntax {"+" syntax:}]
    ["^" pattern]
    ["[0]" code]]
   [math
    [number
     ["n" nat]
     ["f" frac ("[1]#[0]" decimal)]]]]])

(template [<name> <type>]
  [(type: .public <name>
     <type>)]

  [Null    Any]
  [Boolean Bit]
  [Number  Frac]
  [String  Text]
  )

(type: .public JSON
  (Rec JSON
    (Variant
     {#Null    Null}
     {#Boolean Boolean}
     {#Number  Number}
     {#String  String}
     {#Array   (Sequence JSON)}
     {#Object  (Dictionary String JSON)})))

(template [<name> <type>]
  [(type: .public <name>
     <type>)]

  [Array  (Sequence JSON)]
  [Object (Dictionary String JSON)]
  )

(def: .public null?
  (Predicate JSON)
  (|>> (pipe.case {#Null} true
         _ false)))

(def: .public object
  (-> (List [String JSON]) JSON)
  (|>> (dictionary.of_list text.hash) {..#Object}))

(type: JSON'
  (Rec JSON'
    (Variant
     {#Null'    Null}
     {#Boolean' Boolean}
     {#Number'  Number}
     {#String'  String}
     {#Array'   (Sequence JSON')}
     {#Object'  (Dictionary String JSON')}
     {#Code'    Code})))

(def: jsonP
  (<code>.Parser JSON')
  (<>.rec
   (function (_ jsonP)
     ($_ <>.or
         (<code>.form (<>#in []))
         <code>.bit
         <code>.frac
         <code>.text
         (<>#each sequence.of_list
                  (<code>.tuple (<>.some jsonP)))
         (<>#each (dictionary.of_list text.hash)
                  (<code>.variant (<>.some (<>.and <code>.text jsonP))))
         <code>.any
         ))))

(def: (jsonF token)
  (-> JSON' Code)
  (case token
    {#Null' _}
    (` {..#Null})
    
    (^.template [<ctor> <input_tag> <output_tag>]
      [{<input_tag> value}
       (` {<output_tag> (~ (<ctor> value))})])
    ([code.bit  ..#Boolean' ..#Boolean]
     [code.frac ..#Number' ..#Number]
     [code.text ..#String' ..#String])
    
    {#Array' members}
    (` {..#Array ((~! sequence.sequence) (~+ (sequence.list (sequence#each jsonF members))))})

    {#Object' pairs}
    (` {..#Object ((~! dictionary.of_list)
                   (~! text.hash)
                   (list (~+ (|> pairs
                                 dictionary.entries
                                 (list#each (function (_ [key_name value])
                                              (` [(~ (code.text key_name)) (~ (jsonF value))])))))))})

    {#Code' code}
    code))

(syntax: .public (json [token ..jsonP])
  (in (list (` (is JSON (~ (jsonF token)))))))

(def: .public (fields json)
  (-> JSON (Try (List String)))
  (case json
    {#Object obj}
    {try.#Success (dictionary.keys obj)}

    _
    {try.#Failure ($_ text#composite "Cannot get the fields of a non-object.")}))

(def: .public (field key json)
  (-> String JSON (Try JSON))
  (case json
    {#Object obj}
    (case (dictionary.value key obj)
      {.#Some value}
      {try.#Success value}

      {.#None}
      {try.#Failure ($_ text#composite "Missing field '" key "' on object.")})

    _
    {try.#Failure ($_ text#composite "Cannot get field '" key "' on a non-object.")}))

(def: .public (has key value json)
  (-> String JSON JSON (Try JSON))
  (case json
    {#Object obj}
    {try.#Success {#Object (dictionary.has key value obj)}}

    _
    {try.#Failure ($_ text#composite "Cannot set field '" key "' on a non-object.")}))

(template [<name> <tag> <type>]
  [(def: .public (<name> key json)
     (-> Text JSON (Try <type>))
     (case (field key json)
       {try.#Success {<tag> value}}
       {try.#Success value}

       {try.#Success _}
       {try.#Failure ($_ text#composite "Wrong value type at key: " key)}

       {try.#Failure error}
       {try.#Failure error}))]

  [boolean_field #Boolean Boolean]
  [number_field  #Number  Number]
  [string_field  #String  String]
  [array_field   #Array   Array]
  [object_field  #Object  Object]
  )

(implementation: .public equivalence
  (Equivalence JSON)
  
  (def: (= x y)
    (case [x y]
      [{#Null} {#Null}]
      #1

      (^.template [<tag> <struct>]
        [[{<tag> x'} {<tag> y'}]
         (# <struct> = x' y')])
      ([#Boolean bit.equivalence]
       [#Number  f.equivalence]
       [#String  text.equivalence])

      [{#Array xs} {#Array ys}]
      (and (n.= (sequence.size xs) (sequence.size ys))
           (list#mix (function (_ idx prev)
                       (and prev
                            (maybe.else #0
                                        (do maybe.monad
                                          [x' (sequence.item idx xs)
                                           y' (sequence.item idx ys)]
                                          (in (= x' y'))))))
                     #1
                     (list.indices (sequence.size xs))))
      
      [{#Object xs} {#Object ys}]
      (and (n.= (dictionary.size xs) (dictionary.size ys))
           (list#mix (function (_ [xk xv] prev)
                       (and prev
                            (case (dictionary.value xk ys)
                              {.#None}    #0
                              {.#Some yv} (= xv yv))))
                     #1
                     (dictionary.entries xs)))
      
      _
      #0)))

............................................................
............................................................
............................................................

(def: (null_format _)
  (-> Null Text)
  "null")

(def: boolean_format
  (-> Boolean Text)
  (|>> (pipe.case
         #0 "false"
         #1 "true")))

(def: number_format
  (-> Number Text)
  (|>> (pipe.case
         +0.0 ... OR -0.0
         "0.0"

         value
         (let [raw (# f.decimal encoded value)]
           (if (f.< +0.0 value)
             raw
             (|> raw (text.split_at 1) maybe.trusted product.right))))))

(def: escape "\")
(def: escaped_dq (text#composite ..escape text.double_quote))

(def: string_format
  (-> String Text)
  (|>> (text.replaced text.double_quote ..escaped_dq)
       (text.enclosed [text.double_quote text.double_quote])))

(template [<token> <name>]
  [(def: <name>
     Text
     <token>)]

  ["," value_separator]
  [":" entry_separator]

  ["[" array_start]
  ["]" array_end]

  ["{" object_start]
  ["}" object_end]
  )

(def: (array_format format)
  (-> (-> JSON Text) (-> Array Text))
  (|>> (sequence#each format)
       sequence.list
       (text.interposed ..value_separator)
       (text.enclosed [..array_start ..array_end])))

(def: (kv_format format [key value])
  (-> (-> JSON Text) (-> [String JSON] Text))
  ($_ text#composite
      (..string_format key)
      ..entry_separator
      (format value)
      ))

(def: (object_format format)
  (-> (-> JSON Text) (-> Object Text))
  (|>> dictionary.entries
       (list#each (..kv_format format))
       (text.interposed ..value_separator)
       (text.enclosed [..object_start ..object_end])))

(def: .public (format json)
  (-> JSON Text)
  (case json
    (^.template [<tag> <format>]
      [{<tag> value}
       (<format> value)])
    ([#Null    ..null_format]
     [#Boolean ..boolean_format]
     [#Number  ..number_format]
     [#String  ..string_format]
     [#Array   (..array_format format)]
     [#Object  (..object_format format)])
    ))

............................................................
............................................................
............................................................

(def: space_parser
  (Parser Text)
  (<text>.some <text>.space))

(def: value_separator_parser
  (Parser [Text Any Text])
  ($_ <>.and
      ..space_parser
      (<text>.this ..value_separator)
      ..space_parser))

(def: null_parser
  (Parser Null)
  (do <>.monad
    [_ (<text>.this "null")]
    (in [])))

(template [<name> <token> <value>]
  [(def: <name>
     (Parser Boolean)
     (do <>.monad
       [_ (<text>.this <token>)]
       (in <value>)))]

  [true_parser  "true"  #1]
  [false_parser "false" #0]
  )

(def: boolean_parser
  (Parser Boolean)
  ($_ <>.either
      ..true_parser
      ..false_parser))

(def: number_parser
  (Parser Number)
  (do [! <>.monad]
    [signed? (<>.parses? (<text>.this "-"))
     digits (<text>.many <text>.decimal)
     decimals (<>.else "0"
                       (do !
                         [_ (<text>.this ".")]
                         (<text>.many <text>.decimal)))
     exp (<>.else ""
                  (do !
                    [mark (<text>.one_of "eE")
                     signed?' (<>.parses? (<text>.this "-"))
                     offset (<text>.many <text>.decimal)]
                    (in ($_ text#composite mark (if signed?' "-" "") offset))))]
    (case (f#decoded ($_ text#composite (if signed? "-" "") digits "." decimals exp))
      {try.#Failure message}
      (<>.failure message)
      
      {try.#Success value}
      (in value))))

(def: escaped_parser
  (Parser Text)
  ($_ <>.either
      (<>.after (<text>.this "\t")
                (<>#in text.tab))
      (<>.after (<text>.this "\b")
                (<>#in text.back_space))
      (<>.after (<text>.this "\n")
                (<>#in text.new_line))
      (<>.after (<text>.this "\r")
                (<>#in text.carriage_return))
      (<>.after (<text>.this "\f")
                (<>#in text.form_feed))
      (<>.after (<text>.this (text#composite "\" text.double_quote))
                (<>#in text.double_quote))
      (<>.after (<text>.this "\\")
                (<>#in "\"))))

(def: string_parser
  (Parser String)
  (<| (<text>.enclosed [text.double_quote text.double_quote])
      (loop [_ []])
      (do [! <>.monad]
        [chars (<text>.some (<text>.none_of (text#composite "\" text.double_quote)))
         stop <text>.next])
      (if (text#= "\" stop)
        (do !
          [escaped escaped_parser
           next_chars (again [])]
          (in ($_ text#composite chars escaped next_chars)))
        (in chars))))

(def: (kv_parser json_parser)
  (-> (Parser JSON) (Parser [String JSON]))
  (do <>.monad
    [key ..string_parser
     _ ..space_parser
     _ (<text>.this ..entry_separator)
     _ ..space_parser
     value json_parser]
    (in [key value])))

(template [<name> <type> <open> <close> <elem_parser> <prep>]
  [(def: (<name> json_parser)
     (-> (Parser JSON) (Parser <type>))
     (do <>.monad
       [_ (<text>.this <open>)
        _ space_parser
        elems (<>.separated_by ..value_separator_parser <elem_parser>)
        _ space_parser
        _ (<text>.this <close>)]
       (in (<prep> elems))))]

  [array_parser  Array  ..array_start ..array_end json_parser sequence.of_list]
  [object_parser Object ..object_start ..object_end (kv_parser json_parser) (dictionary.of_list text.hash)]
  )

(def: json_parser
  (Parser JSON)
  (<>.rec
   (function (_ json_parser)
     ($_ <>.or
         null_parser
         boolean_parser
         number_parser
         string_parser
         (array_parser json_parser)
         (object_parser json_parser)))))

(implementation: .public codec
  (Codec Text JSON)
  
  (def: encoded ..format)
  (def: decoded (<text>.result json_parser)))