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

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

(with_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)})))

(with_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)
     (all <>.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})
    
    (^.with_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))

(def .public json
  (syntax (_ [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 (all 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 (all text#composite "Missing field '" key "' on object.")})

    _
    {try.#Failure (all 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 (all text#composite "Cannot set field '" key "' on a non-object.")}))

(with_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 (all 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]
  )

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

       (^.with_template [<tag> <struct>]
         [[{<tag> x'} {<tag> y'}]
          (at <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 (at 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])))

(with_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))
  (all 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
    (^.with_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])
  (all <>.and
       ..space_parser
       (<text>.this ..value_separator)
       ..space_parser))

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

(with_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)
  (all <>.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 (all text#composite mark (if signed?' "-" "") offset))))]
    (case (f#decoded (all text#composite (if signed? "-" "") digits "." decimals exp))
      {try.#Failure message}
      (<>.failure message)
      
      {try.#Success value}
      (in value))))

(def escaped_parser
  (Parser Text)
  (all <>.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 (again [_ []]))
      (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 (all 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])))

(with_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)
     (all <>.or
          null_parser
          boolean_parser
          number_parser
          string_parser
          (array_parser json_parser)
          (object_parser json_parser)))))

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