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

(.module:
  [library
   [lux "*"
    ["[0]" meta {"+" [monad]}]
    [abstract
     [equivalence {"+" [Equivalence]}]
     [codec {"+" [Codec]}]
     [predicate {"+" [Predicate]}]
     ["[0]" monad {"+" [do]}]]
    [control
     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]" row {"+" [Row row]} ("[1]\[0]" monad)]
      ["[0]" dictionary {"+" [Dictionary]}]]]
    [macro
     [syntax {"+" [syntax:]}]
     ["[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   (Row JSON)}
     {#Object  (Dictionary String JSON)})))

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

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

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

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

(def: jsonP
  (<code>.Parser JSON)
  (<>.rec
   (function (_ jsonP)
     ($_ <>.or
         (<code>.local_tag! "null")
         <code>.bit
         <code>.frac
         <code>.text
         (<>\each row.of_list
                  (<code>.tuple (<>.some jsonP)))
         (<>\each (dictionary.of_list text.hash)
                  (<code>.variant (<>.some (<>.and <code>.text jsonP))))
         ))))

(def: (jsonF token)
  (-> JSON Code)
  (case token
    {#Null _}
    (` #..Null)
    
    (^template [<ctor> <json_tag>]
      [{<json_tag> value}
       (` {<json_tag> (~ (<ctor> value))})])
    ([code.bit  #..Boolean]
     [code.frac #..Number]
     [code.text #..String])
    
    {#Array members}
    (` {#..Array ((~! row.row) (~+ (row.list (row\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))])))))))})))

(syntax: .public (json [token ..jsonP])
  (in (list (` (: 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.= (row.size xs) (row.size ys))
           (list\mix (function (_ idx prev)
                       (and prev
                            (maybe.else #0
                                        (do maybe.monad
                                          [x' (row.item idx xs)
                                           y' (row.item idx ys)]
                                          (in (= x' y'))))))
                     #1
                     (list.indices (row.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)
  (|>> (case>
        #0 "false"
        #1 "true")))

(def: number_format
  (-> Number Text)
  (|>> (case>
        (^or +0.0 -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))
  (|>> (row\each format)
       row.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 (recur [])]
          (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 row.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)))