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

(.module: {#.doc (.doc "Functionality for reading and writing values in the JSON format."
                       "For more information, please see: http://www.json.org/")}
  [library
   [lux #*
    ["." meta (#+ monad)]
    [abstract
     [equivalence (#+ Equivalence)]
     [codec (#+ Codec)]
     [predicate (#+ Predicate)]
     ["." monad (#+ do)]]
    [control
     pipe
     ["." try (#+ Try)]
     ["<>" parser ("#\." monad)
      ["<.>" text (#+ Parser)]]]
    [data
     ["." bit]
     ["." maybe]
     ["." product]
     ["." text ("#\." equivalence monoid)]
     [collection
      ["." list ("#\." fold functor)]
      ["." row (#+ Row row) ("#\." monad)]
      ["." dictionary (#+ Dictionary)]]]
    [macro (#+ with_gensyms)
     [syntax (#+ syntax:)]
     ["." code]]
    [math
     [number
      ["n" nat]
      ["f" frac ("#\." decimal)]]]]])

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

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

(type: #export #rec JSON
  (#Null    Null)
  (#Boolean Boolean)
  (#Number  Number)
  (#String  String)
  (#Array   (Row JSON))
  (#Object  (Dictionary String JSON)))

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

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

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

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

(syntax: #export (json token)
  {#.doc (doc "A simple way to produce JSON literals."
              (json #null)
              (json #1)
              (json +123.456)
              (json "this is a string")
              (json ["this" "is" "an" "array"])
              (json {"this" "is"
                     "an" "object"}))}
  (let [(^open ".") ..monad
        wrapper (function (_ x) (` (..json (~ x))))]
    (case token
      (^template [<ast_tag> <ctor> <json_tag>]
        [[_ (<ast_tag> value)]
         (wrap (list (` (: JSON (<json_tag> (~ (<ctor> value)))))))])
      ([#.Bit  code.bit  #..Boolean]
       [#.Frac code.frac #..Number]
       [#.Text code.text #..String])

      [_ (#.Tag ["" "null"])]
      (wrap (list (` (: JSON #..Null))))

      [_ (#.Tuple members)]
      (wrap (list (` (: JSON (#..Array ((~! row) (~+ (list\map wrapper members))))))))

      [_ (#.Record pairs)]
      (do {! ..monad}
        [pairs' (monad.map !
                           (function (_ [slot value])
                             (case slot
                               [_ (#.Text key_name)]
                               (wrap (` [(~ (code.text key_name)) (~ (wrapper value))]))

                               _
                               (meta.fail "Wrong syntax for JSON object.")))
                           pairs)]
        (wrap (list (` (: JSON (#..Object ((~! dictionary.from_list)
                                           (~! text.hash)
                                           (list (~+ pairs')))))))))
      
      _
      (wrap (list token)))))

(def: #export (fields json)
  {#.doc "Get all the fields in a JSON object."}
  (-> JSON (Try (List String)))
  (case json
    (#Object obj)
    (#try.Success (dictionary.keys obj))

    _
    (#try.Failure ($_ text\compose "Cannot get the fields of a non-object."))))

(def: #export (get key json)
  {#.doc "A JSON object field getter."}
  (-> String JSON (Try JSON))
  (case json
    (#Object obj)
    (case (dictionary.get key obj)
      (#.Some value)
      (#try.Success value)

      #.None
      (#try.Failure ($_ text\compose "Missing field '" key "' on object.")))

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

(def: #export (set key value json)
  {#.doc "A JSON object field setter."}
  (-> String JSON JSON (Try JSON))
  (case json
    (#Object obj)
    (#try.Success (#Object (dictionary.put key value obj)))

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

(template [<name> <tag> <type> <desc>]
  [(def: #export (<name> key json)
     {#.doc (code.text ($_ text\compose "A JSON object field getter for " <desc> "."))}
     (-> Text JSON (Try <type>))
     (case (get key json)
       (#try.Success (<tag> value))
       (#try.Success value)

       (#try.Success _)
       (#try.Failure ($_ text\compose "Wrong value type at key: " key))

       (#try.Failure error)
       (#try.Failure error)))]

  [get_boolean #Boolean Boolean "booleans"]
  [get_number  #Number  Number  "numbers"]
  [get_string  #String  String  "strings"]
  [get_array   #Array   Array   "arrays"]
  [get_object  #Object  Object  "objects"]
  )

(implementation: #export 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\fold (function (_ idx prev)
                        (and prev
                             (maybe.default #0
                                            (do maybe.monad
                                              [x' (row.nth idx xs)
                                               y' (row.nth idx ys)]
                                              (wrap (= x' y'))))))
                      #1
                      (list.indices (row.size xs))))
      
      [(#Object xs) (#Object ys)]
      (and (n.= (dictionary.size xs) (dictionary.size ys))
           (list\fold (function (_ [xk xv] prev)
                        (and prev
                             (case (dictionary.get xk ys)
                               #.None   #0
                               (#.Some yv) (= xv yv))))
                      #1
                      (dictionary.entries xs)))
      
      _
      #0)))

############################################################
############################################################
############################################################

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

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

(def: format_number
  (-> Number Text)
  (|>> (case>
        (^or +0.0 -0.0) "0.0"
        value (let [raw (\ f.decimal encode value)]
                (if (f.< +0.0 value)
                  raw
                  (|> raw (text.split 1) maybe.assume product.right))))))

(def: escape "\")
(def: escaped_dq (text\compose ..escape text.double_quote))

(def: format_string
  (-> String Text)
  (|>> (text.replace_all text.double_quote ..escaped_dq)
       (text.enclose [text.double_quote text.double_quote])))

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

  ["," separator]
  [":" entry_separator]

  ["[" open_array]
  ["]" close_array]

  ["{" open_object]
  ["}" close_object]
  )

(def: (format_array format)
  (-> (-> JSON Text) (-> Array Text))
  (|>> (row\map format)
       row.to_list
       (text.join_with ..separator)
       (text.enclose [..open_array ..close_array])))

(def: (format_kv format [key value])
  (-> (-> JSON Text) (-> [String JSON] Text))
  ($_ text\compose
      (..format_string key)
      ..entry_separator
      (format value)
      ))

(def: (format_object format)
  (-> (-> JSON Text) (-> Object Text))
  (|>> dictionary.entries
       (list\map (..format_kv format))
       (text.join_with ..separator)
       (text.enclose [..open_object ..close_object])))

(def: #export (format json)
  (-> JSON Text)
  (case json
    (^template [<tag> <format>]
      [(<tag> value)
       (<format> value)])
    ([#Null    ..format_null]
     [#Boolean ..format_boolean]
     [#Number  ..format_number]
     [#String  ..format_string]
     [#Array   (..format_array format)]
     [#Object  (..format_object format)])
    ))

############################################################
############################################################
############################################################

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

(def: parse_separator
  (Parser [Text Any Text])
  ($_ <>.and
      ..parse_space
      (<text>.this ..separator)
      ..parse_space))

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

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

  [parse_true  "true"  #1]
  [parse_false "false" #0]
  )

(def: parse_boolean
  (Parser Boolean)
  ($_ <>.either
      ..parse_true
      ..parse_false))

(def: parse_number
  (Parser Number)
  (do {! <>.monad}
    [signed? (<>.parses? (<text>.this "-"))
     digits (<text>.many <text>.decimal)
     decimals (<>.default "0"
                          (do !
                            [_ (<text>.this ".")]
                            (<text>.many <text>.decimal)))
     exp (<>.default ""
                     (do !
                       [mark (<text>.one_of "eE")
                        signed?' (<>.parses? (<text>.this "-"))
                        offset (<text>.many <text>.decimal)]
                       (wrap ($_ text\compose mark (if signed?' "-" "") offset))))]
    (case (f\decode ($_ text\compose (if signed? "-" "") digits "." decimals exp))
      (#try.Failure message)
      (<>.fail message)
      
      (#try.Success value)
      (wrap value))))

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

(def: parse_string
  (Parser String)
  (<| (<text>.enclosed [text.double_quote text.double_quote])
      (loop [_ []])
      (do {! <>.monad}
        [chars (<text>.some (<text>.none_of (text\compose "\" text.double_quote)))
         stop <text>.peek])
      (if (text\= "\" stop)
        (do !
          [escaped parse_escaped
           next_chars (recur [])]
          (wrap ($_ text\compose chars escaped next_chars)))
        (wrap chars))))

(def: (parse_kv parse_json)
  (-> (Parser JSON) (Parser [String JSON]))
  (do <>.monad
    [key ..parse_string
     _ ..parse_space
     _ (<text>.this ..entry_separator)
     _ ..parse_space
     value parse_json]
    (wrap [key value])))

(template [<name> <type> <open> <close> <elem_parser> <prep>]
  [(def: (<name> parse_json)
     (-> (Parser JSON) (Parser <type>))
     (do <>.monad
       [_ (<text>.this <open>)
        _ parse_space
        elems (<>.separated_by ..parse_separator <elem_parser>)
        _ parse_space
        _ (<text>.this <close>)]
       (wrap (<prep> elems))))]

  [parse_array  Array  ..open_array ..close_array parse_json  row.from_list]
  [parse_object Object ..open_object ..close_object (parse_kv parse_json) (dictionary.from_list text.hash)]
  )

(def: parse_json
  (Parser JSON)
  (<>.rec
   (function (_ parse_json)
     ($_ <>.or
         parse_null
         parse_boolean
         parse_number
         parse_string
         (parse_array parse_json)
         (parse_object parse_json)))))

(implementation: #export codec
  (Codec Text JSON)
  
  (def: encode ..format)
  (def: decode (<text>.run parse_json)))